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