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