parser-moids-check.c
1 //! @file parser-moids-check.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 checker routines.
25
26 // Algol 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG.
27 // These contexts are increasing in strength:
28 //
29 // SOFT: Deproceduring
30 //
31 // WEAK: Dereferencing to REF [] or REF STRUCT
32 //
33 // MEEK: Deproceduring and dereferencing
34 //
35 // FIRM: MEEK followed by uniting
36 //
37 // STRONG: FIRM followed by rowing, widening or voiding
38 //
39 // Furthermore you will see in this file next switches:
40 //
41 // (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX
42 // rows. This can only be the case when there is no danger of altering bounds of a
43 // non FLEX row.
44 //
45 // (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa
46 // is no problem) so that one cannot alter the bounds of a non FLEX row by
47 // aliasing it to a FLEX row. This is particularly the case when passing names as
48 // parameters to procedures:
49 //
50 // PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...;
51 //
52 // x (LOC STRING); # OK #
53 //
54 // x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! #
55 //
56 // y (LOC STRING); # OK #
57 //
58 // y (LOC [10] CHAR); # OK #
59 //
60 // (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names,
61 // not for values, so common things are not rejected, for instance
62 //
63 // STRING x = read string;
64 //
65 // [] CHAR y = read string
66 //
67 // (4) NO_DEFLEXING sets FLEX row apart from non FLEX row.
68 //
69 // Finally, a static scope checker inspects the source. Note that Algol 68 also
70 // needs dynamic scope checking. This phase concludes the parser.
71
72 #include "a68g.h"
73 #include "a68g-parser.h"
74 #include "a68g-prelude.h"
75 #include "a68g-moids.h"
76
77 //! @brief Driver for mode checker.
78
79 void mode_checker (NODE_T * p)
80 {
81 if (IS (p, PARTICULAR_PROGRAM)) {
82 SOID_T x, y;
83 A68 (top_soid_list) = NO_SOID;
84 make_soid (&x, STRONG, M_VOID, 0);
85 mode_check_enclosed (SUB (p), &x, &y);
86 MOID (p) = MOID (&y);
87 }
88 }
89
90 //! @brief Mode check on bounds.
91
92 void mode_check_bounds (NODE_T * p)
93 {
94 if (p == NO_NODE) {
95 return;
96 } else if (IS (p, UNIT)) {
97 SOID_T x, y;
98 make_soid (&x, STRONG, M_INT, 0);
99 mode_check_unit (p, &x, &y);
100 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
101 cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT);
102 }
103 mode_check_bounds (NEXT (p));
104 } else {
105 mode_check_bounds (SUB (p));
106 mode_check_bounds (NEXT (p));
107 }
108 }
109
110 //! @brief Mode check declarer.
111
112 void mode_check_declarer (NODE_T * p)
113 {
114 if (p == NO_NODE) {
115 return;
116 } else if (IS (p, BOUNDS)) {
117 mode_check_bounds (SUB (p));
118 mode_check_declarer (NEXT (p));
119 } else {
120 mode_check_declarer (SUB (p));
121 mode_check_declarer (NEXT (p));
122 }
123 }
124
125 //! @brief Mode check identity declaration.
126
127 void mode_check_identity_declaration (NODE_T * p)
128 {
129 if (p != NO_NODE) {
130 switch (ATTRIBUTE (p)) {
131 case DECLARER:
132 {
133 mode_check_declarer (SUB (p));
134 mode_check_identity_declaration (NEXT (p));
135 break;
136 }
137 case DEFINING_IDENTIFIER:
138 {
139 SOID_T x, y;
140 make_soid (&x, STRONG, MOID (p), 0);
141 mode_check_unit (NEXT_NEXT (p), &x, &y);
142 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
143 cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
144 } else if (MOID (&x) != MOID (&y)) {
145 // Check for instance, REF INT i = LOC REF INT.
146 semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR);
147 }
148 break;
149 }
150 default:
151 {
152 mode_check_identity_declaration (SUB (p));
153 mode_check_identity_declaration (NEXT (p));
154 break;
155 }
156 }
157 }
158 }
159
160 //! @brief Mode check variable declaration.
161
162 void mode_check_variable_declaration (NODE_T * p)
163 {
164 if (p != NO_NODE) {
165 switch (ATTRIBUTE (p)) {
166 case DECLARER:
167 {
168 mode_check_declarer (SUB (p));
169 mode_check_variable_declaration (NEXT (p));
170 break;
171 }
172 case DEFINING_IDENTIFIER:
173 {
174 if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
175 SOID_T x, y;
176 make_soid (&x, STRONG, SUB_MOID (p), 0);
177 mode_check_unit (NEXT_NEXT (p), &x, &y);
178 if (!is_coercible_in_context (&y, &x, FORCE_DEFLEXING)) {
179 cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT);
180 } else if (SUB_MOID (&x) != MOID (&y)) {
181 // Check for instance, REF INT i = LOC REF INT.
182 semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR);
183 }
184 }
185 break;
186 }
187 default:
188 {
189 mode_check_variable_declaration (SUB (p));
190 mode_check_variable_declaration (NEXT (p));
191 break;
192 }
193 }
194 }
195 }
196
197 //! @brief Mode check routine text.
198
199 void mode_check_routine_text (NODE_T * p, SOID_T * y)
200 {
201 SOID_T w;
202 if (IS (p, PARAMETER_PACK)) {
203 mode_check_declarer (SUB (p));
204 FORWARD (p);
205 }
206 mode_check_declarer (SUB (p));
207 make_soid (&w, STRONG, MOID (p), 0);
208 mode_check_unit (NEXT_NEXT (p), &w, y);
209 if (!is_coercible_in_context (y, &w, FORCE_DEFLEXING)) {
210 cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT);
211 }
212 }
213
214 //! @brief Mode check proc declaration.
215
216 void mode_check_proc_declaration (NODE_T * p)
217 {
218 if (p == NO_NODE) {
219 return;
220 } else if (IS (p, ROUTINE_TEXT)) {
221 SOID_T x, y;
222 make_soid (&x, STRONG, NO_MOID, 0);
223 mode_check_routine_text (SUB (p), &y);
224 } else {
225 mode_check_proc_declaration (SUB (p));
226 mode_check_proc_declaration (NEXT (p));
227 }
228 }
229
230 //! @brief Mode check brief op declaration.
231
232 void mode_check_brief_op_declaration (NODE_T * p)
233 {
234 if (p == NO_NODE) {
235 return;
236 } else if (IS (p, DEFINING_OPERATOR)) {
237 SOID_T y;
238 if (MOID (p) != MOID (NEXT_NEXT (p))) {
239 SOID_T y2, x;
240 make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0);
241 make_soid (&x, NO_SORT, MOID (p), 0);
242 cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT);
243 }
244 mode_check_routine_text (SUB (NEXT_NEXT (p)), &y);
245 } else {
246 mode_check_brief_op_declaration (SUB (p));
247 mode_check_brief_op_declaration (NEXT (p));
248 }
249 }
250
251 //! @brief Mode check op declaration.
252
253 void mode_check_op_declaration (NODE_T * p)
254 {
255 if (p == NO_NODE) {
256 return;
257 } else if (IS (p, DEFINING_OPERATOR)) {
258 SOID_T y, x;
259 make_soid (&x, STRONG, MOID (p), 0);
260 mode_check_unit (NEXT_NEXT (p), &x, &y);
261 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
262 cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
263 }
264 } else {
265 mode_check_op_declaration (SUB (p));
266 mode_check_op_declaration (NEXT (p));
267 }
268 }
269
270 //! @brief Mode check declaration list.
271
272 void mode_check_declaration_list (NODE_T * p)
273 {
274 if (p != NO_NODE) {
275 switch (ATTRIBUTE (p)) {
276 case IDENTITY_DECLARATION:
277 {
278 mode_check_identity_declaration (SUB (p));
279 break;
280 }
281 case VARIABLE_DECLARATION:
282 {
283 mode_check_variable_declaration (SUB (p));
284 break;
285 }
286 case MODE_DECLARATION:
287 {
288 mode_check_declarer (SUB (p));
289 break;
290 }
291 case PROCEDURE_DECLARATION:
292 case PROCEDURE_VARIABLE_DECLARATION:
293 {
294 mode_check_proc_declaration (SUB (p));
295 break;
296 }
297 case BRIEF_OPERATOR_DECLARATION:
298 {
299 mode_check_brief_op_declaration (SUB (p));
300 break;
301 }
302 case OPERATOR_DECLARATION:
303 {
304 mode_check_op_declaration (SUB (p));
305 break;
306 }
307 default:
308 {
309 mode_check_declaration_list (SUB (p));
310 mode_check_declaration_list (NEXT (p));
311 break;
312 }
313 }
314 }
315 }
316
317 //! @brief Mode check serial clause.
318
319 void mode_check_serial (SOID_T ** r, NODE_T * p, SOID_T * x, BOOL_T k)
320 {
321 if (p == NO_NODE) {
322 return;
323 } else if (IS (p, INITIALISER_SERIES)) {
324 mode_check_serial (r, SUB (p), x, A68_FALSE);
325 mode_check_serial (r, NEXT (p), x, k);
326 } else if (IS (p, DECLARATION_LIST)) {
327 mode_check_declaration_list (SUB (p));
328 } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
329 mode_check_serial (r, NEXT (p), x, k);
330 } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
331 if (NEXT (p) != NO_NODE) {
332 if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL)) {
333 mode_check_serial (r, SUB (p), x, A68_TRUE);
334 } else {
335 mode_check_serial (r, SUB (p), x, A68_FALSE);
336 }
337 mode_check_serial (r, NEXT (p), x, k);
338 } else {
339 mode_check_serial (r, SUB (p), x, A68_TRUE);
340 }
341 } else if (IS (p, LABELED_UNIT)) {
342 mode_check_serial (r, SUB (p), x, k);
343 } else if (IS (p, UNIT)) {
344 SOID_T y;
345 if (k) {
346 mode_check_unit (p, x, &y);
347 } else {
348 SOID_T w;
349 make_soid (&w, STRONG, M_VOID, 0);
350 mode_check_unit (p, &w, &y);
351 }
352 if (NEXT (p) != NO_NODE) {
353 mode_check_serial (r, NEXT (p), x, k);
354 } else {
355 if (k) {
356 add_to_soid_list (r, p, &y);
357 }
358 }
359 }
360 }
361
362 //! @brief Mode check serial clause units.
363
364 void mode_check_serial_units (NODE_T * p, SOID_T * x, SOID_T * y, int att)
365 {
366 SOID_T *top_sl = NO_SOID;
367 (void) att;
368 mode_check_serial (&top_sl, SUB (p), x, A68_TRUE);
369 if (is_balanced (p, top_sl, SORT (x))) {
370 MOID_T *result = pack_soids_in_moid (top_sl, SERIES_MODE);
371 make_soid (y, SORT (x), result, SERIAL_CLAUSE);
372 } else {
373 make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : M_ERROR), 0);
374 }
375 free_soid_list (top_sl);
376 }
377
378 //! @brief Mode check unit list.
379
380 void mode_check_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x)
381 {
382 if (p == NO_NODE) {
383 return;
384 } else if (IS (p, UNIT_LIST)) {
385 mode_check_unit_list (r, SUB (p), x);
386 mode_check_unit_list (r, NEXT (p), x);
387 } else if (IS (p, COMMA_SYMBOL)) {
388 mode_check_unit_list (r, NEXT (p), x);
389 } else if (IS (p, UNIT)) {
390 SOID_T y;
391 mode_check_unit (p, x, &y);
392 add_to_soid_list (r, p, &y);
393 mode_check_unit_list (r, NEXT (p), x);
394 }
395 }
396
397 //! @brief Mode check struct display.
398
399 void mode_check_struct_display (SOID_T ** r, NODE_T * p, PACK_T ** fields)
400 {
401 if (p == NO_NODE) {
402 return;
403 } else if (IS (p, UNIT_LIST)) {
404 mode_check_struct_display (r, SUB (p), fields);
405 mode_check_struct_display (r, NEXT (p), fields);
406 } else if (IS (p, COMMA_SYMBOL)) {
407 mode_check_struct_display (r, NEXT (p), fields);
408 } else if (IS (p, UNIT)) {
409 SOID_T x, y;
410 if (*fields != NO_PACK) {
411 make_soid (&x, STRONG, MOID (*fields), 0);
412 FORWARD (*fields);
413 } else {
414 make_soid (&x, STRONG, NO_MOID, 0);
415 }
416 mode_check_unit (p, &x, &y);
417 add_to_soid_list (r, p, &y);
418 mode_check_struct_display (r, NEXT (p), fields);
419 }
420 }
421
422 //! @brief Mode check get specified moids.
423
424 void mode_check_get_specified_moids (NODE_T * p, MOID_T * u)
425 {
426 for (; p != NO_NODE; FORWARD (p)) {
427 if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
428 mode_check_get_specified_moids (SUB (p), u);
429 } else if (IS (p, SPECIFIER)) {
430 MOID_T *m = MOID (NEXT_SUB (p));
431 add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m));
432 }
433 }
434 }
435
436 //! @brief Mode check specified unit list.
437
438 void mode_check_specified_unit_list (SOID_T ** r, NODE_T * p, SOID_T * x, MOID_T * u)
439 {
440 for (; p != NO_NODE; FORWARD (p)) {
441 if (is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) {
442 mode_check_specified_unit_list (r, SUB (p), x, u);
443 } else if (IS (p, SPECIFIER)) {
444 MOID_T *m = MOID (NEXT_SUB (p));
445 if (u != NO_MOID && !is_unitable (m, u, SAFE_DEFLEXING)) {
446 diagnostic (A68_ERROR, p, ERROR_NO_COMPONENT, m, u);
447 }
448 } else if (IS (p, UNIT)) {
449 SOID_T y;
450 mode_check_unit (p, x, &y);
451 add_to_soid_list (r, p, &y);
452 }
453 }
454 }
455
456 //! @brief Mode check united case parts.
457
458 void mode_check_united_case_parts (SOID_T ** ry, NODE_T * p, SOID_T * x)
459 {
460 SOID_T enq_expct, enq_yield;
461 MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID;
462 // Check the CASE part and deduce the united mode.
463 make_soid (&enq_expct, MEEK, NO_MOID, 0);
464 mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
465 // Deduce the united mode from the enquiry clause.
466 u = depref_completely (MOID (&enq_yield));
467 u = make_united_mode (u);
468 u = depref_completely (u);
469 // Also deduce the united mode from the specifiers.
470 v = new_moid ();
471 ATTRIBUTE (v) = SERIES_MODE;
472 mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v);
473 v = make_united_mode (v);
474 // Determine a resulting union.
475 if (u == M_HIP) {
476 w = v;
477 } else {
478 if (IS (u, UNION_SYMBOL)) {
479 BOOL_T uv, vu, some;
480 investigate_firm_relations (PACK (u), PACK (v), &uv, &some);
481 investigate_firm_relations (PACK (v), PACK (u), &vu, &some);
482 if (uv && vu) {
483 // Every component has a specifier.
484 w = u;
485 } else if (!uv && !vu) {
486 // Hmmmm ... let the coercer sort it out.
487 w = u;
488 } else {
489 // This is all the balancing we allow here for the moment. Firmly related
490 // subsets are not valid so we absorb them. If this doesn't solve it then we
491 // get a coercion-error later.
492 w = absorb_related_subsets (u);
493 }
494 } else {
495 diagnostic (A68_ERROR, NEXT_SUB (p), ERROR_NO_UNION, u);
496 return;
497 }
498 }
499 MOID (SUB (p)) = w;
500 FORWARD (p);
501 // Check the IN part.
502 mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w);
503 // OUSE, OUT, ESAC.
504 if ((FORWARD (p)) != NO_NODE) {
505 if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
506 mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
507 } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
508 mode_check_united_case_parts (ry, SUB (p), x);
509 }
510 }
511 }
512
513 //! @brief Mode check united case.
514
515 void mode_check_united_case (NODE_T * p, SOID_T * x, SOID_T * y)
516 {
517 SOID_T *top_sl = NO_SOID;
518 MOID_T *z;
519 mode_check_united_case_parts (&top_sl, p, x);
520 if (!is_balanced (p, top_sl, SORT (x))) {
521 if (MOID (x) != NO_MOID) {
522 make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE);
523
524 } else {
525 make_soid (y, SORT (x), M_ERROR, 0);
526 }
527 } else {
528 z = pack_soids_in_moid (top_sl, SERIES_MODE);
529 make_soid (y, SORT (x), z, CONFORMITY_CLAUSE);
530 }
531 free_soid_list (top_sl);
532 }
533
534 //! @brief Mode check unit list 2.
535
536 void mode_check_unit_list_2 (NODE_T * p, SOID_T * x, SOID_T * y)
537 {
538 SOID_T *top_sl = NO_SOID;
539 if (MOID (x) != NO_MOID) {
540 if (IS_FLEX (MOID (x))) {
541 SOID_T y2;
542 make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0);
543 mode_check_unit_list (&top_sl, SUB (p), &y2);
544 } else if (IS_ROW (MOID (x))) {
545 SOID_T y2;
546 make_soid (&y2, SORT (x), SLICE (MOID (x)), 0);
547 mode_check_unit_list (&top_sl, SUB (p), &y2);
548 } else if (IS (MOID (x), STRUCT_SYMBOL)) {
549 PACK_T *y2 = PACK (MOID (x));
550 mode_check_struct_display (&top_sl, SUB (p), &y2);
551 } else {
552 mode_check_unit_list (&top_sl, SUB (p), x);
553 }
554 } else {
555 mode_check_unit_list (&top_sl, SUB (p), x);
556 }
557 make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0);
558 free_soid_list (top_sl);
559 }
560
561 //! @brief Mode check closed.
562
563 void mode_check_closed (NODE_T * p, SOID_T * x, SOID_T * y)
564 {
565 if (p == NO_NODE) {
566 return;
567 } else if (IS (p, SERIAL_CLAUSE)) {
568 mode_check_serial_units (p, x, y, SERIAL_CLAUSE);
569 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
570 mode_check_closed (NEXT (p), x, y);
571 }
572 MOID (p) = MOID (y);
573 }
574
575 //! @brief Mode check collateral.
576
577 void mode_check_collateral (NODE_T * p, SOID_T * x, SOID_T * y)
578 {
579 if (p == NO_NODE) {
580 return;
581 } else if (whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) {
582 if (SORT (x) == STRONG) {
583 if (MOID (x) == NO_MOID) {
584 diagnostic (A68_ERROR, p, ERROR_VACUUM, "REF MODE");
585 } else {
586 make_soid (y, STRONG, M_VACUUM, 0);
587 }
588 } else {
589 make_soid (y, STRONG, M_UNDEFINED, 0);
590 }
591 } else {
592 if (IS (p, UNIT_LIST)) {
593 mode_check_unit_list_2 (p, x, y);
594 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
595 mode_check_collateral (NEXT (p), x, y);
596 }
597 MOID (p) = MOID (y);
598 }
599 }
600
601 //! @brief Mode check conditional 2.
602
603 void mode_check_conditional_2 (SOID_T ** ry, NODE_T * p, SOID_T * x)
604 {
605 SOID_T enq_expct, enq_yield;
606 make_soid (&enq_expct, MEEK, M_BOOL, 0);
607 mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
608 if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
609 cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
610 }
611 FORWARD (p);
612 mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
613 if ((FORWARD (p)) != NO_NODE) {
614 if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
615 mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
616 } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
617 mode_check_conditional_2 (ry, SUB (p), x);
618 }
619 }
620 }
621
622 //! @brief Mode check conditional.
623
624 void mode_check_conditional (NODE_T * p, SOID_T * x, SOID_T * y)
625 {
626 SOID_T *top_sl = NO_SOID;
627 MOID_T *z;
628 mode_check_conditional_2 (&top_sl, p, x);
629 if (!is_balanced (p, top_sl, SORT (x))) {
630 if (MOID (x) != NO_MOID) {
631 make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE);
632 } else {
633 make_soid (y, SORT (x), M_ERROR, 0);
634 }
635 } else {
636 z = pack_soids_in_moid (top_sl, SERIES_MODE);
637 make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE);
638 }
639 free_soid_list (top_sl);
640 }
641
642 //! @brief Mode check int case 2.
643
644 void mode_check_int_case_2 (SOID_T ** ry, NODE_T * p, SOID_T * x)
645 {
646 SOID_T enq_expct, enq_yield;
647 make_soid (&enq_expct, MEEK, M_INT, 0);
648 mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
649 if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
650 cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
651 }
652 FORWARD (p);
653 mode_check_unit_list (ry, NEXT_SUB (p), x);
654 if ((FORWARD (p)) != NO_NODE) {
655 if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
656 mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE);
657 } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
658 mode_check_int_case_2 (ry, SUB (p), x);
659 }
660 }
661 }
662
663 //! @brief Mode check int case.
664
665 void mode_check_int_case (NODE_T * p, SOID_T * x, SOID_T * y)
666 {
667 SOID_T *top_sl = NO_SOID;
668 MOID_T *z;
669 mode_check_int_case_2 (&top_sl, p, x);
670 if (!is_balanced (p, top_sl, SORT (x))) {
671 if (MOID (x) != NO_MOID) {
672 make_soid (y, SORT (x), MOID (x), CASE_CLAUSE);
673 } else {
674 make_soid (y, SORT (x), M_ERROR, 0);
675 }
676 } else {
677 z = pack_soids_in_moid (top_sl, SERIES_MODE);
678 make_soid (y, SORT (x), z, CASE_CLAUSE);
679 }
680 free_soid_list (top_sl);
681 }
682
683 //! @brief Mode check loop 2.
684
685 void mode_check_loop_2 (NODE_T * p, SOID_T * y)
686 {
687 if (p == NO_NODE) {
688 return;
689 } else if (IS (p, FOR_PART)) {
690 mode_check_loop_2 (NEXT (p), y);
691 } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
692 SOID_T ix, iy;
693 make_soid (&ix, STRONG, M_INT, 0);
694 mode_check_unit (NEXT_SUB (p), &ix, &iy);
695 if (!is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING)) {
696 cannot_coerce (NEXT_SUB (p), MOID (&iy), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
697 }
698 mode_check_loop_2 (NEXT (p), y);
699 } else if (IS (p, WHILE_PART)) {
700 SOID_T enq_expct, enq_yield;
701 make_soid (&enq_expct, MEEK, M_BOOL, 0);
702 mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
703 if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
704 cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
705 }
706 mode_check_loop_2 (NEXT (p), y);
707 } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
708 SOID_T *z = NO_SOID;
709 SOID_T ix;
710 NODE_T *do_p = NEXT_SUB (p), *un_p;
711 make_soid (&ix, STRONG, M_VOID, 0);
712 if (IS (do_p, SERIAL_CLAUSE)) {
713 mode_check_serial (&z, do_p, &ix, A68_TRUE);
714 un_p = NEXT (do_p);
715 } else {
716 un_p = do_p;
717 }
718 if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
719 SOID_T enq_expct, enq_yield;
720 make_soid (&enq_expct, STRONG, M_BOOL, 0);
721 mode_check_serial_units (NEXT_SUB (un_p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
722 if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) {
723 cannot_coerce (un_p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
724 }
725 }
726 free_soid_list (z);
727 }
728 }
729
730 //! @brief Mode check loop.
731
732 void mode_check_loop (NODE_T * p, SOID_T * y)
733 {
734 SOID_T *z = NO_SOID;
735 mode_check_loop_2 (p, z);
736 make_soid (y, STRONG, M_VOID, 0);
737 }
738
739 //! @brief Mode check enclosed.
740
741 void mode_check_enclosed (NODE_T * p, SOID_T * x, SOID_T * y)
742 {
743 if (p == NO_NODE) {
744 return;
745 } else if (IS (p, ENCLOSED_CLAUSE)) {
746 mode_check_enclosed (SUB (p), x, y);
747 } else if (IS (p, CLOSED_CLAUSE)) {
748 mode_check_closed (SUB (p), x, y);
749 } else if (IS (p, PARALLEL_CLAUSE)) {
750 mode_check_collateral (SUB (NEXT_SUB (p)), x, y);
751 make_soid (y, STRONG, M_VOID, 0);
752 MOID (NEXT_SUB (p)) = M_VOID;
753 } else if (IS (p, COLLATERAL_CLAUSE)) {
754 mode_check_collateral (SUB (p), x, y);
755 } else if (IS (p, CONDITIONAL_CLAUSE)) {
756 mode_check_conditional (SUB (p), x, y);
757 } else if (IS (p, CASE_CLAUSE)) {
758 mode_check_int_case (SUB (p), x, y);
759 } else if (IS (p, CONFORMITY_CLAUSE)) {
760 mode_check_united_case (SUB (p), x, y);
761 } else if (IS (p, LOOP_CLAUSE)) {
762 mode_check_loop (SUB (p), y);
763 }
764 MOID (p) = MOID (y);
765 }
766
767 //! @brief Search table for operator.
768
769 TAG_T *search_table_for_operator (TAG_T * t, char *n, MOID_T * x, MOID_T * y)
770 {
771 if (is_mode_isnt_well (x)) {
772 return A68_PARSER (error_tag);
773 } else if (y != NO_MOID && is_mode_isnt_well (y)) {
774 return A68_PARSER (error_tag);
775 }
776 for (; t != NO_TAG; FORWARD (t)) {
777 if (NSYMBOL (NODE (t)) == n) {
778 PACK_T *p = PACK (MOID (t));
779 if (is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING)) {
780 FORWARD (p);
781 if (p == NO_PACK && y == NO_MOID) {
782 // Matched in case of a monadic.
783 return t;
784 } else if (p != NO_PACK && y != NO_MOID && is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING)) {
785 // Matched in case of a dyadic.
786 return t;
787 }
788 }
789 }
790 }
791 return NO_TAG;
792 }
793
794 //! @brief Search chain of symbol tables and return matching operator "x n y" or "n x".
795
796 TAG_T *search_table_chain_for_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y)
797 {
798 if (is_mode_isnt_well (x)) {
799 return A68_PARSER (error_tag);
800 } else if (y != NO_MOID && is_mode_isnt_well (y)) {
801 return A68_PARSER (error_tag);
802 }
803 while (s != NO_TABLE) {
804 TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y);
805 if (z != NO_TAG) {
806 return z;
807 }
808 BACKWARD (s);
809 }
810 return NO_TAG;
811 }
812
813 //! @brief Return a matching operator "x n y".
814
815 TAG_T *find_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y)
816 {
817 // Coercions to operand modes are FIRM.
818 TAG_T *z;
819 MOID_T *u, *v;
820 // (A) Catch exceptions first.
821 if (x == NO_MOID && y == NO_MOID) {
822 return NO_TAG;
823 } else if (is_mode_isnt_well (x)) {
824 return A68_PARSER (error_tag);
825 } else if (y != NO_MOID && is_mode_isnt_well (y)) {
826 return A68_PARSER (error_tag);
827 }
828 // (B) MONADs.
829 if (x != NO_MOID && y == NO_MOID) {
830 z = search_table_chain_for_operator (s, n, x, NO_MOID);
831 if (z != NO_TAG) {
832 return z;
833 } else {
834 // (B.2) A little trick to allow - (0, 1) or ABS (1, long pi).
835 if (is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING)) {
836 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID);
837 if (z != NO_TAG) {
838 return z;
839 }
840 }
841 if (is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
842 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID);
843 if (z != NO_TAG) {
844 return z;
845 }
846 }
847 if (is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
848 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID);
849 }
850 }
851 return NO_TAG;
852 }
853 // (C) DYADs.
854 z = search_table_chain_for_operator (s, n, x, y);
855 if (z != NO_TAG) {
856 return z;
857 }
858 // (C.2) Vector and matrix "strong coercions" in standard environ.
859 u = depref_completely (x);
860 v = depref_completely (y);
861 if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL)
862 || (v == M_ROW_REAL || v == M_ROW_ROW_REAL)
863 || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX)
864 || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX)) {
865 if (u == M_INT) {
866 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y);
867 if (z != NO_TAG) {
868 return z;
869 }
870 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
871 if (z != NO_TAG) {
872 return z;
873 }
874 } else if (v == M_INT) {
875 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL);
876 if (z != NO_TAG) {
877 return z;
878 }
879 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
880 if (z != NO_TAG) {
881 return z;
882 }
883 } else if (u == M_REAL) {
884 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
885 if (z != NO_TAG) {
886 return z;
887 }
888 } else if (v == M_REAL) {
889 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
890 if (z != NO_TAG) {
891 return z;
892 }
893 }
894 }
895 // (C.3) Look in standenv for an appropriate cross-term.
896 u = make_series_from_moids (x, y);
897 u = make_united_mode (u);
898 v = get_balanced_mode (u, STRONG, NO_DEPREF, SAFE_DEFLEXING);
899 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
900 if (z != NO_TAG) {
901 return z;
902 }
903 if (is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING)) {
904 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL);
905 if (z != NO_TAG) {
906 return z;
907 }
908 }
909 if (is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING)) {
910 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL);
911 if (z != NO_TAG) {
912 return z;
913 }
914 }
915 if (is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING)) {
916 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL);
917 if (z != NO_TAG) {
918 return z;
919 }
920 }
921 if (is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING)) {
922 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX);
923 if (z != NO_TAG) {
924 return z;
925 }
926 }
927 if (is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
928 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX);
929 if (z != NO_TAG) {
930 return z;
931 }
932 }
933 if (is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) {
934 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX);
935 if (z != NO_TAG) {
936 return z;
937 }
938 }
939 // (C.4) Now allow for depreffing for REF REAL +:= INT and alike.
940 v = get_balanced_mode (u, STRONG, DEPREF, SAFE_DEFLEXING);
941 z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
942 if (z != NO_TAG) {
943 return z;
944 }
945 return NO_TAG;
946 }
947
948 //! @brief Mode check monadic operator.
949
950 void mode_check_monadic_operator (NODE_T * p, SOID_T * x, SOID_T * y)
951 {
952 if (p != NO_NODE) {
953 TAG_T *t;
954 MOID_T *u;
955 u = determine_unique_mode (y, SAFE_DEFLEXING);
956 if (is_mode_isnt_well (u)) {
957 make_soid (y, SORT (x), M_ERROR, 0);
958 } else if (u == M_HIP) {
959 diagnostic (A68_ERROR, NEXT (p), ERROR_INVALID_OPERAND, u);
960 make_soid (y, SORT (x), M_ERROR, 0);
961 } else {
962 if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) {
963 t = NO_TAG;
964 diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS);
965 make_soid (y, SORT (x), M_ERROR, 0);
966 } else {
967 t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID);
968 if (t == NO_TAG) {
969 diagnostic (A68_ERROR, p, ERROR_NO_MONADIC, u);
970 make_soid (y, SORT (x), M_ERROR, 0);
971 }
972 }
973 if (t != NO_TAG) {
974 MOID (p) = MOID (t);
975 }
976 TAX (p) = t;
977 if (t != NO_TAG && t != A68_PARSER (error_tag)) {
978 MOID (p) = MOID (t);
979 make_soid (y, SORT (x), SUB_MOID (t), 0);
980 } else {
981 MOID (p) = M_ERROR;
982 make_soid (y, SORT (x), M_ERROR, 0);
983 }
984 }
985 }
986 }
987
988 //! @brief Mode check monadic formula.
989
990 void mode_check_monadic_formula (NODE_T * p, SOID_T * x, SOID_T * y)
991 {
992 SOID_T e;
993 make_soid (&e, FIRM, NO_MOID, 0);
994 mode_check_formula (NEXT (p), &e, y);
995 mode_check_monadic_operator (p, &e, y);
996 make_soid (y, SORT (x), MOID (y), 0);
997 }
998
999 //! @brief Mode check formula.
1000
1001 void mode_check_formula (NODE_T * p, SOID_T * x, SOID_T * y)
1002 {
1003 SOID_T ls, rs;
1004 TAG_T *op;
1005 MOID_T *u, *v;
1006 if (IS (p, MONADIC_FORMULA)) {
1007 mode_check_monadic_formula (SUB (p), x, &ls);
1008 } else if (IS (p, FORMULA)) {
1009 mode_check_formula (SUB (p), x, &ls);
1010 } else if (IS (p, SECONDARY)) {
1011 SOID_T e;
1012 make_soid (&e, FIRM, NO_MOID, 0);
1013 mode_check_unit (SUB (p), &e, &ls);
1014 }
1015 u = determine_unique_mode (&ls, SAFE_DEFLEXING);
1016 MOID (p) = u;
1017 if (NEXT (p) == NO_NODE) {
1018 make_soid (y, SORT (x), u, 0);
1019 } else {
1020 NODE_T *q = NEXT_NEXT (p);
1021 if (IS (q, MONADIC_FORMULA)) {
1022 mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs);
1023 } else if (IS (q, FORMULA)) {
1024 mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs);
1025 } else if (IS (q, SECONDARY)) {
1026 SOID_T e;
1027 make_soid (&e, FIRM, NO_MOID, 0);
1028 mode_check_unit (SUB (q), &e, &rs);
1029 }
1030 v = determine_unique_mode (&rs, SAFE_DEFLEXING);
1031 MOID (q) = v;
1032 if (is_mode_isnt_well (u) || is_mode_isnt_well (v)) {
1033 make_soid (y, SORT (x), M_ERROR, 0);
1034 } else if (u == M_HIP) {
1035 diagnostic (A68_ERROR, p, ERROR_INVALID_OPERAND, u);
1036 make_soid (y, SORT (x), M_ERROR, 0);
1037 } else if (v == M_HIP) {
1038 diagnostic (A68_ERROR, q, ERROR_INVALID_OPERAND, u);
1039 make_soid (y, SORT (x), M_ERROR, 0);
1040 } else {
1041 op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v);
1042 if (op == NO_TAG) {
1043 diagnostic (A68_ERROR, NEXT (p), ERROR_NO_DYADIC, u, v);
1044 make_soid (y, SORT (x), M_ERROR, 0);
1045 }
1046 if (op != NO_TAG) {
1047 MOID (NEXT (p)) = MOID (op);
1048 }
1049 TAX (NEXT (p)) = op;
1050 if (op != NO_TAG && op != A68_PARSER (error_tag)) {
1051 make_soid (y, SORT (x), SUB_MOID (op), 0);
1052 } else {
1053 make_soid (y, SORT (x), M_ERROR, 0);
1054 }
1055 }
1056 }
1057 }
1058
1059 //! @brief Mode check assignation.
1060
1061 void mode_check_assignation (NODE_T * p, SOID_T * x, SOID_T * y)
1062 {
1063 SOID_T name, tmp, value;
1064 MOID_T *name_moid, *ori;
1065 // Get destination mode.
1066 make_soid (&name, SOFT, NO_MOID, 0);
1067 mode_check_unit (SUB (p), &name, &tmp);
1068 // SOFT coercion.
1069 ori = determine_unique_mode (&tmp, SAFE_DEFLEXING);
1070 name_moid = deproc_completely (ori);
1071 if (ATTRIBUTE (name_moid) != REF_SYMBOL) {
1072 if (IF_MODE_IS_WELL (name_moid)) {
1073 diagnostic (A68_ERROR, p, ERROR_NO_NAME, ori, ATTRIBUTE (SUB (p)));
1074 }
1075 make_soid (y, SORT (x), M_ERROR, 0);
1076 return;
1077 }
1078 MOID (p) = name_moid;
1079 // Get source mode.
1080 make_soid (&name, STRONG, SUB (name_moid), 0);
1081 mode_check_unit (NEXT_NEXT (p), &name, &value);
1082 if (!is_coercible_in_context (&value, &name, FORCE_DEFLEXING)) {
1083 cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT);
1084 make_soid (y, SORT (x), M_ERROR, 0);
1085 } else {
1086 make_soid (y, SORT (x), name_moid, 0);
1087 }
1088 }
1089
1090 //! @brief Mode check identity relation.
1091
1092 void mode_check_identity_relation (NODE_T * p, SOID_T * x, SOID_T * y)
1093 {
1094 SOID_T e, l, r;
1095 MOID_T *lhs, *rhs, *oril, *orir;
1096 NODE_T *ln = p, *rn = NEXT_NEXT (p);
1097 make_soid (&e, SOFT, NO_MOID, 0);
1098 mode_check_unit (SUB (ln), &e, &l);
1099 mode_check_unit (SUB (rn), &e, &r);
1100 // SOFT coercion.
1101 oril = determine_unique_mode (&l, SAFE_DEFLEXING);
1102 orir = determine_unique_mode (&r, SAFE_DEFLEXING);
1103 lhs = deproc_completely (oril);
1104 rhs = deproc_completely (orir);
1105 if (IF_MODE_IS_WELL (lhs) && lhs != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL) {
1106 diagnostic (A68_ERROR, ln, ERROR_NO_NAME, oril, ATTRIBUTE (SUB (ln)));
1107 lhs = M_ERROR;
1108 }
1109 if (IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL) {
1110 diagnostic (A68_ERROR, rn, ERROR_NO_NAME, orir, ATTRIBUTE (SUB (rn)));
1111 rhs = M_ERROR;
1112 }
1113 if (lhs == M_HIP && rhs == M_HIP) {
1114 diagnostic (A68_ERROR, p, ERROR_NO_UNIQUE_MODE);
1115 }
1116 if (is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING)) {
1117 lhs = rhs;
1118 } else if (is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING)) {
1119 rhs = lhs;
1120 } else {
1121 cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY);
1122 lhs = rhs = M_ERROR;
1123 }
1124 MOID (ln) = lhs;
1125 MOID (rn) = rhs;
1126 make_soid (y, SORT (x), M_BOOL, 0);
1127 }
1128
1129 //! @brief Mode check bool functions ANDF and ORF.
1130
1131 void mode_check_bool_function (NODE_T * p, SOID_T * x, SOID_T * y)
1132 {
1133 SOID_T e, l, r;
1134 NODE_T *ln = p, *rn = NEXT_NEXT (p);
1135 make_soid (&e, STRONG, M_BOOL, 0);
1136 mode_check_unit (SUB (ln), &e, &l);
1137 if (!is_coercible_in_context (&l, &e, SAFE_DEFLEXING)) {
1138 cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
1139 }
1140 mode_check_unit (SUB (rn), &e, &r);
1141 if (!is_coercible_in_context (&r, &e, SAFE_DEFLEXING)) {
1142 cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
1143 }
1144 MOID (ln) = M_BOOL;
1145 MOID (rn) = M_BOOL;
1146 make_soid (y, SORT (x), M_BOOL, 0);
1147 }
1148
1149 //! @brief Mode check cast.
1150
1151 void mode_check_cast (NODE_T * p, SOID_T * x, SOID_T * y)
1152 {
1153 SOID_T w;
1154 mode_check_declarer (p);
1155 make_soid (&w, STRONG, MOID (p), 0);
1156 CAST (&w) = A68_TRUE;
1157 mode_check_enclosed (SUB_NEXT (p), &w, y);
1158 if (!is_coercible_in_context (y, &w, SAFE_DEFLEXING)) {
1159 cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1160 }
1161 make_soid (y, SORT (x), MOID (p), 0);
1162 }
1163
1164 //! @brief Mode check assertion.
1165
1166 void mode_check_assertion (NODE_T * p)
1167 {
1168 SOID_T w, y;
1169 make_soid (&w, STRONG, M_BOOL, 0);
1170 mode_check_enclosed (SUB_NEXT (p), &w, &y);
1171 SORT (&y) = SORT (&w);
1172 if (!is_coercible_in_context (&y, &w, NO_DEFLEXING)) {
1173 cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE);
1174 }
1175 }
1176
1177 //! @brief Mode check argument list.
1178
1179 void mode_check_argument_list (SOID_T ** r, NODE_T * p, PACK_T ** x, PACK_T ** v, PACK_T ** w)
1180 {
1181 for (; p != NO_NODE; FORWARD (p)) {
1182 if (IS (p, GENERIC_ARGUMENT_LIST)) {
1183 ATTRIBUTE (p) = ARGUMENT_LIST;
1184 }
1185 if (IS (p, ARGUMENT_LIST)) {
1186 mode_check_argument_list (r, SUB (p), x, v, w);
1187 } else if (IS (p, UNIT)) {
1188 SOID_T y, z;
1189 if (*x != NO_PACK) {
1190 make_soid (&z, STRONG, MOID (*x), 0);
1191 add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p);
1192 FORWARD (*x);
1193 } else {
1194 make_soid (&z, STRONG, NO_MOID, 0);
1195 }
1196 mode_check_unit (p, &z, &y);
1197 add_to_soid_list (r, p, &y);
1198 } else if (IS (p, TRIMMER)) {
1199 SOID_T z;
1200 if (SUB (p) != NO_NODE) {
1201 diagnostic (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, ARGUMENT);
1202 make_soid (&z, STRONG, M_ERROR, 0);
1203 add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
1204 add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
1205 FORWARD (*x);
1206 } else if (*x != NO_PACK) {
1207 make_soid (&z, STRONG, MOID (*x), 0);
1208 add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
1209 add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
1210 FORWARD (*x);
1211 } else {
1212 make_soid (&z, STRONG, NO_MOID, 0);
1213 }
1214 add_to_soid_list (r, p, &z);
1215 } else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&A68_JOB)) {
1216 diagnostic (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, CALL);
1217 }
1218 }
1219 }
1220
1221 //! @brief Mode check argument list 2.
1222
1223 void mode_check_argument_list_2 (NODE_T * p, PACK_T * x, SOID_T * y, PACK_T ** v, PACK_T ** w)
1224 {
1225 SOID_T *top_sl = NO_SOID;
1226 mode_check_argument_list (&top_sl, SUB (p), &x, v, w);
1227 make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0);
1228 free_soid_list (top_sl);
1229 }
1230
1231 //! @brief Mode check meek int.
1232
1233 void mode_check_meek_int (NODE_T * p)
1234 {
1235 SOID_T x, y;
1236 make_soid (&x, MEEK, M_INT, 0);
1237 mode_check_unit (p, &x, &y);
1238 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1239 cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0);
1240 }
1241 }
1242
1243 //! @brief Mode check trimmer.
1244
1245 void mode_check_trimmer (NODE_T * p)
1246 {
1247 if (p == NO_NODE) {
1248 return;
1249 } else if (IS (p, TRIMMER)) {
1250 mode_check_trimmer (SUB (p));
1251 } else if (IS (p, UNIT)) {
1252 mode_check_meek_int (p);
1253 mode_check_trimmer (NEXT (p));
1254 } else {
1255 mode_check_trimmer (NEXT (p));
1256 }
1257 }
1258
1259 //! @brief Mode check indexer.
1260
1261 void mode_check_indexer (NODE_T * p, int *subs, int *trims)
1262 {
1263 if (p == NO_NODE) {
1264 return;
1265 } else if (IS (p, TRIMMER)) {
1266 (*trims)++;
1267 mode_check_trimmer (SUB (p));
1268 } else if (IS (p, UNIT)) {
1269 (*subs)++;
1270 mode_check_meek_int (p);
1271 } else {
1272 mode_check_indexer (SUB (p), subs, trims);
1273 mode_check_indexer (NEXT (p), subs, trims);
1274 }
1275 }
1276
1277 //! @brief Mode check call.
1278
1279 void mode_check_call (NODE_T * p, MOID_T * n, SOID_T * x, SOID_T * y)
1280 {
1281 SOID_T d;
1282 MOID (p) = n;
1283 // "partial_locale" is the mode of the locale.
1284 PARTIAL_LOCALE (GINFO (p)) = new_moid ();
1285 ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL;
1286 PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK;
1287 SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n);
1288 // "partial_proc" is the mode of the resulting proc.
1289 PARTIAL_PROC (GINFO (p)) = new_moid ();
1290 ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL;
1291 PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK;
1292 SUB (PARTIAL_PROC (GINFO (p))) = SUB (n);
1293 // Check arguments and construct modes.
1294 mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))), &PACK (PARTIAL_PROC (GINFO (p))));
1295 DIM (PARTIAL_PROC (GINFO (p))) = count_pack_members (PACK (PARTIAL_PROC (GINFO (p))));
1296 DIM (PARTIAL_LOCALE (GINFO (p))) = count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p))));
1297 PARTIAL_PROC (GINFO (p)) = register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_PROC (GINFO (p)));
1298 PARTIAL_LOCALE (GINFO (p)) = register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p)));
1299 if (DIM (MOID (&d)) != DIM (n)) {
1300 diagnostic (A68_ERROR, p, ERROR_ARGUMENT_NUMBER, n);
1301 make_soid (y, SORT (x), SUB (n), 0);
1302 // make_soid (y, SORT (x), M_ERROR, 0);.
1303 } else {
1304 if (!is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING)) {
1305 cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT);
1306 }
1307 if (DIM (PARTIAL_PROC (GINFO (p))) == 0) {
1308 make_soid (y, SORT (x), SUB (n), 0);
1309 } else {
1310 if (OPTION_PORTCHECK (&A68_JOB)) {
1311 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_EXTENSION);
1312 }
1313 make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0);
1314 }
1315 }
1316 }
1317
1318 //! @brief Mode check slice.
1319
1320 void mode_check_slice (NODE_T * p, MOID_T * ori, SOID_T * x, SOID_T * y)
1321 {
1322 BOOL_T is_ref;
1323 int rowdim, subs, trims;
1324 MOID_T *m = depref_completely (ori), *n = ori;
1325 // WEAK coercion.
1326 while ((IS_REF (n) && !is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK)) {
1327 n = depref_once (n);
1328 }
1329 if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1330 if (IF_MODE_IS_WELL (n)) {
1331 diagnostic (A68_ERROR, p, ERROR_NO_ROW_OR_PROC, n, ATTRIBUTE (SUB (p)));
1332 }
1333 make_soid (y, SORT (x), M_ERROR, 0);
1334 }
1335
1336 MOID (p) = n;
1337 subs = trims = 0;
1338 mode_check_indexer (SUB_NEXT (p), &subs, &trims);
1339 if ((is_ref = is_ref_row (n)) != 0) {
1340 rowdim = DIM (DEFLEX (SUB (n)));
1341 } else {
1342 rowdim = DIM (DEFLEX (n));
1343 }
1344 if ((subs + trims) != rowdim) {
1345 diagnostic (A68_ERROR, p, ERROR_INDEXER_NUMBER, n);
1346 make_soid (y, SORT (x), M_ERROR, 0);
1347 } else {
1348 if (subs > 0 && trims == 0) {
1349 ANNOTATION (NEXT (p)) = SLICE;
1350 m = n;
1351 } else {
1352 ANNOTATION (NEXT (p)) = TRIMMER;
1353 m = n;
1354 }
1355 while (subs > 0) {
1356 if (is_ref) {
1357 m = NAME (m);
1358 } else {
1359 if (IS_FLEX (m)) {
1360 m = SUB (m);
1361 }
1362 m = SLICE (m);
1363 }
1364 ABEND (m == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1365 subs--;
1366 }
1367 // A trim cannot be but deflexed.
1368 if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) {
1369 ABEND (TRIM (m) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1370 make_soid (y, SORT (x), TRIM (m), 0);
1371 } else {
1372 make_soid (y, SORT (x), m, 0);
1373 }
1374 }
1375 }
1376
1377 //! @brief Mode check specification.
1378
1379 int mode_check_specification (NODE_T * p, SOID_T * x, SOID_T * y)
1380 {
1381 SOID_T w, d;
1382 MOID_T *m, *ori;
1383 make_soid (&w, WEAK, NO_MOID, 0);
1384 mode_check_unit (SUB (p), &w, &d);
1385 ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1386 m = depref_completely (ori);
1387 if (IS (m, PROC_SYMBOL)) {
1388 // Assume CALL.
1389 mode_check_call (p, m, x, y);
1390 return CALL;
1391 } else if (IS_ROW (m) || IS_FLEX (m)) {
1392 // Assume SLICE.
1393 mode_check_slice (p, ori, x, y);
1394 return SLICE;
1395 } else {
1396 if (m != M_ERROR) {
1397 diagnostic (A68_SYNTAX_ERROR, p, ERROR_MODE_SPECIFICATION, m);
1398 }
1399 make_soid (y, SORT (x), M_ERROR, 0);
1400 return PRIMARY;
1401 }
1402 }
1403
1404 //! @brief Mode check selection.
1405
1406 void mode_check_selection (NODE_T * p, SOID_T * x, SOID_T * y)
1407 {
1408 SOID_T w, d;
1409 BOOL_T coerce;
1410 MOID_T *n, *str, *ori;
1411 PACK_T *t, *t_2;
1412 char *fs;
1413 BOOL_T deflex = A68_FALSE;
1414 NODE_T *secondary = SUB_NEXT (p);
1415 make_soid (&w, WEAK, NO_MOID, 0);
1416 mode_check_unit (secondary, &w, &d);
1417 n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1418 coerce = A68_TRUE;
1419 while (coerce) {
1420 if (IS (n, STRUCT_SYMBOL)) {
1421 coerce = A68_FALSE;
1422 t = PACK (n);
1423 } else if (IS_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID) {
1424 coerce = A68_FALSE;
1425 deflex = A68_TRUE;
1426 t = PACK (MULTIPLE (n));
1427 } else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID) {
1428 coerce = A68_FALSE;
1429 deflex = A68_TRUE;
1430 t = PACK (MULTIPLE (n));
1431 } else if (IS_REF (n) && is_name_struct (n)) {
1432 coerce = A68_FALSE;
1433 t = PACK (NAME (n));
1434 } else if (is_deprefable (n)) {
1435 coerce = A68_TRUE;
1436 n = SUB (n);
1437 t = NO_PACK;
1438 } else {
1439 coerce = A68_FALSE;
1440 t = NO_PACK;
1441 }
1442 }
1443 if (t == NO_PACK) {
1444 if (IF_MODE_IS_WELL (MOID (&d))) {
1445 diagnostic (A68_ERROR, secondary, ERROR_NO_STRUCT, ori, ATTRIBUTE (secondary));
1446 }
1447 make_soid (y, SORT (x), M_ERROR, 0);
1448 return;
1449 }
1450 MOID (NEXT (p)) = n;
1451 fs = NSYMBOL (SUB (p));
1452 str = n;
1453 while (IS_REF (str)) {
1454 str = SUB (str);
1455 }
1456 if (IS_FLEX (str)) {
1457 str = SUB (str);
1458 }
1459 if (IS_ROW (str)) {
1460 str = SUB (str);
1461 }
1462 t_2 = PACK (str);
1463 while (t != NO_PACK && t_2 != NO_PACK) {
1464 if (TEXT (t) == fs) {
1465 MOID_T *ret = MOID (t);
1466 if (deflex && TRIM (ret) != NO_MOID) {
1467 ret = TRIM (ret);
1468 }
1469 make_soid (y, SORT (x), ret, 0);
1470 MOID (p) = ret;
1471 NODE_PACK (SUB (p)) = t_2;
1472 return;
1473 }
1474 FORWARD (t);
1475 FORWARD (t_2);
1476 }
1477 make_soid (&d, NO_SORT, n, 0);
1478 diagnostic (A68_ERROR, p, ERROR_NO_FIELD, str, fs);
1479 make_soid (y, SORT (x), M_ERROR, 0);
1480 }
1481
1482 //! @brief Mode check diagonal.
1483
1484 void mode_check_diagonal (NODE_T * p, SOID_T * x, SOID_T * y)
1485 {
1486 SOID_T w, d;
1487 NODE_T *tert;
1488 MOID_T *n, *ori;
1489 int rowdim;
1490 BOOL_T is_ref;
1491 if (IS (p, TERTIARY)) {
1492 make_soid (&w, STRONG, M_INT, 0);
1493 mode_check_unit (p, &w, &d);
1494 if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) {
1495 cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0);
1496 }
1497 tert = NEXT_NEXT (p);
1498 } else {
1499 tert = NEXT (p);
1500 }
1501 make_soid (&w, WEAK, NO_MOID, 0);
1502 mode_check_unit (tert, &w, &d);
1503 n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1504 while (IS_REF (n) && !is_ref_row (n)) {
1505 n = depref_once (n);
1506 }
1507 if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1508 if (IF_MODE_IS_WELL (n)) {
1509 diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1510 }
1511 make_soid (y, SORT (x), M_ERROR, 0);
1512 return;
1513 }
1514 if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1515 if (IF_MODE_IS_WELL (n)) {
1516 diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1517 }
1518 make_soid (y, SORT (x), M_ERROR, 0);
1519 return;
1520 }
1521 if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1522 rowdim = DIM (DEFLEX (SUB (n)));
1523 } else {
1524 rowdim = DIM (DEFLEX (n));
1525 }
1526 if (rowdim != 2) {
1527 diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1528 make_soid (y, SORT (x), M_ERROR, 0);
1529 return;
1530 }
1531 MOID (tert) = n;
1532 if (is_ref) {
1533 n = NAME (n);
1534 ABEND (!IS_REF (n), ERROR_INTERNAL_CONSISTENCY, PM (n));
1535 } else {
1536 n = SLICE (n);
1537 }
1538 ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1539 make_soid (y, SORT (x), n, 0);
1540 }
1541
1542 //! @brief Mode check transpose.
1543
1544 void mode_check_transpose (NODE_T * p, SOID_T * x, SOID_T * y)
1545 {
1546 SOID_T w, d;
1547 NODE_T *tert = NEXT (p);
1548 MOID_T *n, *ori;
1549 int rowdim;
1550 BOOL_T is_ref;
1551 make_soid (&w, WEAK, NO_MOID, 0);
1552 mode_check_unit (tert, &w, &d);
1553 n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1554 while (IS_REF (n) && !is_ref_row (n)) {
1555 n = depref_once (n);
1556 }
1557 if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1558 if (IF_MODE_IS_WELL (n)) {
1559 diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1560 }
1561 make_soid (y, SORT (x), M_ERROR, 0);
1562 return;
1563 }
1564 if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1565 if (IF_MODE_IS_WELL (n)) {
1566 diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1567 }
1568 make_soid (y, SORT (x), M_ERROR, 0);
1569 return;
1570 }
1571 if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1572 rowdim = DIM (DEFLEX (SUB (n)));
1573 } else {
1574 rowdim = DIM (DEFLEX (n));
1575 }
1576 if (rowdim != 2) {
1577 diagnostic (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY);
1578 make_soid (y, SORT (x), M_ERROR, 0);
1579 return;
1580 }
1581 MOID (tert) = n;
1582 ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1583 make_soid (y, SORT (x), n, 0);
1584 }
1585
1586 //! @brief Mode check row or column function.
1587
1588 void mode_check_row_column_function (NODE_T * p, SOID_T * x, SOID_T * y)
1589 {
1590 SOID_T w, d;
1591 NODE_T *tert;
1592 MOID_T *n, *ori;
1593 int rowdim;
1594 BOOL_T is_ref;
1595 if (IS (p, TERTIARY)) {
1596 make_soid (&w, STRONG, M_INT, 0);
1597 mode_check_unit (p, &w, &d);
1598 if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) {
1599 cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0);
1600 }
1601 tert = NEXT_NEXT (p);
1602 } else {
1603 tert = NEXT (p);
1604 }
1605 make_soid (&w, WEAK, NO_MOID, 0);
1606 mode_check_unit (tert, &w, &d);
1607 n = ori = determine_unique_mode (&d, SAFE_DEFLEXING);
1608 while (IS_REF (n) && !is_ref_row (n)) {
1609 n = depref_once (n);
1610 }
1611 if (n != NO_MOID && (IS_FLEX (n) || IS_REF_FLEX (n))) {
1612 if (IF_MODE_IS_WELL (n)) {
1613 diagnostic (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY);
1614 }
1615 make_soid (y, SORT (x), M_ERROR, 0);
1616 return;
1617 }
1618 if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) {
1619 if (IF_MODE_IS_WELL (n)) {
1620 diagnostic (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY);
1621 }
1622 make_soid (y, SORT (x), M_ERROR, 0);
1623 return;
1624 }
1625 if ((is_ref = is_ref_row (n)) != A68_FALSE) {
1626 rowdim = DIM (DEFLEX (SUB (n)));
1627 } else {
1628 rowdim = DIM (DEFLEX (n));
1629 }
1630 if (rowdim != 1) {
1631 diagnostic (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY);
1632 make_soid (y, SORT (x), M_ERROR, 0);
1633 return;
1634 }
1635 MOID (tert) = n;
1636 ABEND (n == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1637 make_soid (y, SORT (x), ROWED (n), 0);
1638 }
1639
1640 //! @brief Mode check format text.
1641
1642 void mode_check_format_text (NODE_T * p)
1643 {
1644 for (; p != NO_NODE; FORWARD (p)) {
1645 mode_check_format_text (SUB (p));
1646 if (IS (p, FORMAT_PATTERN)) {
1647 SOID_T x, y;
1648 make_soid (&x, STRONG, M_FORMAT, 0);
1649 mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1650 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1651 cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1652 }
1653 } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) {
1654 SOID_T x, y;
1655 make_soid (&x, STRONG, M_ROW_INT, 0);
1656 mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1657 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1658 cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1659 }
1660 } else if (IS (p, DYNAMIC_REPLICATOR)) {
1661 SOID_T x, y;
1662 make_soid (&x, STRONG, M_INT, 0);
1663 mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
1664 if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) {
1665 cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
1666 }
1667 }
1668 }
1669 }
1670
1671 //! @brief Mode check unit.
1672
1673 void mode_check_unit (NODE_T * p, SOID_T * x, SOID_T * y)
1674 {
1675 if (p == NO_NODE) {
1676 return;
1677 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) {
1678 mode_check_unit (SUB (p), x, y);
1679 // Ex primary.
1680 } else if (IS (p, SPECIFICATION)) {
1681 ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y);
1682 warn_for_voiding (p, x, y, ATTRIBUTE (p));
1683 } else if (IS (p, CAST)) {
1684 mode_check_cast (SUB (p), x, y);
1685 warn_for_voiding (p, x, y, CAST);
1686 } else if (IS (p, DENOTATION)) {
1687 make_soid (y, SORT (x), MOID (SUB (p)), 0);
1688 warn_for_voiding (p, x, y, DENOTATION);
1689 } else if (IS (p, IDENTIFIER)) {
1690 if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID)) {
1691 int att = first_tag_global (TABLE (p), NSYMBOL (p));
1692 if (att == STOP) {
1693 (void) add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
1694 diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
1695 MOID (p) = M_ERROR;
1696 } else {
1697 TAG_T *z = find_tag_global (TABLE (p), att, NSYMBOL (p));
1698 if (att == IDENTIFIER && z != NO_TAG) {
1699 MOID (p) = MOID (z);
1700 } else {
1701 (void) add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
1702 diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
1703 MOID (p) = M_ERROR;
1704 }
1705 }
1706 }
1707 make_soid (y, SORT (x), MOID (p), 0);
1708 warn_for_voiding (p, x, y, IDENTIFIER);
1709 } else if (IS (p, ENCLOSED_CLAUSE)) {
1710 mode_check_enclosed (SUB (p), x, y);
1711 } else if (IS (p, FORMAT_TEXT)) {
1712 mode_check_format_text (p);
1713 make_soid (y, SORT (x), M_FORMAT, 0);
1714 warn_for_voiding (p, x, y, FORMAT_TEXT);
1715 // Ex secondary.
1716 } else if (IS (p, GENERATOR)) {
1717 mode_check_declarer (SUB (p));
1718 make_soid (y, SORT (x), MOID (SUB (p)), 0);
1719 warn_for_voiding (p, x, y, GENERATOR);
1720 } else if (IS (p, SELECTION)) {
1721 mode_check_selection (SUB (p), x, y);
1722 warn_for_voiding (p, x, y, SELECTION);
1723 // Ex tertiary.
1724 } else if (IS (p, NIHIL)) {
1725 make_soid (y, STRONG, M_HIP, 0);
1726 } else if (IS (p, FORMULA)) {
1727 mode_check_formula (p, x, y);
1728 if (!IS_REF (MOID (y))) {
1729 warn_for_voiding (p, x, y, FORMULA);
1730 }
1731 } else if (IS (p, DIAGONAL_FUNCTION)) {
1732 mode_check_diagonal (SUB (p), x, y);
1733 warn_for_voiding (p, x, y, DIAGONAL_FUNCTION);
1734 } else if (IS (p, TRANSPOSE_FUNCTION)) {
1735 mode_check_transpose (SUB (p), x, y);
1736 warn_for_voiding (p, x, y, TRANSPOSE_FUNCTION);
1737 } else if (IS (p, ROW_FUNCTION)) {
1738 mode_check_row_column_function (SUB (p), x, y);
1739 warn_for_voiding (p, x, y, ROW_FUNCTION);
1740 } else if (IS (p, COLUMN_FUNCTION)) {
1741 mode_check_row_column_function (SUB (p), x, y);
1742 warn_for_voiding (p, x, y, COLUMN_FUNCTION);
1743 // Ex unit.
1744 } else if (is_one_of (p, JUMP, SKIP, STOP)) {
1745 if (SORT (x) != STRONG) {
1746 diagnostic (A68_WARNING, p, WARNING_HIP, SORT (x));
1747 }
1748 // make_soid (y, STRONG, M_HIP, 0);
1749 make_soid (y, SORT (x), M_HIP, 0);
1750 } else if (IS (p, ASSIGNATION)) {
1751 mode_check_assignation (SUB (p), x, y);
1752 } else if (IS (p, IDENTITY_RELATION)) {
1753 mode_check_identity_relation (SUB (p), x, y);
1754 warn_for_voiding (p, x, y, IDENTITY_RELATION);
1755 } else if (IS (p, ROUTINE_TEXT)) {
1756 mode_check_routine_text (SUB (p), y);
1757 make_soid (y, SORT (x), MOID (p), 0);
1758 warn_for_voiding (p, x, y, ROUTINE_TEXT);
1759 } else if (IS (p, ASSERTION)) {
1760 mode_check_assertion (SUB (p));
1761 make_soid (y, STRONG, M_VOID, 0);
1762 } else if (IS (p, AND_FUNCTION)) {
1763 mode_check_bool_function (SUB (p), x, y);
1764 warn_for_voiding (p, x, y, AND_FUNCTION);
1765 } else if (IS (p, OR_FUNCTION)) {
1766 mode_check_bool_function (SUB (p), x, y);
1767 warn_for_voiding (p, x, y, OR_FUNCTION);
1768 } else if (IS (p, CODE_CLAUSE)) {
1769 make_soid (y, STRONG, M_HIP, 0);
1770 }
1771 MOID (p) = MOID (y);
1772 }
1773
