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-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 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 (A68_LEVEL <= 2)
526 if (sizety == 0) {
527 MOID (p) = M_BITS;
528 } else if (sizety == 1) {
529 MOID (p) = M_LONG_BITS;
530 } else if (sizety == 2) {
531 MOID (p) = M_LONG_LONG_BITS;
532 } else {
533 MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
534 }
535 #else
536 if (sizety == 0) {
537 MOID (p) = M_BITS;
538 } else if (sizety == 1) {
539 MOID (p) = M_LONG_BITS;
540 } else {
541 MOID (p) = (sizety > 0 ? M_LONG_BITS : M_BITS);
542 }
543 #endif
544 } else if (IS (p, LONGETY) || IS (p, SHORTETY)) {
545 get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
546 MOID (p) = MOID (NEXT (p));
547 } else if (IS (p, EMPTY_SYMBOL)) {
548 MOID (p) = M_VOID;
549 }
550 }
551 }
552
553 //! @brief Collect modes from the syntax tree.
554
555 void get_modes_from_tree (NODE_T * p, int attribute)
556 {
557 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
558 if (IS (q, VOID_SYMBOL)) {
559 MOID (q) = M_VOID;
560 } else if (IS (q, DECLARER)) {
561 if (attribute == VARIABLE_DECLARATION) {
562 MOID_T *new_one = get_mode_from_declarer (q);
563 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
564 } else {
565 MOID (q) = get_mode_from_declarer (q);
566 }
567 } else if (IS (q, ROUTINE_TEXT)) {
568 MOID (q) = get_mode_from_routine_text (SUB (q));
569 } else if (IS (q, OPERATOR_PLAN)) {
570 MOID (q) = get_mode_from_operator (SUB (q));
571 } else if (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
572 if (attribute == GENERATOR) {
573 MOID_T *new_one = get_mode_from_declarer (NEXT (q));
574 MOID (NEXT (q)) = new_one;
575 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
576 }
577 } else {
578 if (attribute == DENOTATION) {
579 get_mode_from_denotation (q, 0);
580 }
581 }
582 }
583 if (attribute != DENOTATION) {
584 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
585 if (SUB (q) != NO_NODE) {
586 get_modes_from_tree (SUB (q), ATTRIBUTE (q));
587 }
588 }
589 }
590 }
591
592 //! @brief Collect modes from proc variables.
593
594 void get_mode_from_proc_variables (NODE_T * p)
595 {
596 if (p != NO_NODE) {
597 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
598 get_mode_from_proc_variables (SUB (p));
599 get_mode_from_proc_variables (NEXT (p));
600 } else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) {
601 get_mode_from_proc_variables (NEXT (p));
602 } else if (IS (p, DEFINING_IDENTIFIER)) {
603 MOID_T *new_one = MOID (NEXT_NEXT (p));
604 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
605 }
606 }
607 }
608
609 //! @brief Collect modes from proc variable declarations.
610
611 void get_mode_from_proc_var_declarations_tree (NODE_T * p)
612 {
613 for (; p != NO_NODE; FORWARD (p)) {
614 get_mode_from_proc_var_declarations_tree (SUB (p));
615 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
616 get_mode_from_proc_variables (p);
617 }
618 }
619 }
620
621 // Various routines to test modes.
622
623 //! @brief Whether a mode declaration refers to self or relates to void.
624
625 BOOL_T is_well_formed (MOID_T * def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video)
626 {
627 if (z == NO_MOID) {
628 return A68_FALSE;
629 } else if (yin && yang) {
630 return z == M_VOID ? video : A68_TRUE;
631 } else if (z == M_VOID) {
632 return video;
633 } else if (IS (z, STANDARD)) {
634 return A68_TRUE;
635 } else if (IS (z, INDICANT)) {
636 if (def == NO_MOID) {
637 // Check an applied indicant for relation to VOID.
638 while (z != NO_MOID) {
639 z = EQUIVALENT (z);
640 }
641 if (z == M_VOID) {
642 return video;
643 } else {
644 return A68_TRUE;
645 }
646 } else {
647 if (z == def || USE (z)) {
648 return yin && yang;
649 } else {
650 USE (z) = A68_TRUE;
651 BOOL_T wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
652 USE (z) = A68_FALSE;
653 return wwf;
654 }
655 }
656 } else if (IS_REF (z)) {
657 return is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE);
658 } else if (IS (z, PROC_SYMBOL)) {
659 return PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE);
660 } else if (IS_ROW (z)) {
661 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
662 } else if (IS_FLEX (z)) {
663 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
664 } else if (IS (z, STRUCT_SYMBOL)) {
665 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
666 if (!is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) {
667 return A68_FALSE;
668 }
669 }
670 return A68_TRUE;
671 } else if (IS (z, UNION_SYMBOL)) {
672 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
673 if (!is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) {
674 return A68_FALSE;
675 }
676 }
677 return A68_TRUE;
678 } else {
679 return A68_FALSE;
680 }
681 }
682
683 //! @brief Replace a mode by its equivalent mode (walk chain).
684
685 void resolve_eq_members (MOID_T * q)
686 {
687 resolve_equivalent (&SUB (q));
688 resolve_equivalent (&DEFLEXED (q));
689 resolve_equivalent (&MULTIPLE (q));
690 resolve_equivalent (&NAME (q));
691 resolve_equivalent (&SLICE (q));
692 resolve_equivalent (&TRIM (q));
693 resolve_equivalent (&ROWED (q));
694 for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p)) {
695 resolve_equivalent (&MOID (p));
696 }
697 }
698
699 //! @brief Track equivalent tags.
700
701 void resolve_eq_tags (TAG_T * z)
702 {
703 for (; z != NO_TAG; FORWARD (z)) {
704 if (MOID (z) != NO_MOID) {
705 resolve_equivalent (&MOID (z));
706 }
707 }
708 }
709
710 //! @brief Bind modes in syntax tree.
711
712 void bind_modes (NODE_T * p)
713 {
714 for (; p != NO_NODE; FORWARD (p)) {
715 resolve_equivalent (&MOID (p));
716 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
717 TABLE_T *s = TABLE (SUB (p));
718 for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z)) {
719 if (NODE (z) != NO_NODE) {
720 resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
721 MOID (z) = MOID (NEXT_NEXT (NODE (z)));
722 MOID (NODE (z)) = MOID (z);
723 }
724 }
725 }
726 bind_modes (SUB (p));
727 }
728 }
729
730 // Routines for calculating subordinates for selections, for instance selection
731 // from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) yields
732 // [] A fields.
733
734 //! @brief Make name pack.
735
736 void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p)
737 {
738 if (src != NO_PACK) {
739 make_name_pack (NEXT (src), dst, p);
740 MOID_T *z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
741 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
742 }
743 }
744
745 //! @brief Make flex multiple row pack.
746
747 void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
748 {
749 if (src != NO_PACK) {
750 make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
751 MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE);
752 z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
753 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
754 }
755 }
756
757 //! @brief Make name struct.
758
759 MOID_T *make_name_struct (MOID_T * m, MOID_T ** p)
760 {
761 PACK_T *u = NO_PACK;
762 make_name_pack (PACK (m), &u, p);
763 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
764 }
765
766 //! @brief Make name row.
767
768 MOID_T *make_name_row (MOID_T * m, MOID_T ** p)
769 {
770 if (SLICE (m) != NO_MOID) {
771 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
772 } else if (SUB (m) != NO_MOID) {
773 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
774 } else {
775 return NO_MOID; // weird, FLEX INT or so ...
776 }
777 }
778
779 //! @brief Make multiple row pack.
780
781 void make_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
782 {
783 if (src != NO_PACK) {
784 make_multiple_row_pack (NEXT (src), dst, p, dim);
785 (void) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src));
786 }
787 }
788
789 //! @brief Make flex multiple struct.
790
791 MOID_T *make_flex_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
792 {
793 PACK_T *u = NO_PACK;
794 make_flex_multiple_row_pack (PACK (m), &u, p, dim);
795 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
796 }
797
798 //! @brief Make multiple struct.
799
800 MOID_T *make_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
801 {
802 PACK_T *u = NO_PACK;
803 make_multiple_row_pack (PACK (m), &u, p, dim);
804 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
805 }
806
807 //! @brief Whether mode has row.
808
809 BOOL_T is_mode_has_row (MOID_T * m)
810 {
811 if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) {
812 BOOL_T k = A68_FALSE;
813 for (PACK_T *p = PACK (m); p != NO_PACK && k == A68_FALSE; FORWARD (p)) {
814 HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
815 k |= (HAS_ROWS (MOID (p)));
816 }
817 return k;
818 } else {
819 return (BOOL_T) (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
820 }
821 }
822
823 //! @brief Compute derived modes.
824
825 void compute_derived_modes (MODULE_T * mod)
826 {
827 MOID_T *z;
828 int len = 0, nlen = 1;
829 // UNION things.
830 absorb_unions (TOP_MOID (mod));
831 contract_unions (TOP_MOID (mod));
832 // The for-statement below prevents an endless loop.
833 for (int k = 1; k <= 10 && len != nlen; k++) {
834 // Make deflexed modes.
835 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
836 if (SUB (z) != NO_MOID) {
837 if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) {
838 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK);
839 } else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID) {
840 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK);
841 } else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID) {
842 DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK);
843 } else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) {
844 DEFLEXED (z) = DEFLEXED (SUB (z));
845 } else if (IS_FLEX (z)) {
846 DEFLEXED (z) = SUB (z);
847 } else {
848 DEFLEXED (z) = z;
849 }
850 }
851 }
852 // Derived modes for stowed modes.
853 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
854 if (NAME (z) == NO_MOID && IS_REF (z)) {
855 if (IS (SUB (z), STRUCT_SYMBOL)) {
856 NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
857 } else if (IS_ROW (SUB (z))) {
858 NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
859 } else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) {
860 NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
861 }
862 }
863 if (MULTIPLE (z) != NO_MOID) {
864 ;
865 } else if (IS_REF (z)) {
866 if (MULTIPLE (SUB (z)) != NO_MOID) {
867 MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
868 }
869 } else if (IS_ROW (z)) {
870 if (IS (SUB (z), STRUCT_SYMBOL)) {
871 MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
872 }
873 }
874 }
875 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
876 if (TRIM (z) == NO_MOID && IS_FLEX (z)) {
877 TRIM (z) = SUB (z);
878 }
879 if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) {
880 TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
881 }
882 }
883 // Fill out stuff for rows, f.i. inverse relations.
884 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
885 if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) {
886 (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE);
887 } else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) {
888 MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), A68_TRUE);
889 MOID_T *y = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
890 NAME (y) = z;
891 }
892 }
893 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
894 if (IS_ROW (z) && SLICE (z) != NO_MOID) {
895 ROWED (SLICE (z)) = z;
896 }
897 if (IS_REF (z)) {
898 MOID_T *y = SUB (z);
899 if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) {
900 ROWED (NAME (z)) = z;
901 }
902 }
903 }
904 bind_modes (TOP_NODE (mod));
905 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
906 if (IS (z, INDICANT) && NODE (z) != NO_NODE) {
907 EQUIVALENT (z) = MOID (NODE (z));
908 }
909 }
910 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
911 resolve_eq_members (z);
912 }
913 resolve_eq_tags (INDICANTS (A68_STANDENV));
914 resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
915 resolve_eq_tags (OPERATORS (A68_STANDENV));
916 resolve_equivalent (&M_STRING);
917 resolve_equivalent (&M_COMPLEX);
918 resolve_equivalent (&M_COMPL);
919 resolve_equivalent (&M_LONG_COMPLEX);
920 resolve_equivalent (&M_LONG_COMPL);
921 resolve_equivalent (&M_LONG_LONG_COMPLEX);
922 resolve_equivalent (&M_LONG_LONG_COMPL);
923 resolve_equivalent (&M_SEMA);
924 resolve_equivalent (&M_PIPE);
925 // UNION members could be resolved.
926 absorb_unions (TOP_MOID (mod));
927 contract_unions (TOP_MOID (mod));
928 // FLEX INDICANT could be resolved.
929 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
930 if (IS_FLEX (z) && SUB (z) != NO_MOID) {
931 if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) {
932 MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
933 }
934 }
935 }
936 // See what new known modes we have generated by resolving..
937 for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) {
938 MOID_T *v;
939 for (v = NEXT (z); v != NO_MOID; FORWARD (v)) {
940 if (prove_moid_equivalence (z, v)) {
941 EQUIVALENT (z) = v;
942 EQUIVALENT (v) = NO_MOID;
943 }
944 }
945 }
946 // Count the modes to check self consistency.
947 len = nlen;
948 for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
949 nlen++;
950 }
951 }
952 ABEND (M_STRING != M_FLEX_ROW_CHAR, ERROR_INTERNAL_CONSISTENCY, __func__);
953 // Find out what modes contain rows.
954 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
955 HAS_ROWS (z) = is_mode_has_row (z);
956 }
957 // Check flexible modes.
958 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
959 if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) {
960 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
961 }
962 }
963 // Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is wrong.
964 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
965 if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
966 PACK_T *s = PACK (z);
967 for (; s != NO_PACK; FORWARD (s)) {
968 BOOL_T x = A68_TRUE;
969 for (PACK_T *t = NEXT (s); t != NO_PACK && x; FORWARD (t)) {
970 if (TEXT (s) == TEXT (t)) {
971 diagnostic (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD);
972 while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) {
973 FORWARD (s);
974 }
975 x = A68_FALSE;
976 }
977 }
978 }
979 }
980 }
981 // Various union test.
982 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
983 if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
984 PACK_T *s = PACK (z);
985 // Discard unions with one member.
986 if (count_pack_members (s) == 1) {
987 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, z);
988 }
989 // Discard incestuous unions with firmly related modes.
990 for (; s != NO_PACK; FORWARD (s)) {
991 PACK_T *t;
992 for (t = NEXT (s); t != NO_PACK; FORWARD (t)) {
993 if (MOID (t) != MOID (s)) {
994 if (is_firm (MOID (s), MOID (t))) {
995 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z);
996 }
997 }
998 }
999 }
1000 // Discard incestuous unions with firmly related subsets.
1001 for (s = PACK (z); s != NO_PACK; FORWARD (s)) {
1002 MOID_T *n = depref_completely (MOID (s));
1003 if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) {
1004 diagnostic (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n);
1005 }
1006 }
1007 }
1008 }
1009 // Wrap up and exit.
1010 free_postulate_list (A68 (top_postulate), NO_POSTULATE);
1011 A68 (top_postulate) = NO_POSTULATE;
1012 }
1013
1014 //! @brief Make list of all modes in the program.
1015
1016 void make_moid_list (MODULE_T * mod)
1017 {
1018 BOOL_T cont = A68_TRUE;
1019 // Collect modes from the syntax tree.
1020 reset_moid_tree (TOP_NODE (mod));
1021 get_modes_from_tree (TOP_NODE (mod), STOP);
1022 get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
1023 // Connect indicants to their declarers.
1024 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1025 if (IS (z, INDICANT)) {
1026 NODE_T *u = NODE (z);
1027 ABEND (NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1028 ABEND (NEXT_NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1029 ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1030 EQUIVALENT (z) = MOID (NEXT_NEXT (u));
1031 }
1032 }
1033 // Checks on wrong declarations.
1034 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1035 USE (z) = A68_FALSE;
1036 }
1037 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1038 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1039 if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) {
1040 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1041 cont = A68_FALSE;
1042 }
1043 }
1044 }
1045 for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z)) {
1046 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1047 ;
1048 } else if (NODE (z) != NO_NODE) {
1049 if (!is_well_formed (NO_MOID, z, A68_FALSE, A68_FALSE, A68_TRUE)) {
1050 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1051 }
1052 }
1053 }
1054 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1055 ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, __func__);
1056 }
1057 if (ERROR_COUNT (mod) != 0) {
1058 return;
1059 }
1060 compute_derived_modes (mod);
1061 init_postulates ();
1062 }
