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