parser-moids-coerce.c
1 //! @file parser-moids-coerce.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Mode coercion driver.
25
26 #include "a68g.h"
27 #include "a68g-parser.h"
28 #include "a68g-prelude.h"
29 #include "a68g-moids.h"
30
31 //! @brief Coerce bounds.
32
33 void coerce_bounds (NODE_T * p)
34 {
35 for (; p != NO_NODE; FORWARD (p)) {
36 if (IS (p, UNIT)) {
37 SOID_T q;
38 make_soid (&q, MEEK, M_INT, 0);
39 coerce_unit (p, &q);
40 } else {
41 coerce_bounds (SUB (p));
42 }
43 }
44 }
45
46 //! @brief Coerce declarer.
47
48 void coerce_declarer (NODE_T * p)
49 {
50 for (; p != NO_NODE; FORWARD (p)) {
51 if (IS (p, BOUNDS)) {
52 coerce_bounds (SUB (p));
53 } else {
54 coerce_declarer (SUB (p));
55 }
56 }
57 }
58
59 //! @brief Coerce identity declaration.
60
61 void coerce_identity_declaration (NODE_T * p)
62 {
63 if (p != NO_NODE) {
64 switch (ATTRIBUTE (p)) {
65 case DECLARER:
66 {
67 coerce_declarer (SUB (p));
68 coerce_identity_declaration (NEXT (p));
69 break;
70 }
71 case DEFINING_IDENTIFIER:
72 {
73 SOID_T q;
74 make_soid (&q, STRONG, MOID (p), 0);
75 coerce_unit (NEXT_NEXT (p), &q);
76 break;
77 }
78 default:
79 {
80 coerce_identity_declaration (SUB (p));
81 coerce_identity_declaration (NEXT (p));
82 break;
83 }
84 }
85 }
86 }
87
88 //! @brief Coerce variable declaration.
89
90 void coerce_variable_declaration (NODE_T * p)
91 {
92 if (p != NO_NODE) {
93 switch (ATTRIBUTE (p)) {
94 case DECLARER:
95 {
96 coerce_declarer (SUB (p));
97 coerce_variable_declaration (NEXT (p));
98 break;
99 }
100 case DEFINING_IDENTIFIER:
101 {
102 if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
103 SOID_T q;
104 make_soid (&q, STRONG, SUB_MOID (p), 0);
105 coerce_unit (NEXT_NEXT (p), &q);
106 break;
107 }
108 }
109 default:
110 {
111 coerce_variable_declaration (SUB (p));
112 coerce_variable_declaration (NEXT (p));
113 break;
114 }
115 }
116 }
117 }
118
119 //! @brief Coerce routine text.
120
121 void coerce_routine_text (NODE_T * p)
122 {
123 SOID_T w;
124 if (IS (p, PARAMETER_PACK)) {
125 FORWARD (p);
126 }
127 make_soid (&w, STRONG, MOID (p), 0);
128 coerce_unit (NEXT_NEXT (p), &w);
129 }
130
131 //! @brief Coerce proc declaration.
132
133 void coerce_proc_declaration (NODE_T * p)
134 {
135 if (p == NO_NODE) {
136 return;
137 } else if (IS (p, ROUTINE_TEXT)) {
138 coerce_routine_text (SUB (p));
139 } else {
140 coerce_proc_declaration (SUB (p));
141 coerce_proc_declaration (NEXT (p));
142 }
143 }
144
145 //! @brief Coerce_op_declaration.
146
147 void coerce_op_declaration (NODE_T * p)
148 {
149 if (p == NO_NODE) {
150 return;
151 } else if (IS (p, DEFINING_OPERATOR)) {
152 SOID_T q;
153 make_soid (&q, STRONG, MOID (p), 0);
154 coerce_unit (NEXT_NEXT (p), &q);
155 } else {
156 coerce_op_declaration (SUB (p));
157 coerce_op_declaration (NEXT (p));
158 }
159 }
160
161 //! @brief Coerce brief op declaration.
162
163 void coerce_brief_op_declaration (NODE_T * p)
164 {
165 if (p == NO_NODE) {
166 return;
167 } else if (IS (p, DEFINING_OPERATOR)) {
168 coerce_routine_text (SUB (NEXT_NEXT (p)));
169 } else {
170 coerce_brief_op_declaration (SUB (p));
171 coerce_brief_op_declaration (NEXT (p));
172 }
173 }
174
175 //! @brief Coerce declaration list.
176
177 void coerce_declaration_list (NODE_T * p)
178 {
179 if (p != NO_NODE) {
180 switch (ATTRIBUTE (p)) {
181 case IDENTITY_DECLARATION:
182 {
183 coerce_identity_declaration (SUB (p));
184 break;
185 }
186 case VARIABLE_DECLARATION:
187 {
188 coerce_variable_declaration (SUB (p));
189 break;
190 }
191 case MODE_DECLARATION:
192 {
193 coerce_declarer (SUB (p));
194 break;
195 }
196 case PROCEDURE_DECLARATION:
197 case PROCEDURE_VARIABLE_DECLARATION:
198 {
199 coerce_proc_declaration (SUB (p));
200 break;
201 }
202 case BRIEF_OPERATOR_DECLARATION:
203 {
204 coerce_brief_op_declaration (SUB (p));
205 break;
206 }
207 case OPERATOR_DECLARATION:
208 {
209 coerce_op_declaration (SUB (p));
210 break;
211 }
212 default:
213 {
214 coerce_declaration_list (SUB (p));
215 coerce_declaration_list (NEXT (p));
216 break;
217 }
218 }
219 }
220 }
221
222 //! @brief Coerce serial.
223
224 void coerce_serial (NODE_T * p, SOID_T * q, BOOL_T k)
225 {
226 if (p == NO_NODE) {
227 return;
228 } else if (IS (p, INITIALISER_SERIES)) {
229 coerce_serial (SUB (p), q, A68_FALSE);
230 coerce_serial (NEXT (p), q, k);
231 } else if (IS (p, DECLARATION_LIST)) {
232 coerce_declaration_list (SUB (p));
233 } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
234 coerce_serial (NEXT (p), q, k);
235 } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
236 NODE_T *z = NEXT (p);
237 if (z != NO_NODE) {
238 if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL) || IS (z, OCCA_SYMBOL)) {
239 coerce_serial (SUB (p), q, A68_TRUE);
240 } else {
241 coerce_serial (SUB (p), q, A68_FALSE);
242 }
243 } else {
244 coerce_serial (SUB (p), q, A68_TRUE);
245 }
246 coerce_serial (NEXT (p), q, k);
247 } else if (IS (p, LABELED_UNIT)) {
248 coerce_serial (SUB (p), q, k);
249 } else if (IS (p, UNIT)) {
250 if (k) {
251 coerce_unit (p, q);
252 } else {
253 SOID_T strongvoid;
254 make_soid (&strongvoid, STRONG, M_VOID, 0);
255 coerce_unit (p, &strongvoid);
256 }
257 }
258 }
259
260 //! @brief Coerce closed.
261
262 void coerce_closed (NODE_T * p, SOID_T * q)
263 {
264 if (IS (p, SERIAL_CLAUSE)) {
265 coerce_serial (p, q, A68_TRUE);
266 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
267 coerce_closed (NEXT (p), q);
268 }
269 }
270
271 //! @brief Coerce conditional.
272
273 void coerce_conditional (NODE_T * p, SOID_T * q)
274 {
275 SOID_T w;
276 make_soid (&w, MEEK, M_BOOL, 0);
277 coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
278 FORWARD (p);
279 coerce_serial (NEXT_SUB (p), q, A68_TRUE);
280 if ((FORWARD (p)) != NO_NODE) {
281 if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
282 coerce_serial (NEXT_SUB (p), q, A68_TRUE);
283 } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
284 coerce_conditional (SUB (p), q);
285 }
286 }
287 }
288
289 //! @brief Coerce unit list.
290
291 void coerce_unit_list (NODE_T * p, SOID_T * q)
292 {
293 if (p == NO_NODE) {
294 return;
295 } else if (IS (p, UNIT_LIST)) {
296 coerce_unit_list (SUB (p), q);
297 coerce_unit_list (NEXT (p), q);
298 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) {
299 coerce_unit_list (NEXT (p), q);
300 } else if (IS (p, UNIT)) {
301 coerce_unit (p, q);
302 coerce_unit_list (NEXT (p), q);
303 }
304 }
305
306 //! @brief Coerce int case.
307
308 void coerce_int_case (NODE_T * p, SOID_T * q)
309 {
310 SOID_T w;
311 make_soid (&w, MEEK, M_INT, 0);
312 coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
313 FORWARD (p);
314 coerce_unit_list (NEXT_SUB (p), q);
315 if ((FORWARD (p)) != NO_NODE) {
316 if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
317 coerce_serial (NEXT_SUB (p), q, A68_TRUE);
318 } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
319 coerce_int_case (SUB (p), q);
320 }
321 }
322 }
323
324 //! @brief Coerce spec unit list.
325
326 void coerce_spec_unit_list (NODE_T * p, SOID_T * q)
327 {
328 for (; p != NO_NODE; FORWARD (p)) {
329 if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
330 coerce_spec_unit_list (SUB (p), q);
331 } else if (IS (p, UNIT)) {
332 coerce_unit (p, q);
333 }
334 }
335 }
336
337 //! @brief Coerce united case.
338
339 void coerce_united_case (NODE_T * p, SOID_T * q)
340 {
341 SOID_T w;
342 make_soid (&w, MEEK, MOID (SUB (p)), 0);
343 coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
344 FORWARD (p);
345 coerce_spec_unit_list (NEXT_SUB (p), q);
346 if ((FORWARD (p)) != NO_NODE) {
347 if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
348 coerce_serial (NEXT_SUB (p), q, A68_TRUE);
349 } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
350 coerce_united_case (SUB (p), q);
351 }
352 }
353 }
354
355 //! @brief Coerce loop.
356
357 void coerce_loop (NODE_T * p)
358 {
359 if (IS (p, FOR_PART)) {
360 coerce_loop (NEXT (p));
361 } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
362 SOID_T w;
363 make_soid (&w, MEEK, M_INT, 0);
364 coerce_unit (NEXT_SUB (p), &w);
365 coerce_loop (NEXT (p));
366 } else if (IS (p, WHILE_PART)) {
367 SOID_T w;
368 make_soid (&w, MEEK, M_BOOL, 0);
369 coerce_serial (NEXT_SUB (p), &w, A68_TRUE);
370 coerce_loop (NEXT (p));
371 } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
372 SOID_T w;
373 NODE_T *do_p = NEXT_SUB (p), *un_p;
374 make_soid (&w, STRONG, M_VOID, 0);
375 coerce_serial (do_p, &w, A68_TRUE);
376 if (IS (do_p, SERIAL_CLAUSE)) {
377 un_p = NEXT (do_p);
378 } else {
379 un_p = do_p;
380 }
381 if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
382 SOID_T sw;
383 make_soid (&sw, MEEK, M_BOOL, 0);
384 coerce_serial (NEXT_SUB (un_p), &sw, A68_TRUE);
385 }
386 }
387 }
388
389 //! @brief Coerce struct display.
390
391 void coerce_struct_display (PACK_T ** r, NODE_T * p)
392 {
393 if (p == NO_NODE) {
394 return;
395 } else if (IS (p, UNIT_LIST)) {
396 coerce_struct_display (r, SUB (p));
397 coerce_struct_display (r, NEXT (p));
398 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) {
399 coerce_struct_display (r, NEXT (p));
400 } else if (IS (p, UNIT)) {
401 SOID_T s;
402 make_soid (&s, STRONG, MOID (*r), 0);
403 coerce_unit (p, &s);
404 FORWARD (*r);
405 coerce_struct_display (r, NEXT (p));
406 }
407 }
408
409 //! @brief Coerce collateral.
410
411 void coerce_collateral (NODE_T * p, SOID_T * q)
412 {
413 if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) {
414 if (IS (MOID (q), STRUCT_SYMBOL)) {
415 PACK_T *t = PACK (MOID (q));
416 coerce_struct_display (&t, p);
417 } else if (IS_FLEX (MOID (q))) {
418 SOID_T w;
419 make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0);
420 coerce_unit_list (p, &w);
421 } else if (IS_ROW (MOID (q))) {
422 SOID_T w;
423 make_soid (&w, STRONG, SLICE (MOID (q)), 0);
424 coerce_unit_list (p, &w);
425 } else {
426 // if (MOID (q) != M_VOID).
427 coerce_unit_list (p, q);
428 }
429 }
430 }
431
432 //! @brief Coerce_enclosed.
433
434 void coerce_enclosed (NODE_T * p, SOID_T * q)
435 {
436 if (IS (p, ENCLOSED_CLAUSE)) {
437 coerce_enclosed (SUB (p), q);
438 } else if (IS (p, CLOSED_CLAUSE)) {
439 coerce_closed (SUB (p), q);
440 } else if (IS (p, COLLATERAL_CLAUSE)) {
441 coerce_collateral (SUB (p), q);
442 } else if (IS (p, PARALLEL_CLAUSE)) {
443 coerce_collateral (SUB (NEXT_SUB (p)), q);
444 } else if (IS (p, CONDITIONAL_CLAUSE)) {
445 coerce_conditional (SUB (p), q);
446 } else if (IS (p, CASE_CLAUSE)) {
447 coerce_int_case (SUB (p), q);
448 } else if (IS (p, CONFORMITY_CLAUSE)) {
449 coerce_united_case (SUB (p), q);
450 } else if (IS (p, LOOP_CLAUSE)) {
451 coerce_loop (SUB (p));
452 }
453 MOID (p) = depref_rows (MOID (p), MOID (q));
454 }
455
456 //! @brief Get monad moid.
457
458 MOID_T *get_monad_moid (NODE_T * p)
459 {
460 if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag)) {
461 MOID (p) = MOID (TAX (p));
462 return MOID (PACK (MOID (p)));
463 } else {
464 return M_ERROR;
465 }
466 }
467
468 //! @brief Coerce monad oper.
469
470 void coerce_monad_oper (NODE_T * p, SOID_T * q)
471 {
472 if (p != NO_NODE) {
473 SOID_T z;
474 make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0);
475 INSERT_COERCIONS (NEXT (p), MOID (q), &z);
476 }
477 }
478
479 //! @brief Coerce monad formula.
480
481 void coerce_monad_formula (NODE_T * p)
482 {
483 SOID_T e;
484 make_soid (&e, STRONG, get_monad_moid (p), 0);
485 coerce_operand (NEXT (p), &e);
486 coerce_monad_oper (p, &e);
487 }
488
489 //! @brief Coerce operand.
490
491 void coerce_operand (NODE_T * p, SOID_T * q)
492 {
493 if (IS (p, MONADIC_FORMULA)) {
494 coerce_monad_formula (SUB (p));
495 if (MOID (p) != MOID (q)) {
496 make_sub (p, p, FORMULA);
497 INSERT_COERCIONS (p, MOID (p), q);
498 make_sub (p, p, TERTIARY);
499 }
500 MOID (p) = depref_rows (MOID (p), MOID (q));
501 } else if (IS (p, FORMULA)) {
502 coerce_formula (SUB (p), q);
503 INSERT_COERCIONS (p, MOID (p), q);
504 MOID (p) = depref_rows (MOID (p), MOID (q));
505 } else if (IS (p, SECONDARY)) {
506 coerce_unit (SUB (p), q);
507 MOID (p) = MOID (SUB (p));
508 }
509 }
510
511 //! @brief Coerce formula.
512
513 void coerce_formula (NODE_T * p, SOID_T * q)
514 {
515 (void) q;
516 if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE) {
517 coerce_monad_formula (SUB (p));
518 } else {
519 if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != A68_PARSER (error_tag)) {
520 SOID_T s;
521 NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p);
522 MOID_T *w = MOID (op);
523 MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w)));
524 make_soid (&s, STRONG, u, 0);
525 coerce_operand (p, &s);
526 make_soid (&s, STRONG, v, 0);
527 coerce_operand (nq, &s);
528 }
529 }
530 }
531
532 //! @brief Coerce assignation.
533
534 void coerce_assignation (NODE_T * p)
535 {
536 SOID_T w;
537 make_soid (&w, SOFT, MOID (p), 0);
538 coerce_unit (SUB (p), &w);
539 make_soid (&w, STRONG, SUB_MOID (p), 0);
540 coerce_unit (NEXT_NEXT (p), &w);
541 }
542
543 //! @brief Coerce relation.
544
545 void coerce_relation (NODE_T * p)
546 {
547 SOID_T w;
548 make_soid (&w, STRONG, MOID (p), 0);
549 coerce_unit (SUB (p), &w);
550 make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0);
551 coerce_unit (SUB (NEXT_NEXT (p)), &w);
552 }
553
554 //! @brief Coerce bool function.
555
556 void coerce_bool_function (NODE_T * p)
557 {
558 SOID_T w;
559 make_soid (&w, STRONG, M_BOOL, 0);
560 coerce_unit (SUB (p), &w);
561 coerce_unit (SUB (NEXT_NEXT (p)), &w);
562 }
563
564 //! @brief Coerce assertion.
565
566 void coerce_assertion (NODE_T * p)
567 {
568 SOID_T w;
569 make_soid (&w, MEEK, M_BOOL, 0);
570 coerce_enclosed (SUB_NEXT (p), &w);
571 }
572
573 //! @brief Coerce selection.
574
575 void coerce_selection (NODE_T * p)
576 {
577 SOID_T w;
578 make_soid (&w, STRONG, MOID (NEXT (p)), 0);
579 coerce_unit (SUB_NEXT (p), &w);
580 }
581
582 //! @brief Coerce cast.
583
584 void coerce_cast (NODE_T * p)
585 {
586 SOID_T w;
587 coerce_declarer (p);
588 make_soid (&w, STRONG, MOID (p), 0);
589 coerce_enclosed (NEXT (p), &w);
590 }
591
592 //! @brief Coerce argument list.
593
594 void coerce_argument_list (PACK_T ** r, NODE_T * p)
595 {
596 for (; p != NO_NODE; FORWARD (p)) {
597 if (IS (p, ARGUMENT_LIST)) {
598 coerce_argument_list (r, SUB (p));
599 } else if (IS (p, UNIT)) {
600 SOID_T s;
601 make_soid (&s, STRONG, MOID (*r), 0);
602 coerce_unit (p, &s);
603 FORWARD (*r);
604 } else if (IS (p, TRIMMER)) {
605 FORWARD (*r);
606 }
607 }
608 }
609
610 //! @brief Coerce call.
611
612 void coerce_call (NODE_T * p)
613 {
614 MOID_T *proc = MOID (p);
615 SOID_T w;
616 PACK_T *t;
617 make_soid (&w, MEEK, proc, 0);
618 coerce_unit (SUB (p), &w);
619 FORWARD (p);
620 t = PACK (proc);
621 coerce_argument_list (&t, SUB (p));
622 }
623
624 //! @brief Coerce meek int.
625
626 void coerce_meek_int (NODE_T * p)
627 {
628 SOID_T x;
629 make_soid (&x, MEEK, M_INT, 0);
630 coerce_unit (p, &x);
631 }
632
633 //! @brief Coerce trimmer.
634
635 void coerce_trimmer (NODE_T * p)
636 {
637 if (p != NO_NODE) {
638 if (IS (p, UNIT)) {
639 coerce_meek_int (p);
640 coerce_trimmer (NEXT (p));
641 } else {
642 coerce_trimmer (NEXT (p));
643 }
644 }
645 }
646
647 //! @brief Coerce indexer.
648
649 void coerce_indexer (NODE_T * p)
650 {
651 if (p != NO_NODE) {
652 if (IS (p, TRIMMER)) {
653 coerce_trimmer (SUB (p));
654 } else if (IS (p, UNIT)) {
655 coerce_meek_int (p);
656 } else {
657 coerce_indexer (SUB (p));
658 coerce_indexer (NEXT (p));
659 }
660 }
661 }
662
663 //! @brief Coerce_slice.
664
665 void coerce_slice (NODE_T * p)
666 {
667 SOID_T w;
668 MOID_T *row;
669 row = MOID (p);
670 make_soid (&w, STRONG, row, 0);
671 coerce_unit (SUB (p), &w);
672 coerce_indexer (SUB_NEXT (p));
673 }
674
675 //! @brief Mode coerce diagonal.
676
677 void coerce_diagonal (NODE_T * p)
678 {
679 SOID_T w;
680 if (IS (p, TERTIARY)) {
681 make_soid (&w, MEEK, M_INT, 0);
682 coerce_unit (SUB (p), &w);
683 FORWARD (p);
684 }
685 make_soid (&w, STRONG, MOID (NEXT (p)), 0);
686 coerce_unit (SUB_NEXT (p), &w);
687 }
688
689 //! @brief Mode coerce transpose.
690
691 void coerce_transpose (NODE_T * p)
692 {
693 SOID_T w;
694 make_soid (&w, STRONG, MOID (NEXT (p)), 0);
695 coerce_unit (SUB_NEXT (p), &w);
696 }
697
698 //! @brief Mode coerce row or column function.
699
700 void coerce_row_column_function (NODE_T * p)
701 {
702 SOID_T w;
703 if (IS (p, TERTIARY)) {
704 make_soid (&w, MEEK, M_INT, 0);
705 coerce_unit (SUB (p), &w);
706 FORWARD (p);
707 }
708 make_soid (&w, STRONG, MOID (NEXT (p)), 0);
709 coerce_unit (SUB_NEXT (p), &w);
710 }
711
712 //! @brief Coerce format text.
713
714 void coerce_format_text (NODE_T * p)
715 {
716 for (; p != NO_NODE; FORWARD (p)) {
717 coerce_format_text (SUB (p));
718 if (IS (p, FORMAT_PATTERN)) {
719 SOID_T x;
720 make_soid (&x, STRONG, M_FORMAT, 0);
721 coerce_enclosed (SUB (NEXT_SUB (p)), &x);
722 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
723 SOID_T x;
724 make_soid (&x, STRONG, M_ROW_INT, 0);
725 coerce_enclosed (SUB (NEXT_SUB (p)), &x);
726 } else if (IS (p, DYNAMIC_REPLICATOR)) {
727 SOID_T x;
728 make_soid (&x, STRONG, M_INT, 0);
729 coerce_enclosed (SUB (NEXT_SUB (p)), &x);
730 }
731 }
732 }
733
734 //! @brief Coerce unit.
735
736 void coerce_unit (NODE_T * p, SOID_T * q)
737 {
738 if (p == NO_NODE) {
739 return;
740 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) {
741 coerce_unit (SUB (p), q);
742 MOID (p) = MOID (SUB (p));
743 // Ex primary.
744 } else if (IS (p, CALL)) {
745 coerce_call (SUB (p));
746 INSERT_COERCIONS (p, MOID (p), q);
747 } else if (IS (p, SLICE)) {
748 coerce_slice (SUB (p));
749 INSERT_COERCIONS (p, MOID (p), q);
750 } else if (IS (p, CAST)) {
751 coerce_cast (SUB (p));
752 INSERT_COERCIONS (p, MOID (p), q);
753 } else if (is_one_of (p, DENOTATION, IDENTIFIER, STOP)) {
754 INSERT_COERCIONS (p, MOID (p), q);
755 } else if (IS (p, FORMAT_TEXT)) {
756 coerce_format_text (SUB (p));
757 INSERT_COERCIONS (p, MOID (p), q);
758 } else if (IS (p, ENCLOSED_CLAUSE)) {
759 coerce_enclosed (p, q);
760 // Ex secondary.
761 } else if (IS (p, SELECTION)) {
762 coerce_selection (SUB (p));
763 INSERT_COERCIONS (p, MOID (p), q);
764 } else if (IS (p, GENERATOR)) {
765 coerce_declarer (SUB (p));
766 INSERT_COERCIONS (p, MOID (p), q);
767 // Ex tertiary.
768 } else if (IS (p, NIHIL)) {
769 if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != M_VOID) {
770 diagnostic (A68_ERROR, p, ERROR_NO_NAME_REQUIRED);
771 }
772 MOID (p) = depref_rows (MOID (p), MOID (q));
773 } else if (IS (p, FORMULA)) {
774 coerce_formula (SUB (p), q);
775 INSERT_COERCIONS (p, MOID (p), q);
776 } else if (IS (p, DIAGONAL_FUNCTION)) {
777 coerce_diagonal (SUB (p));
778 INSERT_COERCIONS (p, MOID (p), q);
779 } else if (IS (p, TRANSPOSE_FUNCTION)) {
780 coerce_transpose (SUB (p));
781 INSERT_COERCIONS (p, MOID (p), q);
782 } else if (IS (p, ROW_FUNCTION)) {
783 coerce_row_column_function (SUB (p));
784 INSERT_COERCIONS (p, MOID (p), q);
785 } else if (IS (p, COLUMN_FUNCTION)) {
786 coerce_row_column_function (SUB (p));
787 INSERT_COERCIONS (p, MOID (p), q);
788 // Ex unit.
789 } else if (IS (p, JUMP)) {
790 if (MOID (q) == M_PROC_VOID) {
791 make_sub (p, p, PROCEDURING);
792 }
793 MOID (p) = depref_rows (MOID (p), MOID (q));
794 } else if (IS (p, SKIP)) {
795 MOID (p) = depref_rows (MOID (p), MOID (q));
796 } else if (IS (p, ASSIGNATION)) {
797 coerce_assignation (SUB (p));
798 INSERT_COERCIONS (p, MOID (p), q);
799 MOID (p) = depref_rows (MOID (p), MOID (q));
800 } else if (IS (p, IDENTITY_RELATION)) {
801 coerce_relation (SUB (p));
802 INSERT_COERCIONS (p, MOID (p), q);
803 } else if (IS (p, ROUTINE_TEXT)) {
804 coerce_routine_text (SUB (p));
805 INSERT_COERCIONS (p, MOID (p), q);
806 } else if (is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP)) {
807 coerce_bool_function (SUB (p));
808 INSERT_COERCIONS (p, MOID (p), q);
809 } else if (IS (p, ASSERTION)) {
810 coerce_assertion (SUB (p));
811 INSERT_COERCIONS (p, MOID (p), q);
812 }
813 }
814
815 //! @brief Widen denotation depending on mode required, this is an extension to A68.
816
817 void widen_denotation (NODE_T * p)
818 {
819 #define WIDEN {\
820 *q = *(SUB (q));\
821 ATTRIBUTE (q) = DENOTATION;\
822 MOID (q) = lm;\
823 STATUS_SET (q, OPTIMAL_MASK);\
824 }
825 #define WARN_WIDENING\
826 if (OPTION_PORTCHECK (&A68_JOB) && !(STATUS_TEST (SUB (q), OPTIMAL_MASK))) {\
827 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_WIDENING_NOT_PORTABLE);\
828 }
829 NODE_T *q;
830 for (q = p; q != NO_NODE; FORWARD (q)) {
831 widen_denotation (SUB (q));
832 if (IS (q, WIDENING) && IS (SUB (q), DENOTATION)) {
833 MOID_T *lm = MOID (q), *m = MOID (SUB (q));
834 if (lm == M_LONG_LONG_INT && m == M_LONG_INT) {
835 WARN_WIDENING;
836 WIDEN;
837 }
838 if (lm == M_LONG_INT && m == M_INT) {
839 WARN_WIDENING;
840 WIDEN;
841 }
842 if (lm == M_LONG_LONG_REAL && m == M_LONG_REAL) {
843 WARN_WIDENING;
844 WIDEN;
845 }
846 if (lm == M_LONG_REAL && m == M_REAL) {
847 WARN_WIDENING;
848 WIDEN;
849 }
850 if (lm == M_LONG_REAL && m == M_LONG_INT) {
851 WIDEN;
852 }
853 if (lm == M_REAL && m == M_INT) {
854 WIDEN;
855 }
856 if (lm == M_LONG_LONG_BITS && m == M_LONG_BITS) {
857 WARN_WIDENING;
858 WIDEN;
859 }
860 if (lm == M_LONG_BITS && m == M_BITS) {
861 WARN_WIDENING;
862 WIDEN;
863 }
864 return;
865 }
866 }
867 #undef WIDEN
868 #undef WARN_WIDENING
869 }
870
871 //! @brief Driver for coercion inserions.
872
873 void coercion_inserter (NODE_T * p)
874 {
875 if (IS (p, PARTICULAR_PROGRAM)) {
876 SOID_T q;
877 make_soid (&q, STRONG, M_VOID, 0);
878 coerce_enclosed (SUB (p), &q);
879 }
880 }
881
