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