parser-modes.c
1 //! @file parser-modes.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 table management.
25
26 #include "a68g.h"
27 #include "a68g-postulates.h"
28 #include "a68g-parser.h"
29
30 // Mode collection, equivalencing and derived modes.
31
32 // Mode service routines.
33
34 //! @brief Count bounds in declarer in tree.
35
36 int count_bounds (NODE_T * p)
37 {
38 if (p == NO_NODE) {
39 return 0;
40 } else {
41 if (IS (p, BOUND)) {
42 return 1 + count_bounds (NEXT (p));
43 } else {
44 return count_bounds (NEXT (p)) + count_bounds (SUB (p));
45 }
46 }
47 }
48
49 //! @brief Count number of SHORTs or LONGs.
50
51 int count_sizety (NODE_T * p)
52 {
53 if (p == NO_NODE) {
54 return 0;
55 } else if (IS (p, LONGETY)) {
56 return count_sizety (SUB (p)) + count_sizety (NEXT (p));
57 } else if (IS (p, SHORTETY)) {
58 return count_sizety (SUB (p)) + count_sizety (NEXT (p));
59 } else if (IS (p, LONG_SYMBOL)) {
60 return 1;
61 } else if (IS (p, SHORT_SYMBOL)) {
62 return -1;
63 } else {
64 return 0;
65 }
66 }
67
68 //! @brief Count moids in a pack.
69
70 int count_pack_members (PACK_T * u)
71 {
72 int k = 0;
73 for (; u != NO_PACK; FORWARD (u)) {
74 k++;
75 }
76 return k;
77 }
78
79 //! @brief Replace a mode by its equivalent mode.
80
81 void resolve_equivalent (MOID_T ** m)
82 {
83 while ((*m) != NO_MOID && EQUIVALENT ((*m)) != NO_MOID && (*m) != EQUIVALENT (*m)) {
84 (*m) = EQUIVALENT (*m);
85 }
86 }
87
88 //! @brief Reset moid.
89
90 void reset_moid_tree (NODE_T * p)
91 {
92 for (; p != NO_NODE; FORWARD (p)) {
93 MOID (p) = NO_MOID;
94 reset_moid_tree (SUB (p));
95 }
96 }
97
98 //! @brief Renumber moids.
99
100 void renumber_moids (MOID_T * p, int n)
101 {
102 if (p != NO_MOID) {
103 NUMBER (p) = n;
104 renumber_moids (NEXT (p), n + 1);
105 }
106 }
107
108 //! @brief Register mode in the global mode table, if mode is unique.
109
110 MOID_T *register_extra_mode (MOID_T ** z, MOID_T * u)
111 {
112 // If we already know this mode, return the existing entry; otherwise link it in.
113 for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head)) {
114 if (prove_moid_equivalence (head, u)) {
115 return head;
116 }
117 }
118 // Link to chain and exit.
119 NUMBER (u) = A68 (mode_count)++;
120 NEXT (u) = (*z);
121 return *z = u;
122 }
123
124 //! @brief Add mode "sub" to chain "z".
125
126 MOID_T *add_mode (MOID_T ** z, int att, int dim, NODE_T * node, MOID_T * sub, PACK_T * pack)
127 {
128 MOID_T *new_mode = new_moid ();
129 if (sub == NO_MOID) {
130 ABEND (att == REF_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
131 ABEND (att == FLEX_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
132 ABEND (att == ROW_SYMBOL, ERROR_INTERNAL_CONSISTENCY, __func__);
133 }
134 USE (new_mode) = A68_FALSE;
135 SIZE (new_mode) = 0;
136 ATTRIBUTE (new_mode) = att;
137 DIM (new_mode) = dim;
138 NODE (new_mode) = node;
139 HAS_ROWS (new_mode) = (BOOL_T) (att == ROW_SYMBOL);
140 SUB (new_mode) = sub;
141 PACK (new_mode) = pack;
142 NEXT (new_mode) = NO_MOID;
143 EQUIVALENT (new_mode) = NO_MOID;
144 SLICE (new_mode) = NO_MOID;
145 DEFLEXED (new_mode) = NO_MOID;
146 NAME (new_mode) = NO_MOID;
147 MULTIPLE (new_mode) = NO_MOID;
148 ROWED (new_mode) = NO_MOID;
149 return register_extra_mode (z, new_mode);
150 }
151
152 //! @brief Contract a UNION.
153
154 void contract_union (MOID_T * u)
155 {
156 for (PACK_T *s = PACK (u); s != NO_PACK; FORWARD (s)) {
157 PACK_T *t = s;
158 while (t != NO_PACK) {
159 if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s)) {
160 MOID (t) = MOID (t);
161 NEXT (t) = NEXT_NEXT (t);
162 } else {
163 FORWARD (t);
164 }
165 }
166 }
167 }
168
169 //! @brief Absorb UNION pack.
170
171 PACK_T *absorb_union_pack (PACK_T * u)
172 {
173 PACK_T *z;
174 BOOL_T siga;
175 do {
176 z = NO_PACK;
177 siga = A68_FALSE;
178 for (PACK_T *t = u; t != NO_PACK; FORWARD (t)) {
179 if (IS (MOID (t), UNION_SYMBOL)) {
180 siga = A68_TRUE;
181 for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
182 (void) add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
183 }
184 } else {
185 (void) add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
186 }
187 }
188 u = z;
189 } while (siga);
190 return z;
191 }
192
193 //! @brief Add row and its slices to chain, recursively.
194
195 MOID_T *add_row (MOID_T ** p, int dim, MOID_T * sub, NODE_T * n, BOOL_T derivate)
196 {
197 MOID_T *q = add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK);
198 DERIVATE (q) |= derivate;
199 if (dim > 1) {
200 SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate);
201 } else {
202 SLICE (q) = sub;
203 }
204 return q;
205 }
206
207 //! @brief Add a moid to a pack, maybe with a (field) name.
208
209 void add_mode_to_pack (PACK_T ** p, MOID_T * m, char *text, NODE_T * node)
210 {
211 PACK_T *z = new_pack ();
212 MOID (z) = m;
213 TEXT (z) = text;
214 NODE (z) = node;
215 NEXT (z) = *p;
216 PREVIOUS (z) = NO_PACK;
217 if (NEXT (z) != NO_PACK) {
218 PREVIOUS (NEXT (z)) = z;
219 }
220 // Link in chain.
221 *p = z;
222 }
223
224 //! @brief Add a moid to a pack, maybe with a (field) name.
225
226 void add_mode_to_pack_end (PACK_T ** p, MOID_T * m, char *text, NODE_T * node)
227 {
228 PACK_T *z = new_pack ();
229 MOID (z) = m;
230 TEXT (z) = text;
231 NODE (z) = node;
232 NEXT (z) = NO_PACK;
233 if (NEXT (z) != NO_PACK) {
234 PREVIOUS (NEXT (z)) = z;
235 }
236 // Link in chain.
237 while ((*p) != NO_PACK) {
238 p = &(NEXT (*p));
239 }
240 PREVIOUS (z) = (*p);
241 (*p) = z;
242 }
243
244 //! @brief Absorb UNION members.
245
246 void absorb_unions (MOID_T * m)
247 {
248 // UNION (A, UNION (B, C)) = UNION (A, B, C) or
249 // UNION (A, UNION (A, B)) = UNION (A, B).
250 for (; m != NO_MOID; FORWARD (m)) {
251 if (IS (m, UNION_SYMBOL)) {
252 PACK (m) = absorb_union_pack (PACK (m));
253 }
254 }
255 }
256
257 //! @brief Contract UNIONs .
258
259 void contract_unions (MOID_T * m)
260 {
261 // UNION (A, B, A) -> UNION (A, B).
262 for (; m != NO_MOID; FORWARD (m)) {
263 if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID) {
264 contract_union (m);
265 }
266 }
267 }
268
269 // Routines to collect MOIDs from the program text.
270
271 //! @brief Search standard mode in standard environ.
272
273 MOID_T *search_standard_mode (int sizety, NODE_T * indicant)
274 {
275 // Search standard mode.
276 for (MOID_T *p = TOP_MOID (&A68_JOB); p != NO_MOID; FORWARD (p)) {
277 if (IS (p, STANDARD) && DIM (p) == sizety && NSYMBOL (NODE (p)) == NSYMBOL (indicant)) {
278 return p;
279 }
280 }
281 // Sanity check
282 //if (sizety == -2 || sizety == 2) {
283 // return NO_MOID;
284 //}
285 // Map onto greater precision.
286 if (sizety < 0) {
287 return search_standard_mode (sizety + 1, indicant);
288 } else if (sizety > 0) {
289 return search_standard_mode (sizety - 1, indicant);
290 } else {
291 return NO_MOID;
292 }
293 }
294
295 //! @brief Collect mode from STRUCT field.
296
297 void get_mode_from_struct_field (NODE_T * p, PACK_T ** u)
298 {
299 if (p != NO_NODE) {
300 if (IS (p, IDENTIFIER)) {
301 ATTRIBUTE (p) = FIELD_IDENTIFIER;
302 (void) add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p);
303 } else if (IS (p, DECLARER)) {
304 MOID_T *new_one = get_mode_from_declarer (p);
305 get_mode_from_struct_field (NEXT (p), u);
306 for (PACK_T *t = *u; t && MOID (t) == NO_MOID; FORWARD (t)) {
307 MOID (t) = new_one;
308 MOID (NODE (t)) = new_one;
309 }
310 } else {
311 get_mode_from_struct_field (NEXT (p), u);
312 get_mode_from_struct_field (SUB (p), u);
313 }
314 }
315 }
316
317 //! @brief Collect MODE from formal pack.
318
319 void get_mode_from_formal_pack (NODE_T * p, PACK_T ** u)
320 {
321 if (p != NO_NODE) {
322 if (IS (p, DECLARER)) {
323 get_mode_from_formal_pack (NEXT (p), u);
324 MOID_T *z = get_mode_from_declarer (p);
325 (void) add_mode_to_pack (u, z, NO_TEXT, p);
326 } else {
327 get_mode_from_formal_pack (NEXT (p), u);
328 get_mode_from_formal_pack (SUB (p), u);
329 }
330 }
331 }
332
333 //! @brief Collect MODE or VOID from formal UNION pack.
334
335 void get_mode_from_union_pack (NODE_T * p, PACK_T ** u)
336 {
337 if (p != NO_NODE) {
338 if (IS (p, DECLARER) || IS (p, VOID_SYMBOL)) {
339 get_mode_from_union_pack (NEXT (p), u);
340 MOID_T *z = get_mode_from_declarer (p);
341 (void) add_mode_to_pack (u, z, NO_TEXT, p);
342 } else {
343 get_mode_from_union_pack (NEXT (p), u);
344 get_mode_from_union_pack (SUB (p), u);
345 }
346 }
347 }
348
349 //! @brief Collect mode from PROC, OP pack.
350
351 void get_mode_from_routine_pack (NODE_T * p, PACK_T ** u)
352 {
353 if (p != NO_NODE) {
354 if (IS (p, IDENTIFIER)) {
355 (void) add_mode_to_pack (u, NO_MOID, NO_TEXT, p);
356 } else if (IS (p, DECLARER)) {
357 MOID_T *z = get_mode_from_declarer (p);
358 for (PACK_T *t = *u; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) {
359 MOID (t) = z;
360 MOID (NODE (t)) = z;
361 }
362 (void) add_mode_to_pack (u, z, NO_TEXT, p);
363 } else {
364 get_mode_from_routine_pack (NEXT (p), u);
365 get_mode_from_routine_pack (SUB (p), u);
366 }
367 }
368 }
369
370 //! @brief Collect MODE from DECLARER.
371
372 MOID_T *get_mode_from_declarer (NODE_T * p)
373 {
374 if (p == NO_NODE) {
375 return NO_MOID;
376 } else {
377 if (IS (p, DECLARER)) {
378 if (MOID (p) != NO_MOID) {
379 return MOID (p);
380 } else {
381 return MOID (p) = get_mode_from_declarer (SUB (p));
382 }
383 } else {
384 if (IS (p, VOID_SYMBOL)) {
385 MOID (p) = M_VOID;
386 return MOID (p);
387 } else if (IS (p, LONGETY)) {
388 if (whether (p, LONGETY, INDICANT, STOP)) {
389 int k = count_sizety (SUB (p));
390 MOID (p) = search_standard_mode (k, NEXT (p));
391 return MOID (p);
392 } else {
393 return NO_MOID;
394 }
395 } else if (IS (p, SHORTETY)) {
396 if (whether (p, SHORTETY, INDICANT, STOP)) {
397 int k = count_sizety (SUB (p));
398 MOID (p) = search_standard_mode (k, NEXT (p));
399 return MOID (p);
400 } else {
401 return NO_MOID;
402 }
403 } else if (IS (p, INDICANT)) {
404 MOID_T *q = search_standard_mode (0, p);
405 if (q != NO_MOID) {
406 MOID (p) = q;
407 } else {
408 // Position of definition tells indicants apart.
409 TAG_T *y = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
410 if (y == NO_TAG) {
411 diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p));
412 } else {
413 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y), NO_MOID, NO_PACK);
414 }
415 }
416 return MOID (p);
417 } else if (IS_REF (p)) {
418 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
419 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
420 return MOID (p);
421 } else if (IS_FLEX (p)) {
422 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
423 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK);
424 SLICE (MOID (p)) = SLICE (new_one);
425 return MOID (p);
426 } else if (IS (p, FORMAL_BOUNDS)) {
427 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
428 MOID (p) = add_row (&TOP_MOID (&A68_JOB), 1 + count_formal_bounds (SUB (p)), new_one, p, A68_FALSE);
429 return MOID (p);
430 } else if (IS (p, BOUNDS)) {
431 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
432 MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, A68_FALSE);
433 return MOID (p);
434 } else if (IS (p, STRUCT_SYMBOL)) {
435 PACK_T *u = NO_PACK;
436 get_mode_from_struct_field (NEXT (p), &u);
437 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (u), p, NO_MOID, u);
438 return MOID (p);
439 } else if (IS (p, UNION_SYMBOL)) {
440 PACK_T *u = NO_PACK;
441 get_mode_from_union_pack (NEXT (p), &u);
442 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, count_pack_members (u), p, NO_MOID, u);
443 return MOID (p);
444 } else if (IS (p, PROC_SYMBOL)) {
445 NODE_T *save = p;
446 PACK_T *u = NO_PACK;
447 if (IS (NEXT (p), FORMAL_DECLARERS)) {
448 get_mode_from_formal_pack (SUB_NEXT (p), &u);
449 FORWARD (p);
450 }
451 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
452 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
453 MOID (save) = MOID (p);
454 return MOID (p);
455 } else {
456 return NO_MOID;
457 }
458 }
459 }
460 }
461
462 //! @brief Collect MODEs from a routine-text header.
463
464 MOID_T *get_mode_from_routine_text (NODE_T * p)
465 {
466 PACK_T *u = NO_PACK;
467 NODE_T *q = p;
468 if (IS (p, PARAMETER_PACK)) {
469 get_mode_from_routine_pack (SUB (p), &u);
470 FORWARD (p);
471 }
472 MOID_T *n = get_mode_from_declarer (p);
473 return add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), q, n, u);
474 }
475
476 //! @brief Collect modes from operator-plan.
477
478 MOID_T *get_mode_from_operator (NODE_T * p)
479 {
480 PACK_T *u = NO_PACK;
481 NODE_T *save = p;
482 if (IS (NEXT (p), FORMAL_DECLARERS)) {
483 get_mode_from_formal_pack (SUB_NEXT (p), &u);
484 FORWARD (p);
485 }
486 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
487 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
488 return MOID (p);
489 }
490
491 //! @brief Collect mode from denotation.
492
493 void get_mode_from_denotation (NODE_T * p, int sizety)
494 {
495 if (p != NO_NODE) {
496 if (IS (p, ROW_CHAR_DENOTATION)) {
497 if (strlen (NSYMBOL (p)) == 1) {
498 MOID (p) = M_CHAR;
499 } else {
500 MOID (p) = M_ROW_CHAR;
501 }
502 } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) {
503 MOID (p) = M_BOOL;
504 } else if (IS (p, INT_DENOTATION)) {
505 if (sizety == 0) {
506 MOID (p) = M_INT;
507 } else if (sizety == 1) {
508 MOID (p) = M_LONG_INT;
509 } else if (sizety == 2) {
510 MOID (p) = M_LONG_LONG_INT;
511 } else {
512 MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT);
513 }
514 } else if (IS (p, REAL_DENOTATION)) {
515 if (sizety == 0) {
516 MOID (p) = M_REAL;
517 } else if (sizety == 1) {
518 MOID (p) = M_LONG_REAL;
519 } else if (sizety == 2) {
520 MOID (p) = M_LONG_LONG_REAL;
521 } else {
522 MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL);
523 }
524 } else if (IS (p, BITS_DENOTATION)) {
525 if (sizety == 0) {
526 MOID (p) = M_BITS;
527 } else if (sizety == 1) {
528 MOID (p) = M_LONG_BITS;
529 } else if (sizety == 2) {
530 MOID (p) = M_LONG_LONG_BITS;
531 } else {
532 MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
533 }
534 } else if (IS (p, LONGETY) || IS (p, SHORTETY)) {
535 get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
536 MOID (p) = MOID (NEXT (p));
537 } else if (IS (p, EMPTY_SYMBOL)) {
538 MOID (p) = M_VOID;
539 }
540 }
541 }
542
543 //! @brief Collect modes from the syntax tree.
544
545 void get_modes_from_tree (NODE_T * p, int attribute)
546 {
547 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
548 if (IS (q, VOID_SYMBOL)) {
549 MOID (q) = M_VOID;
550 } else if (IS (q, DECLARER)) {
551 if (attribute == VARIABLE_DECLARATION) {
552 MOID_T *new_one = get_mode_from_declarer (q);
553 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
554 } else {
555 MOID (q) = get_mode_from_declarer (q);
556 }
557 } else if (IS (q, ROUTINE_TEXT)) {
558 MOID (q) = get_mode_from_routine_text (SUB (q));
559 } else if (IS (q, OPERATOR_PLAN)) {
560 MOID (q) = get_mode_from_operator (SUB (q));
561 } else if (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
562 if (attribute == GENERATOR) {
563 MOID_T *new_one = get_mode_from_declarer (NEXT (q));
564 MOID (NEXT (q)) = new_one;
565 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
566 }
567 } else {
568 if (attribute == DENOTATION) {
569 get_mode_from_denotation (q, 0);
570 }
571 }
572 }
573 if (attribute != DENOTATION) {
574 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
575 if (SUB (q) != NO_NODE) {
576 get_modes_from_tree (SUB (q), ATTRIBUTE (q));
577 }
578 }
579 }
580 }
581
582 //! @brief Collect modes from proc variables.
583
584 void get_mode_from_proc_variables (NODE_T * p)
585 {
586 if (p != NO_NODE) {
587 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
588 get_mode_from_proc_variables (SUB (p));
589 get_mode_from_proc_variables (NEXT (p));
590 } else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) {
591 get_mode_from_proc_variables (NEXT (p));
592 } else if (IS (p, DEFINING_IDENTIFIER)) {
593 MOID_T *new_one = MOID (NEXT_NEXT (p));
594 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
595 }
596 }
597 }
598
599 //! @brief Collect modes from proc variable declarations.
600
601 void get_mode_from_proc_var_declarations_tree (NODE_T * p)
602 {
603 for (; p != NO_NODE; FORWARD (p)) {
604 get_mode_from_proc_var_declarations_tree (SUB (p));
605 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
606 get_mode_from_proc_variables (p);
607 }
608 }
609 }
610
611 // Various routines to test modes.
612
613 //! @brief Whether a mode declaration refers to self or relates to void.
614
615 BOOL_T is_well_formed (MOID_T * def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video)
616 {
617 if (z == NO_MOID) {
618 return A68_FALSE;
619 } else if (yin && yang) {
620 return z == M_VOID ? video : A68_TRUE;
621 } else if (z == M_VOID) {
622 return video;
623 } else if (IS (z, STANDARD)) {
624 return A68_TRUE;
625 } else if (IS (z, INDICANT)) {
626 if (def == NO_MOID) {
627 // Check an applied indicant for relation to VOID.
628 while (z != NO_MOID) {
629 z = EQUIVALENT (z);
630 }
631 if (z == M_VOID) {
632 return video;
633 } else {
634 return A68_TRUE;
635 }
636 } else {
637 if (z == def || USE (z)) {
638 return yin && yang;
639 } else {
640 USE (z) = A68_TRUE;
641 BOOL_T wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
642 USE (z) = A68_FALSE;
643 return wwf;
644 }
645 }
646 } else if (IS_REF (z)) {
647 return is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE);
648 } else if (IS (z, PROC_SYMBOL)) {
649 return PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE);
650 } else if (IS_ROW (z)) {
651 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
652 } else if (IS_FLEX (z)) {
653 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
654 } else if (IS (z, STRUCT_SYMBOL)) {
655 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
656 if (!is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) {
657 return A68_FALSE;
658 }
659 }
660 return A68_TRUE;
661 } else if (IS (z, UNION_SYMBOL)) {
662 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
663 if (!is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) {
664 return A68_FALSE;
665 }
666 }
667 return A68_TRUE;
668 } else {
669 return A68_FALSE;
670 }
671 }
672
673 //! @brief Replace a mode by its equivalent mode (walk chain).
674
675 void resolve_eq_members (MOID_T * q)
676 {
677 resolve_equivalent (&SUB (q));
678 resolve_equivalent (&DEFLEXED (q));
679 resolve_equivalent (&MULTIPLE (q));
680 resolve_equivalent (&NAME (q));
681 resolve_equivalent (&SLICE (q));
682 resolve_equivalent (&TRIM (q));
683 resolve_equivalent (&ROWED (q));
684 for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p)) {
685 resolve_equivalent (&MOID (p));
686 }
687 }
688
689 //! @brief Track equivalent tags.
690
691 void resolve_eq_tags (TAG_T * z)
692 {
693 for (; z != NO_TAG; FORWARD (z)) {
694 if (MOID (z) != NO_MOID) {
695 resolve_equivalent (&MOID (z));
696 }
697 }
698 }
699
700 //! @brief Bind modes in syntax tree.
701
702 void bind_modes (NODE_T * p)
703 {
704 for (; p != NO_NODE; FORWARD (p)) {
705 resolve_equivalent (&MOID (p));
706 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
707 TABLE_T *s = TABLE (SUB (p));
708 for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z)) {
709 if (NODE (z) != NO_NODE) {
710 resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
711 MOID (z) = MOID (NEXT_NEXT (NODE (z)));
712 MOID (NODE (z)) = MOID (z);
713 }
714 }
715 }
716 bind_modes (SUB (p));
717 }
718 }
719
720 // Routines for calculating subordinates for selections, for instance selection
721 // from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) yields
722 // [] A fields.
723
724 //! @brief Make name pack.
725
726 void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p)
727 {
728 if (src != NO_PACK) {
729 make_name_pack (NEXT (src), dst, p);
730 MOID_T *z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
731 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
732 }
733 }
734
735 //! @brief Make flex multiple row pack.
736
737 void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
738 {
739 if (src != NO_PACK) {
740 make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
741 MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE);
742 z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
743 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
744 }
745 }
746
747 //! @brief Make name struct.
748
749 MOID_T *make_name_struct (MOID_T * m, MOID_T ** p)
750 {
751 PACK_T *u = NO_PACK;
752 make_name_pack (PACK (m), &u, p);
753 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
754 }
755
756 //! @brief Make name row.
757
758 MOID_T *make_name_row (MOID_T * m, MOID_T ** p)
759 {
760 if (SLICE (m) != NO_MOID) {
761 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
762 } else if (SUB (m) != NO_MOID) {
763 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
764 } else {
765 return NO_MOID; // weird, FLEX INT or so ...
766 }
767 }
768
769 //! @brief Make multiple row pack.
770
771 void make_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
772 {
773 if (src != NO_PACK) {
774 make_multiple_row_pack (NEXT (src), dst, p, dim);
775 (void) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src));
776 }
777 }
778
779 //! @brief Make flex multiple struct.
780
781 MOID_T *make_flex_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
782 {
783 PACK_T *u = NO_PACK;
784 make_flex_multiple_row_pack (PACK (m), &u, p, dim);
785 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
786 }
787
788 //! @brief Make multiple struct.
789
790 MOID_T *make_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
791 {
792 PACK_T *u = NO_PACK;
793 make_multiple_row_pack (PACK (m), &u, p, dim);
794 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
795 }
796
797 //! @brief Whether mode has row.
798
799 BOOL_T is_mode_has_row (MOID_T * m)
800 {
801 if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) {
802 BOOL_T k = A68_FALSE;
803 for (PACK_T *p = PACK (m); p != NO_PACK && k == A68_FALSE; FORWARD (p)) {
804 HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
805 k |= (HAS_ROWS (MOID (p)));
806 }
807 return k;
808 } else {
809 return (BOOL_T) (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
810 }
811 }
812
813 //! @brief Compute derived modes.
814
815 void compute_derived_modes (MODULE_T * mod)
816 {
817 MOID_T *z;
818 int len = 0, nlen = 1;
819 // UNION things.
820 absorb_unions (TOP_MOID (mod));
821 contract_unions (TOP_MOID (mod));
822 // The for-statement below prevents an endless loop.
823 for (int k = 1; k <= 10 && len != nlen; k++) {
824 // Make deflexed modes.
825 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
826 if (SUB (z) != NO_MOID) {
827 if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) {
828 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK);
829 } else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID) {
830 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK);
831 } else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID) {
832 DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK);
833 } else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) {
834 DEFLEXED (z) = DEFLEXED (SUB (z));
835 } else if (IS_FLEX (z)) {
836 DEFLEXED (z) = SUB (z);
837 } else {
838 DEFLEXED (z) = z;
839 }
840 }
841 }
842 // Derived modes for stowed modes.
843 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
844 if (NAME (z) == NO_MOID && IS_REF (z)) {
845 if (IS (SUB (z), STRUCT_SYMBOL)) {
846 NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
847 } else if (IS_ROW (SUB (z))) {
848 NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
849 } else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) {
850 NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
851 }
852 }
853 if (MULTIPLE (z) != NO_MOID) {
854 ;
855 } else if (IS_REF (z)) {
856 if (MULTIPLE (SUB (z)) != NO_MOID) {
857 MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
858 }
859 } else if (IS_ROW (z)) {
860 if (IS (SUB (z), STRUCT_SYMBOL)) {
861 MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
862 }
863 }
864 }
865 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
866 if (TRIM (z) == NO_MOID && IS_FLEX (z)) {
867 TRIM (z) = SUB (z);
868 }
869 if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) {
870 TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
871 }
872 }
873 // Fill out stuff for rows, f.i. inverse relations.
874 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
875 if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) {
876 (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE);
877 } else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) {
878 MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), A68_TRUE);
879 MOID_T *y = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
880 NAME (y) = z;
881 }
882 }
883 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
884 if (IS_ROW (z) && SLICE (z) != NO_MOID) {
885 ROWED (SLICE (z)) = z;
886 }
887 if (IS_REF (z)) {
888 MOID_T *y = SUB (z);
889 if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) {
890 ROWED (NAME (z)) = z;
891 }
892 }
893 }
894 bind_modes (TOP_NODE (mod));
895 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
896 if (IS (z, INDICANT) && NODE (z) != NO_NODE) {
897 EQUIVALENT (z) = MOID (NODE (z));
898 }
899 }
900 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
901 resolve_eq_members (z);
902 }
903 resolve_eq_tags (INDICANTS (A68_STANDENV));
904 resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
905 resolve_eq_tags (OPERATORS (A68_STANDENV));
906 resolve_equivalent (&M_STRING);
907 resolve_equivalent (&M_COMPLEX);
908 resolve_equivalent (&M_COMPL);
909 resolve_equivalent (&M_LONG_COMPLEX);
910 resolve_equivalent (&M_LONG_COMPL);
911 resolve_equivalent (&M_LONG_LONG_COMPLEX);
912 resolve_equivalent (&M_LONG_LONG_COMPL);
913 resolve_equivalent (&M_SEMA);
914 resolve_equivalent (&M_PIPE);
915 // UNION members could be resolved.
916 absorb_unions (TOP_MOID (mod));
917 contract_unions (TOP_MOID (mod));
918 // FLEX INDICANT could be resolved.
919 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
920 if (IS_FLEX (z) && SUB (z) != NO_MOID) {
921 if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) {
922 MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
923 }
924 }
925 }
926 // See what new known modes we have generated by resolving..
927 for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) {
928 MOID_T *v;
929 for (v = NEXT (z); v != NO_MOID; FORWARD (v)) {
930 if (prove_moid_equivalence (z, v)) {
931 EQUIVALENT (z) = v;
932 EQUIVALENT (v) = NO_MOID;
933 }
934 }
935 }
936 // Count the modes to check self consistency.
937 len = nlen;
938 for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
939 nlen++;
940 }
941 }
942 ABEND (M_STRING != M_FLEX_ROW_CHAR, ERROR_INTERNAL_CONSISTENCY, __func__);
943 // Find out what modes contain rows.
944 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
945 HAS_ROWS (z) = is_mode_has_row (z);
946 }
947 // Check flexible modes.
948 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
949 if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) {
950 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
951 }
952 }
953 // Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is wrong.
954 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
955 if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
956 PACK_T *s = PACK (z);
957 for (; s != NO_PACK; FORWARD (s)) {
958 PACK_T *t = NEXT (s);
959 BOOL_T x = A68_TRUE;
960 for (t = NEXT (s); t != NO_PACK && x; FORWARD (t)) {
961 if (TEXT (s) == TEXT (t)) {
962 diagnostic (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD);
963 while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) {
964 FORWARD (s);
965 }
966 x = A68_FALSE;
967 }
968 }
969 }
970 }
971 }
972 // Various union test.
973 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
974 if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
975 PACK_T *s = PACK (z);
976 // Discard unions with one member.
977 if (count_pack_members (s) == 1) {
978 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, z);
979 }
980 // Discard incestuous unions with firmly related modes.
981 for (; s != NO_PACK; FORWARD (s)) {
982 PACK_T *t;
983 for (t = NEXT (s); t != NO_PACK; FORWARD (t)) {
984 if (MOID (t) != MOID (s)) {
985 if (is_firm (MOID (s), MOID (t))) {
986 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z);
987 }
988 }
989 }
990 }
991 // Discard incestuous unions with firmly related subsets.
992 for (s = PACK (z); s != NO_PACK; FORWARD (s)) {
993 MOID_T *n = depref_completely (MOID (s));
994 if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) {
995 diagnostic (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n);
996 }
997 }
998 }
999 }
1000 // Wrap up and exit.
1001 free_postulate_list (A68 (top_postulate), NO_POSTULATE);
1002 A68 (top_postulate) = NO_POSTULATE;
1003 }
1004
1005 //! @brief Make list of all modes in the program.
1006
1007 void make_moid_list (MODULE_T * mod)
1008 {
1009 BOOL_T cont = A68_TRUE;
1010 // Collect modes from the syntax tree.
1011 reset_moid_tree (TOP_NODE (mod));
1012 get_modes_from_tree (TOP_NODE (mod), STOP);
1013 get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
1014 // Connect indicants to their declarers.
1015 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1016 if (IS (z, INDICANT)) {
1017 NODE_T *u = NODE (z);
1018 ABEND (NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1019 ABEND (NEXT_NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1020 ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1021 EQUIVALENT (z) = MOID (NEXT_NEXT (u));
1022 }
1023 }
1024 // Checks on wrong declarations.
1025 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1026 USE (z) = A68_FALSE;
1027 }
1028 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1029 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1030 if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) {
1031 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1032 cont = A68_FALSE;
1033 }
1034 }
1035 }
1036 for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z)) {
1037 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1038 ;
1039 } else if (NODE (z) != NO_NODE) {
1040 if (!is_well_formed (NO_MOID, z, A68_FALSE, A68_FALSE, A68_TRUE)) {
1041 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1042 }
1043 }
1044 }
1045 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1046 ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, __func__);
1047 }
1048 if (ERROR_COUNT (mod) != 0) {
1049 return;
1050 }
1051 compute_derived_modes (mod);
1052 init_postulates ();
1053 }
