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-2025 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 // Check whether a standard mode with length 'sizety' exists.
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 // If no standard mode exists, map onto nearest length.
282 if (sizety < 0) {
283 return search_standard_mode (sizety + 1, indicant);
284 } else if (sizety > 0) {
285 return search_standard_mode (sizety - 1, indicant);
286 } else {
287 return NO_MOID;
288 }
289 }
290
291 //! @brief Collect mode from STRUCT field.
292
293 void get_mode_from_struct_field (NODE_T * p, PACK_T ** u)
294 {
295 if (p != NO_NODE) {
296 if (IS (p, IDENTIFIER)) {
297 ATTRIBUTE (p) = FIELD_IDENTIFIER;
298 (void) add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p);
299 } else if (IS (p, DECLARER)) {
300 MOID_T *new_one = get_mode_from_declarer (p);
301 get_mode_from_struct_field (NEXT (p), u);
302 for (PACK_T *t = *u; t && MOID (t) == NO_MOID; FORWARD (t)) {
303 MOID (t) = new_one;
304 MOID (NODE (t)) = new_one;
305 }
306 } else {
307 get_mode_from_struct_field (NEXT (p), u);
308 get_mode_from_struct_field (SUB (p), u);
309 }
310 }
311 }
312
313 //! @brief Collect MODE from formal pack.
314
315 void get_mode_from_formal_pack (NODE_T * p, PACK_T ** u)
316 {
317 if (p != NO_NODE) {
318 if (IS (p, DECLARER)) {
319 get_mode_from_formal_pack (NEXT (p), u);
320 MOID_T *z = get_mode_from_declarer (p);
321 (void) add_mode_to_pack (u, z, NO_TEXT, p);
322 } else {
323 get_mode_from_formal_pack (NEXT (p), u);
324 get_mode_from_formal_pack (SUB (p), u);
325 }
326 }
327 }
328
329 //! @brief Collect MODE or VOID from formal UNION pack.
330
331 void get_mode_from_union_pack (NODE_T * p, PACK_T ** u)
332 {
333 if (p != NO_NODE) {
334 if (IS (p, DECLARER) || IS (p, VOID_SYMBOL)) {
335 get_mode_from_union_pack (NEXT (p), u);
336 MOID_T *z = get_mode_from_declarer (p);
337 (void) add_mode_to_pack (u, z, NO_TEXT, p);
338 } else {
339 get_mode_from_union_pack (NEXT (p), u);
340 get_mode_from_union_pack (SUB (p), u);
341 }
342 }
343 }
344
345 //! @brief Collect mode from PROC, OP pack.
346
347 void get_mode_from_routine_pack (NODE_T * p, PACK_T ** u)
348 {
349 if (p != NO_NODE) {
350 if (IS (p, IDENTIFIER)) {
351 (void) add_mode_to_pack (u, NO_MOID, NO_TEXT, p);
352 } else if (IS (p, DECLARER)) {
353 MOID_T *z = get_mode_from_declarer (p);
354 for (PACK_T *t = *u; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) {
355 MOID (t) = z;
356 MOID (NODE (t)) = z;
357 }
358 (void) add_mode_to_pack (u, z, NO_TEXT, p);
359 } else {
360 get_mode_from_routine_pack (NEXT (p), u);
361 get_mode_from_routine_pack (SUB (p), u);
362 }
363 }
364 }
365
366 //! @brief Collect MODE from DECLARER.
367
368 MOID_T *get_mode_from_declarer (NODE_T * p)
369 {
370 if (p == NO_NODE) {
371 return NO_MOID;
372 } else {
373 if (IS (p, DECLARER)) {
374 if (MOID (p) != NO_MOID) {
375 return MOID (p);
376 } else {
377 return MOID (p) = get_mode_from_declarer (SUB (p));
378 }
379 } else {
380 if (IS (p, VOID_SYMBOL)) {
381 MOID (p) = M_VOID;
382 return MOID (p);
383 } else if (IS (p, LONGETY)) {
384 if (whether (p, LONGETY, INDICANT, STOP)) {
385 int k = count_sizety (SUB (p));
386 MOID (p) = search_standard_mode (k, NEXT (p));
387 return MOID (p);
388 } else {
389 return NO_MOID;
390 }
391 } else if (IS (p, SHORTETY)) {
392 if (whether (p, SHORTETY, INDICANT, STOP)) {
393 int k = count_sizety (SUB (p));
394 MOID (p) = search_standard_mode (k, NEXT (p));
395 return MOID (p);
396 } else {
397 return NO_MOID;
398 }
399 } else if (IS (p, INDICANT)) {
400 MOID_T *q = search_standard_mode (0, p);
401 if (q != NO_MOID) {
402 MOID (p) = q;
403 } else {
404 // Position of definition tells indicants apart.
405 TAG_T *y = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
406 if (y == NO_TAG) {
407 diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p));
408 } else {
409 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y), NO_MOID, NO_PACK);
410 }
411 }
412 return MOID (p);
413 } else if (IS_REF (p)) {
414 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
415 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
416 return MOID (p);
417 } else if (IS_FLEX (p)) {
418 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
419 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK);
420 SLICE (MOID (p)) = SLICE (new_one);
421 return MOID (p);
422 } else if (IS (p, FORMAL_BOUNDS)) {
423 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
424 MOID (p) = add_row (&TOP_MOID (&A68_JOB), 1 + count_formal_bounds (SUB (p)), new_one, p, A68_FALSE);
425 return MOID (p);
426 } else if (IS (p, BOUNDS)) {
427 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
428 MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, A68_FALSE);
429 return MOID (p);
430 } else if (IS (p, STRUCT_SYMBOL)) {
431 PACK_T *u = NO_PACK;
432 get_mode_from_struct_field (NEXT (p), &u);
433 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, count_pack_members (u), p, NO_MOID, u);
434 return MOID (p);
435 } else if (IS (p, UNION_SYMBOL)) {
436 PACK_T *u = NO_PACK;
437 get_mode_from_union_pack (NEXT (p), &u);
438 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, count_pack_members (u), p, NO_MOID, u);
439 return MOID (p);
440 } else if (IS (p, PROC_SYMBOL)) {
441 NODE_T *save = p;
442 PACK_T *u = NO_PACK;
443 if (IS (NEXT (p), FORMAL_DECLARERS)) {
444 get_mode_from_formal_pack (SUB_NEXT (p), &u);
445 FORWARD (p);
446 }
447 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
448 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
449 MOID (save) = MOID (p);
450 return MOID (p);
451 } else {
452 return NO_MOID;
453 }
454 }
455 }
456 }
457
458 //! @brief Collect MODEs from a routine-text header.
459
460 MOID_T *get_mode_from_routine_text (NODE_T * p)
461 {
462 PACK_T *u = NO_PACK;
463 NODE_T *q = p;
464 if (IS (p, PARAMETER_PACK)) {
465 get_mode_from_routine_pack (SUB (p), &u);
466 FORWARD (p);
467 }
468 MOID_T *n = get_mode_from_declarer (p);
469 return add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), q, n, u);
470 }
471
472 //! @brief Collect modes from operator-plan.
473
474 MOID_T *get_mode_from_operator (NODE_T * p)
475 {
476 PACK_T *u = NO_PACK;
477 NODE_T *save = p;
478 if (IS (NEXT (p), FORMAL_DECLARERS)) {
479 get_mode_from_formal_pack (SUB_NEXT (p), &u);
480 FORWARD (p);
481 }
482 MOID_T *new_one = get_mode_from_declarer (NEXT (p));
483 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, count_pack_members (u), save, new_one, u);
484 return MOID (p);
485 }
486
487 //! @brief Collect mode from denotation.
488
489 void get_mode_from_denotation (NODE_T * p, int sizety)
490 {
491 if (p != NO_NODE) {
492 if (IS (p, ROW_CHAR_DENOTATION)) {
493 if (strlen (NSYMBOL (p)) == 1) {
494 MOID (p) = M_CHAR;
495 } else {
496 MOID (p) = M_ROW_CHAR;
497 }
498 } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) {
499 MOID (p) = M_BOOL;
500 } else if (IS (p, INT_DENOTATION)) {
501 if (sizety == 0) {
502 MOID (p) = M_INT;
503 } else if (sizety == 1) {
504 MOID (p) = M_LONG_INT;
505 } else if (sizety == 2) {
506 MOID (p) = M_LONG_LONG_INT;
507 } else {
508 MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT);
509 }
510 } else if (IS (p, REAL_DENOTATION)) {
511 if (sizety == 0) {
512 MOID (p) = M_REAL;
513 } else if (sizety == 1) {
514 MOID (p) = M_LONG_REAL;
515 } else if (sizety == 2) {
516 MOID (p) = M_LONG_LONG_REAL;
517 } else {
518 MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL);
519 }
520 } else if (IS (p, BITS_DENOTATION)) {
521 #if (A68_LEVEL <= 2)
522 if (sizety == 0) {
523 MOID (p) = M_BITS;
524 } else if (sizety == 1) {
525 MOID (p) = M_LONG_BITS;
526 } else if (sizety == 2) {
527 MOID (p) = M_LONG_LONG_BITS;
528 } else {
529 MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
530 }
531 #else
532 if (sizety == 0) {
533 MOID (p) = M_BITS;
534 } else if (sizety == 1) {
535 MOID (p) = M_LONG_BITS;
536 } else {
537 MOID (p) = (sizety > 0 ? M_LONG_BITS : M_BITS);
538 }
539 #endif
540 } else if (IS (p, LONGETY) || IS (p, SHORTETY)) {
541 get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
542 MOID (p) = MOID (NEXT (p));
543 } else if (IS (p, EMPTY_SYMBOL)) {
544 MOID (p) = M_VOID;
545 }
546 }
547 }
548
549 //! @brief Collect modes from the syntax tree.
550
551 void get_modes_from_tree (NODE_T * p, int attribute)
552 {
553 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
554 if (IS (q, VOID_SYMBOL)) {
555 MOID (q) = M_VOID;
556 } else if (IS (q, DECLARER)) {
557 if (attribute == VARIABLE_DECLARATION) {
558 MOID_T *new_one = get_mode_from_declarer (q);
559 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
560 } else {
561 MOID (q) = get_mode_from_declarer (q);
562 }
563 } else if (IS (q, ROUTINE_TEXT)) {
564 MOID (q) = get_mode_from_routine_text (SUB (q));
565 } else if (IS (q, OPERATOR_PLAN)) {
566 MOID (q) = get_mode_from_operator (SUB (q));
567 } else if (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
568 if (attribute == GENERATOR) {
569 MOID_T *new_one = get_mode_from_declarer (NEXT (q));
570 MOID (NEXT (q)) = new_one;
571 MOID (q) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
572 }
573 } else {
574 if (attribute == DENOTATION) {
575 get_mode_from_denotation (q, 0);
576 }
577 }
578 }
579 if (attribute != DENOTATION) {
580 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
581 if (SUB (q) != NO_NODE) {
582 get_modes_from_tree (SUB (q), ATTRIBUTE (q));
583 }
584 }
585 }
586 }
587
588 //! @brief Collect modes from proc variables.
589
590 void get_mode_from_proc_variables (NODE_T * p)
591 {
592 if (p != NO_NODE) {
593 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
594 get_mode_from_proc_variables (SUB (p));
595 get_mode_from_proc_variables (NEXT (p));
596 } else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) {
597 get_mode_from_proc_variables (NEXT (p));
598 } else if (IS (p, DEFINING_IDENTIFIER)) {
599 MOID_T *new_one = MOID (NEXT_NEXT (p));
600 MOID (p) = add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
601 }
602 }
603 }
604
605 //! @brief Collect modes from proc variable declarations.
606
607 void get_mode_from_proc_var_declarations_tree (NODE_T * p)
608 {
609 for (; p != NO_NODE; FORWARD (p)) {
610 get_mode_from_proc_var_declarations_tree (SUB (p));
611 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
612 get_mode_from_proc_variables (p);
613 }
614 }
615 }
616
617 // Various routines to test modes.
618
619 //! @brief Whether a mode declaration refers to self or relates to void.
620
621 BOOL_T is_well_formed (MOID_T * def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video)
622 {
623 if (z == NO_MOID) {
624 return A68_FALSE;
625 } else if (yin && yang) {
626 return z == M_VOID ? video : A68_TRUE;
627 } else if (z == M_VOID) {
628 return video;
629 } else if (IS (z, STANDARD)) {
630 return A68_TRUE;
631 } else if (IS (z, INDICANT)) {
632 if (def == NO_MOID) {
633 // Check an applied indicant for relation to VOID.
634 while (z != NO_MOID) {
635 z = EQUIVALENT (z);
636 }
637 if (z == M_VOID) {
638 return video;
639 } else {
640 return A68_TRUE;
641 }
642 } else {
643 if (z == def || USE (z)) {
644 return yin && yang;
645 } else {
646 USE (z) = A68_TRUE;
647 BOOL_T wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
648 USE (z) = A68_FALSE;
649 return wwf;
650 }
651 }
652 } else if (IS_REF (z)) {
653 return is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE);
654 } else if (IS (z, PROC_SYMBOL)) {
655 return PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE);
656 } else if (IS_ROW (z)) {
657 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
658 } else if (IS_FLEX (z)) {
659 return is_well_formed (def, SUB (z), yin, yang, A68_FALSE);
660 } else if (IS (z, STRUCT_SYMBOL)) {
661 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
662 if (!is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) {
663 return A68_FALSE;
664 }
665 }
666 return A68_TRUE;
667 } else if (IS (z, UNION_SYMBOL)) {
668 for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) {
669 if (!is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) {
670 return A68_FALSE;
671 }
672 }
673 return A68_TRUE;
674 } else {
675 return A68_FALSE;
676 }
677 }
678
679 //! @brief Replace a mode by its equivalent mode (walk chain).
680
681 void resolve_eq_members (MOID_T * q)
682 {
683 resolve_equivalent (&SUB (q));
684 resolve_equivalent (&DEFLEXED (q));
685 resolve_equivalent (&MULTIPLE (q));
686 resolve_equivalent (&NAME (q));
687 resolve_equivalent (&SLICE (q));
688 resolve_equivalent (&TRIM (q));
689 resolve_equivalent (&ROWED (q));
690 for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p)) {
691 resolve_equivalent (&MOID (p));
692 }
693 }
694
695 //! @brief Track equivalent tags.
696
697 void resolve_eq_tags (TAG_T * z)
698 {
699 for (; z != NO_TAG; FORWARD (z)) {
700 if (MOID (z) != NO_MOID) {
701 resolve_equivalent (&MOID (z));
702 }
703 }
704 }
705
706 //! @brief Bind modes in syntax tree.
707
708 void bind_modes (NODE_T * p)
709 {
710 for (; p != NO_NODE; FORWARD (p)) {
711 resolve_equivalent (&MOID (p));
712 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
713 TABLE_T *s = TABLE (SUB (p));
714 for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z)) {
715 if (NODE (z) != NO_NODE) {
716 resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
717 MOID (z) = MOID (NEXT_NEXT (NODE (z)));
718 MOID (NODE (z)) = MOID (z);
719 }
720 }
721 }
722 bind_modes (SUB (p));
723 }
724 }
725
726 // Routines for calculating subordinates for selections, for instance selection
727 // from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) yields
728 // [] A fields.
729
730 //! @brief Make name pack.
731
732 void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p)
733 {
734 if (src != NO_PACK) {
735 make_name_pack (NEXT (src), dst, p);
736 MOID_T *z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
737 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
738 }
739 }
740
741 //! @brief Make flex multiple row pack.
742
743 void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
744 {
745 if (src != NO_PACK) {
746 make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
747 MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE);
748 z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
749 (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src));
750 }
751 }
752
753 //! @brief Make name struct.
754
755 MOID_T *make_name_struct (MOID_T * m, MOID_T ** p)
756 {
757 PACK_T *u = NO_PACK;
758 make_name_pack (PACK (m), &u, p);
759 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
760 }
761
762 //! @brief Make name row.
763
764 MOID_T *make_name_row (MOID_T * m, MOID_T ** p)
765 {
766 if (SLICE (m) != NO_MOID) {
767 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
768 } else if (SUB (m) != NO_MOID) {
769 return add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
770 } else {
771 return NO_MOID; // weird, FLEX INT or so ...
772 }
773 }
774
775 //! @brief Make multiple row pack.
776
777 void make_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim)
778 {
779 if (src != NO_PACK) {
780 make_multiple_row_pack (NEXT (src), dst, p, dim);
781 (void) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src));
782 }
783 }
784
785 //! @brief Make flex multiple struct.
786
787 MOID_T *make_flex_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
788 {
789 PACK_T *u = NO_PACK;
790 make_flex_multiple_row_pack (PACK (m), &u, p, dim);
791 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
792 }
793
794 //! @brief Make multiple struct.
795
796 MOID_T *make_multiple_struct (MOID_T * m, MOID_T ** p, int dim)
797 {
798 PACK_T *u = NO_PACK;
799 make_multiple_row_pack (PACK (m), &u, p, dim);
800 return add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
801 }
802
803 //! @brief Whether mode has row.
804
805 BOOL_T is_mode_has_row (MOID_T * m)
806 {
807 if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) {
808 BOOL_T k = A68_FALSE;
809 for (PACK_T *p = PACK (m); p != NO_PACK && k == A68_FALSE; FORWARD (p)) {
810 HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
811 k |= (HAS_ROWS (MOID (p)));
812 }
813 return k;
814 } else {
815 return (BOOL_T) (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
816 }
817 }
818
819 //! @brief Compute derived modes.
820
821 void compute_derived_modes (MODULE_T * mod)
822 {
823 MOID_T *z;
824 int len = 0, nlen = 1;
825 // UNION things.
826 absorb_unions (TOP_MOID (mod));
827 contract_unions (TOP_MOID (mod));
828 // The for-statement below prevents an endless loop.
829 for (int k = 1; k <= 10 && len != nlen; k++) {
830 // Make deflexed modes.
831 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
832 if (SUB (z) != NO_MOID) {
833 if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) {
834 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK);
835 } else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID) {
836 DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK);
837 } else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID) {
838 DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK);
839 } else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) {
840 DEFLEXED (z) = DEFLEXED (SUB (z));
841 } else if (IS_FLEX (z)) {
842 DEFLEXED (z) = SUB (z);
843 } else {
844 DEFLEXED (z) = z;
845 }
846 }
847 }
848 // Derived modes for stowed modes.
849 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
850 if (NAME (z) == NO_MOID && IS_REF (z)) {
851 if (IS (SUB (z), STRUCT_SYMBOL)) {
852 NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
853 } else if (IS_ROW (SUB (z))) {
854 NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
855 } else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) {
856 NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
857 }
858 }
859 if (MULTIPLE (z) != NO_MOID) {
860 ;
861 } else if (IS_REF (z)) {
862 if (MULTIPLE (SUB (z)) != NO_MOID) {
863 MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
864 }
865 } else if (IS_ROW (z)) {
866 if (IS (SUB (z), STRUCT_SYMBOL)) {
867 MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
868 }
869 }
870 }
871 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
872 if (TRIM (z) == NO_MOID && IS_FLEX (z)) {
873 TRIM (z) = SUB (z);
874 }
875 if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) {
876 TRIM (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
877 }
878 }
879 // Fill out stuff for rows, f.i. inverse relations.
880 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
881 if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) {
882 (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE);
883 } else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) {
884 MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), A68_TRUE);
885 MOID_T *y = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
886 NAME (y) = z;
887 }
888 }
889 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
890 if (IS_ROW (z) && SLICE (z) != NO_MOID) {
891 ROWED (SLICE (z)) = z;
892 }
893 if (IS_REF (z)) {
894 MOID_T *y = SUB (z);
895 if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) {
896 ROWED (NAME (z)) = z;
897 }
898 }
899 }
900 bind_modes (TOP_NODE (mod));
901 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
902 if (IS (z, INDICANT) && NODE (z) != NO_NODE) {
903 EQUIVALENT (z) = MOID (NODE (z));
904 }
905 }
906 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
907 resolve_eq_members (z);
908 }
909 resolve_eq_tags (INDICANTS (A68_STANDENV));
910 resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
911 resolve_eq_tags (OPERATORS (A68_STANDENV));
912 resolve_equivalent (&M_STRING);
913 resolve_equivalent (&M_COMPLEX);
914 resolve_equivalent (&M_COMPL);
915 resolve_equivalent (&M_LONG_COMPLEX);
916 resolve_equivalent (&M_LONG_COMPL);
917 resolve_equivalent (&M_LONG_LONG_COMPLEX);
918 resolve_equivalent (&M_LONG_LONG_COMPL);
919 resolve_equivalent (&M_SEMA);
920 resolve_equivalent (&M_PIPE);
921 // UNION members could be resolved.
922 absorb_unions (TOP_MOID (mod));
923 contract_unions (TOP_MOID (mod));
924 // FLEX INDICANT could be resolved.
925 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
926 if (IS_FLEX (z) && SUB (z) != NO_MOID) {
927 if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) {
928 MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
929 }
930 }
931 }
932 // See what new known modes we have generated by resolving..
933 for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) {
934 MOID_T *v;
935 for (v = NEXT (z); v != NO_MOID; FORWARD (v)) {
936 if (prove_moid_equivalence (z, v)) {
937 EQUIVALENT (z) = v;
938 EQUIVALENT (v) = NO_MOID;
939 }
940 }
941 }
942 // Count the modes to check self consistency.
943 len = nlen;
944 for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
945 nlen++;
946 }
947 }
948 ABEND (M_STRING != M_FLEX_ROW_CHAR, ERROR_INTERNAL_CONSISTENCY, __func__);
949 // Find out what modes contain rows.
950 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
951 HAS_ROWS (z) = is_mode_has_row (z);
952 }
953 // Check flexible modes.
954 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
955 if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) {
956 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
957 }
958 }
959 // Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is wrong.
960 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
961 if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
962 PACK_T *s = PACK (z);
963 for (; s != NO_PACK; FORWARD (s)) {
964 BOOL_T x = A68_TRUE;
965 for (PACK_T *t = NEXT (s); t != NO_PACK && x; FORWARD (t)) {
966 if (TEXT (s) == TEXT (t)) {
967 diagnostic (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD);
968 while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) {
969 FORWARD (s);
970 }
971 x = A68_FALSE;
972 }
973 }
974 }
975 }
976 }
977 // Various union test.
978 for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
979 if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) {
980 PACK_T *s = PACK (z);
981 // Discard unions with one member.
982 if (count_pack_members (s) == 1) {
983 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, z);
984 }
985 // Discard incestuous unions with firmly related modes.
986 for (; s != NO_PACK; FORWARD (s)) {
987 PACK_T *t;
988 for (t = NEXT (s); t != NO_PACK; FORWARD (t)) {
989 if (MOID (t) != MOID (s)) {
990 if (is_firm (MOID (s), MOID (t))) {
991 diagnostic (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z);
992 }
993 }
994 }
995 }
996 // Discard incestuous unions with firmly related subsets.
997 for (s = PACK (z); s != NO_PACK; FORWARD (s)) {
998 MOID_T *n = depref_completely (MOID (s));
999 if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) {
1000 diagnostic (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n);
1001 }
1002 }
1003 }
1004 }
1005 // Wrap up and exit.
1006 free_postulate_list (A68 (top_postulate), NO_POSTULATE);
1007 A68 (top_postulate) = NO_POSTULATE;
1008 }
1009
1010 //! @brief Make list of all modes in the program.
1011
1012 void make_moid_list (MODULE_T * mod)
1013 {
1014 BOOL_T cont = A68_TRUE;
1015 // Collect modes from the syntax tree.
1016 reset_moid_tree (TOP_NODE (mod));
1017 get_modes_from_tree (TOP_NODE (mod), STOP);
1018 get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
1019 // Connect indicants to their declarers.
1020 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1021 if (IS (z, INDICANT)) {
1022 NODE_T *u = NODE (z);
1023 ABEND (NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1024 ABEND (NEXT_NEXT (u) == NO_NODE, ERROR_INTERNAL_CONSISTENCY, __func__);
1025 ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, __func__);
1026 EQUIVALENT (z) = MOID (NEXT_NEXT (u));
1027 }
1028 }
1029 // Checks on wrong declarations.
1030 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1031 USE (z) = A68_FALSE;
1032 }
1033 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1034 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1035 if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) {
1036 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1037 cont = A68_FALSE;
1038 }
1039 }
1040 }
1041 for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z)) {
1042 if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) {
1043 ;
1044 } else if (NODE (z) != NO_NODE) {
1045 if (!is_well_formed (NO_MOID, z, A68_FALSE, A68_FALSE, A68_TRUE)) {
1046 diagnostic (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z);
1047 }
1048 }
1049 }
1050 for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) {
1051 ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, __func__);
1052 }
1053 if (ERROR_COUNT (mod) != 0) {
1054 return;
1055 }
1056 compute_derived_modes (mod);
1057 init_postulates ();
1058 }
|
© 2002-2025 J.M. van der Veer (jmvdveer@xs4all.nl)
|
