parser-taxes.c
1 //! @file parser-taxes.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 //! Symbol table management.
25
26 #include "a68g.h"
27 #include "a68g-parser.h"
28
29 // Symbol table handling, managing TAGS.
30
31 //! @brief Set level for procedures.
32
33 void set_proc_level (NODE_T * p, int n)
34 {
35 for (; p != NO_NODE; FORWARD (p)) {
36 PROCEDURE_LEVEL (INFO (p)) = n;
37 if (IS (p, ROUTINE_TEXT)) {
38 set_proc_level (SUB (p), n + 1);
39 } else {
40 set_proc_level (SUB (p), n);
41 }
42 }
43 }
44
45 //! @brief Set nests for diagnostics.
46
47 void set_nest (NODE_T * p, NODE_T * s)
48 {
49 for (; p != NO_NODE; FORWARD (p)) {
50 NEST (p) = s;
51 if (IS (p, PARTICULAR_PROGRAM)) {
52 set_nest (SUB (p), p);
53 } else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0) {
54 set_nest (SUB (p), p);
55 } else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0) {
56 set_nest (SUB (p), p);
57 } else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0) {
58 set_nest (SUB (p), p);
59 } else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0) {
60 set_nest (SUB (p), p);
61 } else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0) {
62 set_nest (SUB (p), p);
63 } else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0) {
64 set_nest (SUB (p), p);
65 } else {
66 set_nest (SUB (p), s);
67 }
68 }
69 }
70
71 // Routines that work with tags and symbol tables.
72
73 void tax_tags (NODE_T *);
74 void tax_specifier_list (NODE_T *);
75 void tax_parameter_list (NODE_T *);
76 void tax_format_texts (NODE_T *);
77
78 //! @brief Find a tag, searching symbol tables towards the root.
79
80 int first_tag_global (TABLE_T * table, char *name)
81 {
82 if (table != NO_TABLE) {
83 for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) {
84 if (NSYMBOL (NODE (s)) == name) {
85 return IDENTIFIER;
86 }
87 }
88 for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s)) {
89 if (NSYMBOL (NODE (s)) == name) {
90 return INDICANT;
91 }
92 }
93 for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s)) {
94 if (NSYMBOL (NODE (s)) == name) {
95 return LABEL;
96 }
97 }
98 for (TAG_T *s = OPERATORS (table); s != NO_TAG; FORWARD (s)) {
99 if (NSYMBOL (NODE (s)) == name) {
100 return OP_SYMBOL;
101 }
102 }
103 for (TAG_T *s = PRIO (table); s != NO_TAG; FORWARD (s)) {
104 if (NSYMBOL (NODE (s)) == name) {
105 return PRIO_SYMBOL;
106 }
107 }
108 return first_tag_global (PREVIOUS (table), name);
109 } else {
110 return STOP;
111 }
112 }
113
114 #define PORTCHECK_TAX(p, q) {\
115 if (q == A68_FALSE) {\
116 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);\
117 }}
118
119 //! @brief Check portability of sub tree.
120
121 void portcheck (NODE_T * p)
122 {
123 for (; p != NO_NODE; FORWARD (p)) {
124 portcheck (SUB (p));
125 if (OPTION_PORTCHECK (&A68_JOB)) {
126 if (IS (p, INDICANT) && MOID (p) != NO_MOID) {
127 PORTCHECK_TAX (p, PORTABLE (MOID (p)));
128 PORTABLE (MOID (p)) = A68_TRUE;
129 } else if (IS (p, IDENTIFIER)) {
130 PORTCHECK_TAX (p, PORTABLE (TAX (p)));
131 PORTABLE (TAX (p)) = A68_TRUE;
132 } else if (IS (p, OPERATOR)) {
133 PORTCHECK_TAX (p, PORTABLE (TAX (p)));
134 PORTABLE (TAX (p)) = A68_TRUE;
135 } else if (IS (p, ASSERTION)) {
136 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);
137 }
138 }
139 }
140 }
141
142 //! @brief Whether routine can be "lengthety-mapped".
143
144 BOOL_T is_mappable_routine (char *z)
145 {
146 #define ACCEPT(u, v) {\
147 if (strlen (u) >= strlen (v)) {\
148 if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\
149 return A68_TRUE;\
150 }}}
151 // Math routines.
152 ACCEPT (z, "arccos");
153 ACCEPT (z, "arccosdg");
154 ACCEPT (z, "arccot");
155 ACCEPT (z, "arccotdg");
156 ACCEPT (z, "arcsin");
157 ACCEPT (z, "arcsindg");
158 ACCEPT (z, "arctan");
159 ACCEPT (z, "arctandg");
160 ACCEPT (z, "beta");
161 ACCEPT (z, "betainc");
162 ACCEPT (z, "cbrt");
163 ACCEPT (z, "cos");
164 ACCEPT (z, "cosdg");
165 ACCEPT (z, "cospi");
166 ACCEPT (z, "cot");
167 ACCEPT (z, "cot");
168 ACCEPT (z, "cotdg");
169 ACCEPT (z, "cotpi");
170 ACCEPT (z, "curt");
171 ACCEPT (z, "erf");
172 ACCEPT (z, "erfc");
173 ACCEPT (z, "exp");
174 ACCEPT (z, "gamma");
175 ACCEPT (z, "gammainc");
176 ACCEPT (z, "gammaincg");
177 ACCEPT (z, "gammaincgf");
178 ACCEPT (z, "ln");
179 ACCEPT (z, "log");
180 ACCEPT (z, "pi");
181 ACCEPT (z, "sin");
182 ACCEPT (z, "sindg");
183 ACCEPT (z, "sinpi");
184 ACCEPT (z, "sqrt");
185 ACCEPT (z, "tan");
186 ACCEPT (z, "tandg");
187 ACCEPT (z, "tanpi");
188 // Random generator.
189 ACCEPT (z, "nextrandom");
190 ACCEPT (z, "random");
191 // BITS.
192 ACCEPT (z, "bitspack");
193 // Enquiries.
194 ACCEPT (z, "maxint");
195 ACCEPT (z, "intwidth");
196 ACCEPT (z, "maxreal");
197 ACCEPT (z, "realwidth");
198 ACCEPT (z, "expwidth");
199 ACCEPT (z, "maxbits");
200 ACCEPT (z, "bitswidth");
201 ACCEPT (z, "byteswidth");
202 ACCEPT (z, "smallreal");
203 return A68_FALSE;
204 #undef ACCEPT
205 }
206
207 //! @brief Map "short sqrt" onto "sqrt" etcetera.
208
209 TAG_T *bind_lengthety_identifier (char *u)
210 {
211 #define CAR(u, v) (strncmp (u, v, strlen(v)) == 0)
212 // We can only map routines blessed by "is_mappable_routine", so there is no
213 // "short print" or "long char in string".
214 if (CAR (u, "short")) {
215 do {
216 u = &u[strlen ("short")];
217 char *v = TEXT (add_token (&A68 (top_token), u));
218 TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
219 if (w != NO_TAG && is_mappable_routine (v)) {
220 return w;
221 }
222 } while (CAR (u, "short"));
223 } else if (CAR (u, "long")) {
224 do {
225 u = &u[strlen ("long")];
226 char *v = TEXT (add_token (&A68 (top_token), u));
227 TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
228 if (w != NO_TAG && is_mappable_routine (v)) {
229 return w;
230 }
231 } while (CAR (u, "long"));
232 }
233 return NO_TAG;
234 #undef CAR
235 }
236
237 //! @brief Bind identifier tags to the symbol table.
238
239 void bind_identifier_tag_to_symbol_table (NODE_T * p)
240 {
241 for (; p != NO_NODE; FORWARD (p)) {
242 bind_identifier_tag_to_symbol_table (SUB (p));
243 if (is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP)) {
244 int att = first_tag_global (TABLE (p), NSYMBOL (p));
245 if (att == STOP) {
246 TAG_T *z = bind_lengthety_identifier (NSYMBOL (p));
247 if (z != NO_TAG) {
248 MOID (p) = MOID (z);
249 }
250 TAX (p) = z;
251 } else {
252 TAG_T *z = find_tag_global (TABLE (p), att, NSYMBOL (p));
253 if (att == IDENTIFIER && z != NO_TAG) {
254 MOID (p) = MOID (z);
255 } else if (att == LABEL && z != NO_TAG) {
256 ;
257 } else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) {
258 MOID (p) = MOID (z);
259 } else {
260 diagnostic (A68_ERROR, p, ERROR_UNDECLARED_TAG);
261 z = add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
262 MOID (p) = M_ERROR;
263 }
264 TAX (p) = z;
265 if (IS (p, DEFINING_IDENTIFIER)) {
266 NODE (z) = p;
267 }
268 }
269 }
270 }
271 }
272
273 //! @brief Bind indicant tags to the symbol table.
274
275 void bind_indicant_tag_to_symbol_table (NODE_T * p)
276 {
277 for (; p != NO_NODE; FORWARD (p)) {
278 bind_indicant_tag_to_symbol_table (SUB (p));
279 if (is_one_of (p, INDICANT, DEFINING_INDICANT, STOP)) {
280 TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
281 if (z != NO_TAG) {
282 MOID (p) = MOID (z);
283 TAX (p) = z;
284 if (IS (p, DEFINING_INDICANT)) {
285 NODE (z) = p;
286 }
287 }
288 }
289 }
290 }
291
292 //! @brief Enter specifier identifiers in the symbol table.
293
294 void tax_specifiers (NODE_T * p)
295 {
296 for (; p != NO_NODE; FORWARD (p)) {
297 tax_specifiers (SUB (p));
298 if (SUB (p) != NO_NODE && IS (p, SPECIFIER)) {
299 tax_specifier_list (SUB (p));
300 }
301 }
302 }
303
304 //! @brief Enter specifier identifiers in the symbol table.
305
306 void tax_specifier_list (NODE_T * p)
307 {
308 if (p != NO_NODE) {
309 if (IS (p, OPEN_SYMBOL)) {
310 tax_specifier_list (NEXT (p));
311 } else if (is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP)) {
312 ;
313 } else if (IS (p, IDENTIFIER)) {
314 TAG_T *z = add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER);
315 HEAP (z) = LOC_SYMBOL;
316 } else if (IS (p, DECLARER)) {
317 tax_specifiers (SUB (p));
318 tax_specifier_list (NEXT (p));
319 // last identifier entry is identifier with this declarer.
320 if (IDENTIFIERS (TABLE (p)) != NO_TAG && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER)
321 MOID (IDENTIFIERS (TABLE (p))) = MOID (p);
322 }
323 }
324 }
325
326 //! @brief Enter parameter identifiers in the symbol table.
327
328 void tax_parameters (NODE_T * p)
329 {
330 for (; p != NO_NODE; FORWARD (p)) {
331 if (SUB (p) != NO_NODE) {
332 tax_parameters (SUB (p));
333 if (IS (p, PARAMETER_PACK)) {
334 tax_parameter_list (SUB (p));
335 }
336 }
337 }
338 }
339
340 //! @brief Enter parameter identifiers in the symbol table.
341
342 void tax_parameter_list (NODE_T * p)
343 {
344 if (p != NO_NODE) {
345 if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) {
346 tax_parameter_list (NEXT (p));
347 } else if (IS (p, CLOSE_SYMBOL)) {
348 ;
349 } else if (is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) {
350 tax_parameter_list (NEXT (p));
351 tax_parameter_list (SUB (p));
352 } else if (IS (p, IDENTIFIER)) {
353 // parameters are always local.
354 HEAP (add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL;
355 } else if (IS (p, DECLARER)) {
356 tax_parameter_list (NEXT (p));
357 // last identifier entries are identifiers with this declarer.
358 for (TAG_T *s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s)) {
359 MOID (s) = MOID (p);
360 }
361 tax_parameters (SUB (p));
362 }
363 }
364 }
365
366 //! @brief Enter FOR identifiers in the symbol table.
367
368 void tax_for_identifiers (NODE_T * p)
369 {
370 for (; p != NO_NODE; FORWARD (p)) {
371 tax_for_identifiers (SUB (p));
372 if (IS (p, FOR_SYMBOL)) {
373 if ((FORWARD (p)) != NO_NODE) {
374 (void) add_tag (TABLE (p), IDENTIFIER, p, M_INT, LOOP_IDENTIFIER);
375 }
376 }
377 }
378 }
379
380 //! @brief Enter routine texts in the symbol table.
381
382 void tax_routine_texts (NODE_T * p)
383 {
384 for (; p != NO_NODE; FORWARD (p)) {
385 tax_routine_texts (SUB (p));
386 if (IS (p, ROUTINE_TEXT)) {
387 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT);
388 TAX (p) = z;
389 HEAP (z) = LOC_SYMBOL;
390 USE (z) = A68_TRUE;
391 }
392 }
393 }
394
395 //! @brief Enter format texts in the symbol table.
396
397 void tax_format_texts (NODE_T * p)
398 {
399 for (; p != NO_NODE; FORWARD (p)) {
400 tax_format_texts (SUB (p));
401 if (IS (p, FORMAT_TEXT)) {
402 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_TEXT);
403 TAX (p) = z;
404 USE (z) = A68_TRUE;
405 } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE) {
406 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_IDENTIFIER);
407 TAX (p) = z;
408 USE (z) = A68_TRUE;
409 }
410 }
411 }
412
413 //! @brief Enter FORMAT pictures in the symbol table.
414
415 void tax_pictures (NODE_T * p)
416 {
417 for (; p != NO_NODE; FORWARD (p)) {
418 tax_pictures (SUB (p));
419 if (IS (p, PICTURE)) {
420 TAX (p) = add_tag (TABLE (p), ANONYMOUS, p, M_COLLITEM, FORMAT_IDENTIFIER);
421 }
422 }
423 }
424
425 //! @brief Enter generators in the symbol table.
426
427 void tax_generators (NODE_T * p)
428 {
429 for (; p != NO_NODE; FORWARD (p)) {
430 tax_generators (SUB (p));
431 if (IS (p, GENERATOR)) {
432 if (IS (SUB (p), LOC_SYMBOL)) {
433 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR);
434 HEAP (z) = LOC_SYMBOL;
435 USE (z) = A68_TRUE;
436 TAX (p) = z;
437 }
438 }
439 }
440 }
441
442 //! @brief Find a firmly related operator for operands.
443
444 TAG_T *find_firmly_related_op (TABLE_T * c, const char *n, MOID_T * l, MOID_T * r, const TAG_T * self)
445 {
446 if (c != NO_TABLE) {
447 TAG_T *s = OPERATORS (c);
448 for (; s != NO_TAG; FORWARD (s)) {
449 if (s != self && NSYMBOL (NODE (s)) == n) {
450 PACK_T *t = PACK (MOID (s));
451 if (t != NO_PACK && is_firm (MOID (t), l)) {
452 // catch monadic operator.
453 if ((FORWARD (t)) == NO_PACK) {
454 if (r == NO_MOID) {
455 return s;
456 }
457 } else {
458 // catch dyadic operator.
459 if (r != NO_MOID && is_firm (MOID (t), r)) {
460 return s;
461 }
462 }
463 }
464 }
465 }
466 }
467 return NO_TAG;
468 }
469
470 //! @brief Check for firmly related operators in this range.
471
472 void test_firmly_related_ops_local (NODE_T * p, TAG_T * s)
473 {
474 if (s != NO_TAG) {
475 PACK_T *u = PACK (MOID (s));
476 if (u != NO_PACK) {
477 MOID_T *l = MOID (u);
478 MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID);
479 TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s);
480 if (t != NO_TAG) {
481 if (TAG_TABLE (t) == A68_STANDENV) {
482 diagnostic (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t)));
483 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
484 } else {
485 diagnostic (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t)));
486 }
487 }
488 }
489 if (NEXT (s) != NO_TAG) {
490 test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s));
491 }
492 }
493 }
494
495 //! @brief Find firmly related operators in this program.
496
497 void test_firmly_related_ops (NODE_T * p)
498 {
499 for (; p != NO_NODE; FORWARD (p)) {
500 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
501 TAG_T *oops = OPERATORS (TABLE (SUB (p)));
502 if (oops != NO_TAG) {
503 test_firmly_related_ops_local (NODE (oops), oops);
504 }
505 }
506 test_firmly_related_ops (SUB (p));
507 }
508 }
509
510 //! @brief Driver for the processing of TAXes.
511
512 void collect_taxes (NODE_T * p)
513 {
514 tax_tags (p);
515 tax_specifiers (p);
516 tax_parameters (p);
517 tax_for_identifiers (p);
518 tax_routine_texts (p);
519 tax_pictures (p);
520 tax_format_texts (p);
521 tax_generators (p);
522 bind_identifier_tag_to_symbol_table (p);
523 bind_indicant_tag_to_symbol_table (p);
524 test_firmly_related_ops (p);
525 test_firmly_related_ops_local (NO_NODE, OPERATORS (A68_STANDENV));
526 }
527
528 //! @brief Whether tag has already been declared in this range.
529
530 void already_declared (NODE_T * n, int a)
531 {
532 if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) {
533 diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG);
534 }
535 }
536
537 //! @brief Whether tag has already been declared in this range.
538
539 void already_declared_hidden (NODE_T * n, int a)
540 {
541 if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) {
542 diagnostic (A68_ERROR, n, ERROR_MULTIPLE_TAG);
543 }
544 TAG_T *s = find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n));
545 if (s != NO_TAG) {
546 if (TAG_TABLE (s) == A68_STANDENV) {
547 diagnostic (A68_WARNING, n, WARNING_HIDES_PRELUDE, MOID (s), NSYMBOL (n));
548 } else {
549 diagnostic (A68_WARNING, n, WARNING_HIDES, NSYMBOL (n));
550 }
551 }
552 }
553
554 //! @brief Add tag to local symbol table.
555
556 TAG_T *add_tag (TABLE_T * s, int a, NODE_T * n, MOID_T * m, int p)
557 {
558 #define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);}
559 if (s != NO_TABLE) {
560 TAG_T *z = new_tag ();
561 TAG_TABLE (z) = s;
562 PRIO (z) = p;
563 MOID (z) = m;
564 NODE (z) = n;
565 // TAX (n) = z;.
566 switch (a) {
567 case IDENTIFIER: {
568 already_declared_hidden (n, IDENTIFIER);
569 already_declared_hidden (n, LABEL);
570 INSERT_TAG (&IDENTIFIERS (s), z);
571 break;
572 }
573 case INDICANT: {
574 already_declared_hidden (n, INDICANT);
575 already_declared (n, OP_SYMBOL);
576 already_declared (n, PRIO_SYMBOL);
577 INSERT_TAG (&INDICANTS (s), z);
578 break;
579 }
580 case LABEL: {
581 already_declared_hidden (n, LABEL);
582 already_declared_hidden (n, IDENTIFIER);
583 INSERT_TAG (&LABELS (s), z);
584 break;
585 }
586 case OP_SYMBOL: {
587 already_declared (n, INDICANT);
588 INSERT_TAG (&OPERATORS (s), z);
589 break;
590 }
591 case PRIO_SYMBOL: {
592 already_declared (n, PRIO_SYMBOL);
593 already_declared (n, INDICANT);
594 INSERT_TAG (&PRIO (s), z);
595 break;
596 }
597 case ANONYMOUS: {
598 INSERT_TAG (&ANONYMOUS (s), z);
599 break;
600 }
601 default: {
602 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
603 }
604 }
605 return z;
606 } else {
607 return NO_TAG;
608 }
609 }
610
611 //! @brief Find a tag, searching symbol tables towards the root.
612
613 TAG_T *find_tag_global (TABLE_T * table, int a, char *name)
614 {
615 if (table != NO_TABLE) {
616 TAG_T *s = NO_TAG;
617 switch (a) {
618 case IDENTIFIER: {
619 s = IDENTIFIERS (table);
620 break;
621 }
622 case INDICANT: {
623 s = INDICANTS (table);
624 break;
625 }
626 case LABEL: {
627 s = LABELS (table);
628 break;
629 }
630 case OP_SYMBOL: {
631 s = OPERATORS (table);
632 break;
633 }
634 case PRIO_SYMBOL: {
635 s = PRIO (table);
636 break;
637 }
638 default: {
639 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
640 break;
641 }
642 }
643 for (; s != NO_TAG; FORWARD (s)) {
644 if (NSYMBOL (NODE (s)) == name) {
645 return s;
646 }
647 }
648 return find_tag_global (PREVIOUS (table), a, name);
649 } else {
650 return NO_TAG;
651 }
652 }
653
654 //! @brief Whether identifier or label global.
655
656 int is_identifier_or_label_global (TABLE_T * table, char *name)
657 {
658 if (table != NO_TABLE) {
659 for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) {
660 if (NSYMBOL (NODE (s)) == name) {
661 return IDENTIFIER;
662 }
663 }
664 for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s)) {
665 if (NSYMBOL (NODE (s)) == name) {
666 return LABEL;
667 }
668 }
669 return is_identifier_or_label_global (PREVIOUS (table), name);
670 } else {
671 return 0;
672 }
673 }
674
675 //! @brief Find a tag, searching only local symbol table.
676
677 TAG_T *find_tag_local (TABLE_T * table, int a, const char *name)
678 {
679 if (table != NO_TABLE) {
680 TAG_T *s = NO_TAG;
681 if (a == OP_SYMBOL) {
682 s = OPERATORS (table);
683 } else if (a == PRIO_SYMBOL) {
684 s = PRIO (table);
685 } else if (a == IDENTIFIER) {
686 s = IDENTIFIERS (table);
687 } else if (a == INDICANT) {
688 s = INDICANTS (table);
689 } else if (a == LABEL) {
690 s = LABELS (table);
691 } else {
692 ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, __func__);
693 }
694 for (; s != NO_TAG; FORWARD (s)) {
695 if (NSYMBOL (NODE (s)) == name) {
696 return s;
697 }
698 }
699 }
700 return NO_TAG;
701 }
702
703 //! @brief Whether context specifies HEAP or LOC for an identifier.
704
705 int tab_qualifier (NODE_T * p)
706 {
707 if (p != NO_NODE) {
708 if (is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP)) {
709 return tab_qualifier (SUB (p));
710 } else if (is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) {
711 return ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL;
712 } else {
713 return LOC_SYMBOL;
714 }
715 } else {
716 return LOC_SYMBOL;
717 }
718 }
719
720 //! @brief Enter identity declarations in the symbol table.
721
722 void tax_identity_dec (NODE_T * p, MOID_T ** m)
723 {
724 if (p != NO_NODE) {
725 if (IS (p, IDENTITY_DECLARATION)) {
726 tax_identity_dec (SUB (p), m);
727 tax_identity_dec (NEXT (p), m);
728 } else if (IS (p, DECLARER)) {
729 tax_tags (SUB (p));
730 *m = MOID (p);
731 tax_identity_dec (NEXT (p), m);
732 } else if (IS (p, COMMA_SYMBOL)) {
733 tax_identity_dec (NEXT (p), m);
734 } else if (IS (p, DEFINING_IDENTIFIER)) {
735 TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
736 MOID (p) = *m;
737 HEAP (entry) = LOC_SYMBOL;
738 TAX (p) = entry;
739 MOID (entry) = *m;
740 if (ATTRIBUTE (*m) == REF_SYMBOL) {
741 HEAP (entry) = tab_qualifier (NEXT_NEXT (p));
742 }
743 tax_identity_dec (NEXT_NEXT (p), m);
744 } else {
745 tax_tags (p);
746 }
747 }
748 }
749
750 //! @brief Enter variable declarations in the symbol table.
751
752 void tax_variable_dec (NODE_T * p, int *q, MOID_T ** m)
753 {
754 if (p != NO_NODE) {
755 if (IS (p, VARIABLE_DECLARATION)) {
756 tax_variable_dec (SUB (p), q, m);
757 tax_variable_dec (NEXT (p), q, m);
758 } else if (IS (p, DECLARER)) {
759 tax_tags (SUB (p));
760 *m = MOID (p);
761 tax_variable_dec (NEXT (p), q, m);
762 } else if (IS (p, QUALIFIER)) {
763 *q = ATTRIBUTE (SUB (p));
764 tax_variable_dec (NEXT (p), q, m);
765 } else if (IS (p, COMMA_SYMBOL)) {
766 tax_variable_dec (NEXT (p), q, m);
767 } else if (IS (p, DEFINING_IDENTIFIER)) {
768 TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
769 MOID (p) = *m;
770 TAX (p) = entry;
771 HEAP (entry) = *q;
772 if (*q == LOC_SYMBOL) {
773 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR);
774 HEAP (z) = LOC_SYMBOL;
775 USE (z) = A68_TRUE;
776 BODY (entry) = z;
777 } else {
778 BODY (entry) = NO_TAG;
779 }
780 MOID (entry) = *m;
781 tax_variable_dec (NEXT (p), q, m);
782 } else {
783 tax_tags (p);
784 }
785 }
786 }
787
788 //! @brief Enter procedure variable declarations in the symbol table.
789
790 void tax_proc_variable_dec (NODE_T * p, int *q)
791 {
792 if (p != NO_NODE) {
793 if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
794 tax_proc_variable_dec (SUB (p), q);
795 tax_proc_variable_dec (NEXT (p), q);
796 } else if (IS (p, QUALIFIER)) {
797 *q = ATTRIBUTE (SUB (p));
798 tax_proc_variable_dec (NEXT (p), q);
799 } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) {
800 tax_proc_variable_dec (NEXT (p), q);
801 } else if (IS (p, DEFINING_IDENTIFIER)) {
802 TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
803 TAX (p) = entry;
804 HEAP (entry) = *q;
805 MOID (entry) = MOID (p);
806 if (*q == LOC_SYMBOL) {
807 TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR);
808 HEAP (z) = LOC_SYMBOL;
809 USE (z) = A68_TRUE;
810 BODY (entry) = z;
811 } else {
812 BODY (entry) = NO_TAG;
813 }
814 tax_proc_variable_dec (NEXT (p), q);
815 } else {
816 tax_tags (p);
817 }
818 }
819 }
820
821 //! @brief Enter procedure declarations in the symbol table.
822
823 void tax_proc_dec (NODE_T * p)
824 {
825 if (p != NO_NODE) {
826 if (IS (p, PROCEDURE_DECLARATION)) {
827 tax_proc_dec (SUB (p));
828 tax_proc_dec (NEXT (p));
829 } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) {
830 tax_proc_dec (NEXT (p));
831 } else if (IS (p, DEFINING_IDENTIFIER)) {
832 TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
833 MOID_T *m = MOID (NEXT_NEXT (p));
834 MOID (p) = m;
835 TAX (p) = entry;
836 CODEX (entry) |= PROC_DECLARATION_MASK;
837 HEAP (entry) = LOC_SYMBOL;
838 MOID (entry) = m;
839 tax_proc_dec (NEXT (p));
840 } else {
841 tax_tags (p);
842 }
843 }
844 }
845
846 //! @brief Check validity of operator declaration.
847
848 void check_operator_dec (NODE_T * p, MOID_T * u)
849 {
850 int k = 0;
851 if (u == NO_MOID) {
852 NODE_T *pack = SUB_SUB (NEXT_NEXT (p)); // Where the parameter pack is
853 if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT) {
854 pack = SUB (pack);
855 }
856 k = 1 + count_operands (pack);
857 } else {
858 k = count_pack_members (PACK (u));
859 }
860 if (k < 1 || k > 2) {
861 diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERAND_NUMBER);
862 k = 0;
863 }
864 if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) {
865 diagnostic (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS);
866 } else if (k == 2 && !find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) {
867 diagnostic (A68_SYNTAX_ERROR, p, ERROR_DYADIC_PRIORITY);
868 }
869 }
870
871 //! @brief Enter operator declarations in the symbol table.
872
873 void tax_op_dec (NODE_T * p, MOID_T ** m)
874 {
875 if (p != NO_NODE) {
876 if (IS (p, OPERATOR_DECLARATION)) {
877 tax_op_dec (SUB (p), m);
878 tax_op_dec (NEXT (p), m);
879 } else if (IS (p, OPERATOR_PLAN)) {
880 tax_tags (SUB (p));
881 *m = MOID (p);
882 tax_op_dec (NEXT (p), m);
883 } else if (IS (p, OP_SYMBOL)) {
884 tax_op_dec (NEXT (p), m);
885 } else if (IS (p, COMMA_SYMBOL)) {
886 tax_op_dec (NEXT (p), m);
887 } else if (IS (p, DEFINING_OPERATOR)) {
888 TAG_T *entry = OPERATORS (TABLE (p));
889 check_operator_dec (p, *m);
890 while (entry != NO_TAG && NODE (entry) != p) {
891 FORWARD (entry);
892 }
893 MOID (p) = *m;
894 TAX (p) = entry;
895 HEAP (entry) = LOC_SYMBOL;
896 MOID (entry) = *m;
897 tax_op_dec (NEXT (p), m);
898 } else {
899 tax_tags (p);
900 }
901 }
902 }
903
904 //! @brief Enter brief operator declarations in the symbol table.
905
906 void tax_brief_op_dec (NODE_T * p)
907 {
908 if (p != NO_NODE) {
909 if (IS (p, BRIEF_OPERATOR_DECLARATION)) {
910 tax_brief_op_dec (SUB (p));
911 tax_brief_op_dec (NEXT (p));
912 } else if (is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP)) {
913 tax_brief_op_dec (NEXT (p));
914 } else if (IS (p, DEFINING_OPERATOR)) {
915 TAG_T *entry = OPERATORS (TABLE (p));
916 MOID_T *m = MOID (NEXT_NEXT (p));
917 check_operator_dec (p, NO_MOID);
918 while (entry != NO_TAG && NODE (entry) != p) {
919 FORWARD (entry);
920 }
921 MOID (p) = m;
922 TAX (p) = entry;
923 HEAP (entry) = LOC_SYMBOL;
924 MOID (entry) = m;
925 tax_brief_op_dec (NEXT (p));
926 } else {
927 tax_tags (p);
928 }
929 }
930 }
931
932 //! @brief Enter priority declarations in the symbol table.
933
934 void tax_prio_dec (NODE_T * p)
935 {
936 if (p != NO_NODE) {
937 if (IS (p, PRIORITY_DECLARATION)) {
938 tax_prio_dec (SUB (p));
939 tax_prio_dec (NEXT (p));
940 } else if (is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP)) {
941 tax_prio_dec (NEXT (p));
942 } else if (IS (p, DEFINING_OPERATOR)) {
943 TAG_T *entry = PRIO (TABLE (p));
944 while (entry != NO_TAG && NODE (entry) != p) {
945 FORWARD (entry);
946 }
947 MOID (p) = NO_MOID;
948 TAX (p) = entry;
949 HEAP (entry) = LOC_SYMBOL;
950 tax_prio_dec (NEXT (p));
951 } else {
952 tax_tags (p);
953 }
954 }
955 }
956
957 //! @brief Enter TAXes in the symbol table.
958
959 void tax_tags (NODE_T * p)
960 {
961 for (; p != NO_NODE; FORWARD (p)) {
962 int heap = LOC_SYMBOL;
963 MOID_T *m = NO_MOID;
964 if (IS (p, IDENTITY_DECLARATION)) {
965 tax_identity_dec (p, &m);
966 } else if (IS (p, VARIABLE_DECLARATION)) {
967 tax_variable_dec (p, &heap, &m);
968 } else if (IS (p, PROCEDURE_DECLARATION)) {
969 tax_proc_dec (p);
970 } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
971 tax_proc_variable_dec (p, &heap);
972 } else if (IS (p, OPERATOR_DECLARATION)) {
973 tax_op_dec (p, &m);
974 } else if (IS (p, BRIEF_OPERATOR_DECLARATION)) {
975 tax_brief_op_dec (p);
976 } else if (IS (p, PRIORITY_DECLARATION)) {
977 tax_prio_dec (p);
978 } else {
979 tax_tags (SUB (p));
980 }
981 }
982 }
983
984 //! @brief Reset symbol table nest count.
985
986 void reset_symbol_table_nest_count (NODE_T * p)
987 {
988 for (; p != NO_NODE; FORWARD (p)) {
989 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
990 NEST (TABLE (SUB (p))) = A68 (symbol_table_count)++;
991 }
992 reset_symbol_table_nest_count (SUB (p));
993 }
994 }
995
996 //! @brief Bind routines in symbol table to the tree.
997
998 void bind_routine_tags_to_tree (NODE_T * p)
999 {
1000 // By inserting coercions etc. some may have shifted.
1001 for (; p != NO_NODE; FORWARD (p)) {
1002 if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG) {
1003 NODE (TAX (p)) = p;
1004 }
1005 bind_routine_tags_to_tree (SUB (p));
1006 }
1007 }
1008
1009 //! @brief Bind formats in symbol table to tree.
1010
1011 void bind_format_tags_to_tree (NODE_T * p)
1012 {
1013 // By inserting coercions etc. some may have shifted.
1014 for (; p != NO_NODE; FORWARD (p)) {
1015 if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG) {
1016 NODE (TAX (p)) = p;
1017 } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG) {
1018 NODE (TAX (p)) = p;
1019 }
1020 bind_format_tags_to_tree (SUB (p));
1021 }
1022 }
1023
1024 //! @brief Fill outer level of symbol table.
1025
1026 void fill_symbol_table_outer (NODE_T * p, TABLE_T * s)
1027 {
1028 for (; p != NO_NODE; FORWARD (p)) {
1029 if (TABLE (p) != NO_TABLE) {
1030 OUTER (TABLE (p)) = s;
1031 }
1032 if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT)) {
1033 fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
1034 } else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT)) {
1035 fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
1036 } else {
1037 fill_symbol_table_outer (SUB (p), s);
1038 }
1039 }
1040 }
1041
1042 //! @brief Flood branch in tree with local symbol table "s".
1043
1044 void flood_with_symbol_table_restricted (NODE_T * p, TABLE_T * s)
1045 {
1046 for (; p != NO_NODE; FORWARD (p)) {
1047 TABLE (p) = s;
1048 if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT) {
1049 if (is_new_lexical_level (p)) {
1050 PREVIOUS (TABLE (SUB (p))) = s;
1051 } else {
1052 flood_with_symbol_table_restricted (SUB (p), s);
1053 }
1054 }
1055 }
1056 }
1057
1058 //! @brief Final structure of symbol table after parsing.
1059
1060 void finalise_symbol_table_setup (NODE_T * p, int l)
1061 {
1062 TABLE_T *s = TABLE (p);
1063 NODE_T *q = p;
1064 while (q != NO_NODE) {
1065 // routine texts are ranges.
1066 if (IS (q, ROUTINE_TEXT)) {
1067 flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s));
1068 }
1069 // specifiers are ranges.
1070 else if (IS (q, SPECIFIED_UNIT)) {
1071 flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s));
1072 }
1073 // level count and recursion.
1074 if (SUB (q) != NO_NODE) {
1075 if (is_new_lexical_level (q)) {
1076 LEX_LEVEL (SUB (q)) = l + 1;
1077 PREVIOUS (TABLE (SUB (q))) = s;
1078 finalise_symbol_table_setup (SUB (q), l + 1);
1079 if (IS (q, WHILE_PART)) {
1080 // This was a bug that went unnoticed for 15 years!.
1081 TABLE_T *s2 = TABLE (SUB (q));
1082 if ((FORWARD (q)) == NO_NODE) {
1083 return;
1084 }
1085 if (IS (q, ALT_DO_PART)) {
1086 PREVIOUS (TABLE (SUB (q))) = s2;
1087 LEX_LEVEL (SUB (q)) = l + 2;
1088 finalise_symbol_table_setup (SUB (q), l + 2);
1089 }
1090 }
1091 } else {
1092 TABLE (SUB (q)) = s;
1093 finalise_symbol_table_setup (SUB (q), l);
1094 }
1095 }
1096 TABLE (q) = s;
1097 if (IS (q, FOR_SYMBOL)) {
1098 FORWARD (q);
1099 }
1100 FORWARD (q);
1101 }
1102 // FOR identifiers are in the DO ... OD range.
1103 for (q = p; q != NO_NODE; FORWARD (q)) {
1104 if (IS (q, FOR_SYMBOL)) {
1105 TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q)));
1106 }
1107 }
1108 }
1109
1110 //! @brief First structure of symbol table for parsing.
1111
1112 void preliminary_symbol_table_setup (NODE_T * p)
1113 {
1114 TABLE_T *s = TABLE (p);
1115 BOOL_T not_a_for_range = A68_FALSE;
1116 // let the tree point to the current symbol table.
1117 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
1118 TABLE (q) = s;
1119 }
1120 // insert new tables when required.
1121 for (NODE_T *q = p; q != NO_NODE && !not_a_for_range; FORWARD (q)) {
1122 if (SUB (q) != NO_NODE) {
1123 // BEGIN ... END, CODE ... EDOC, DEF ... FED, DO ... OD, $ ... $, { ... } are ranges.
1124 if (is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, FORMAT_DELIMITER_SYMBOL, ACCO_SYMBOL, STOP)) {
1125 TABLE (SUB (q)) = new_symbol_table (s);
1126 preliminary_symbol_table_setup (SUB (q));
1127 }
1128 // ( ... ) is a range.
1129 else if (IS (q, OPEN_SYMBOL)) {
1130 if (whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP)) {
1131 TABLE (SUB (q)) = s;
1132 preliminary_symbol_table_setup (SUB (q));
1133 FORWARD (q);
1134 TABLE (SUB (q)) = new_symbol_table (s);
1135 preliminary_symbol_table_setup (SUB (q));
1136 if ((FORWARD (q)) == NO_NODE) {
1137 not_a_for_range = A68_TRUE;
1138 } else {
1139 if (IS (q, THEN_BAR_SYMBOL)) {
1140 TABLE (SUB (q)) = new_symbol_table (s);
1141 preliminary_symbol_table_setup (SUB (q));
1142 }
1143 if (IS (q, OPEN_SYMBOL)) {
1144 TABLE (SUB (q)) = new_symbol_table (s);
1145 preliminary_symbol_table_setup (SUB (q));
1146 }
1147 }
1148 } else {
1149 // don't worry about STRUCT (...), UNION (...), PROC (...) yet.
1150 TABLE (SUB (q)) = new_symbol_table (s);
1151 preliminary_symbol_table_setup (SUB (q));
1152 }
1153 }
1154 // IF ... THEN ... ELSE ... FI are ranges.
1155 else if (IS (q, IF_SYMBOL)) {
1156 if (whether (q, IF_SYMBOL, THEN_SYMBOL, STOP)) {
1157 TABLE (SUB (q)) = s;
1158 preliminary_symbol_table_setup (SUB (q));
1159 FORWARD (q);
1160 TABLE (SUB (q)) = new_symbol_table (s);
1161 preliminary_symbol_table_setup (SUB (q));
1162 if ((FORWARD (q)) == NO_NODE) {
1163 not_a_for_range = A68_TRUE;
1164 } else {
1165 if (IS (q, ELSE_SYMBOL)) {
1166 TABLE (SUB (q)) = new_symbol_table (s);
1167 preliminary_symbol_table_setup (SUB (q));
1168 }
1169 if (IS (q, IF_SYMBOL)) {
1170 TABLE (SUB (q)) = new_symbol_table (s);
1171 preliminary_symbol_table_setup (SUB (q));
1172 }
1173 }
1174 } else {
1175 TABLE (SUB (q)) = new_symbol_table (s);
1176 preliminary_symbol_table_setup (SUB (q));
1177 }
1178 }
1179 // CASE ... IN ... OUT ... ESAC are ranges.
1180 else if (IS (q, CASE_SYMBOL)) {
1181 if (whether (q, CASE_SYMBOL, IN_SYMBOL, STOP)) {
1182 TABLE (SUB (q)) = s;
1183 preliminary_symbol_table_setup (SUB (q));
1184 FORWARD (q);
1185 TABLE (SUB (q)) = new_symbol_table (s);
1186 preliminary_symbol_table_setup (SUB (q));
1187 if ((FORWARD (q)) == NO_NODE) {
1188 not_a_for_range = A68_TRUE;
1189 } else {
1190 if (IS (q, OUT_SYMBOL)) {
1191 TABLE (SUB (q)) = new_symbol_table (s);
1192 preliminary_symbol_table_setup (SUB (q));
1193 }
1194 if (IS (q, CASE_SYMBOL)) {
1195 TABLE (SUB (q)) = new_symbol_table (s);
1196 preliminary_symbol_table_setup (SUB (q));
1197 }
1198 }
1199 } else {
1200 TABLE (SUB (q)) = new_symbol_table (s);
1201 preliminary_symbol_table_setup (SUB (q));
1202 }
1203 }
1204 // UNTIL ... OD is a range.
1205 else if (IS (q, UNTIL_SYMBOL) && SUB (q) != NO_NODE) {
1206 TABLE (SUB (q)) = new_symbol_table (s);
1207 preliminary_symbol_table_setup (SUB (q));
1208 // WHILE ... DO ... OD are ranges.
1209 } else if (IS (q, WHILE_SYMBOL)) {
1210 TABLE_T *u = new_symbol_table (s);
1211 TABLE (SUB (q)) = u;
1212 preliminary_symbol_table_setup (SUB (q));
1213 if ((FORWARD (q)) == NO_NODE) {
1214 not_a_for_range = A68_TRUE;
1215 } else if (IS (q, ALT_DO_SYMBOL)) {
1216 TABLE (SUB (q)) = new_symbol_table (u);
1217 preliminary_symbol_table_setup (SUB (q));
1218 }
1219 } else {
1220 TABLE (SUB (q)) = s;
1221 preliminary_symbol_table_setup (SUB (q));
1222 }
1223 }
1224 }
1225 // FOR identifiers will go to the DO ... OD range.
1226 if (!not_a_for_range) {
1227 for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) {
1228 if (IS (q, FOR_SYMBOL)) {
1229 NODE_T *r = q;
1230 TABLE (NEXT (q)) = NO_TABLE;
1231 for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r)) {
1232 if ((is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP)) && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE)) {
1233 TABLE (NEXT (q)) = TABLE (SUB (r));
1234 SEQUENCE (NEXT (q)) = SUB (r);
1235 }
1236 }
1237 }
1238 }
1239 }
1240 }
1241
1242 //! @brief Mark a mode as in use.
1243
1244 void mark_mode (MOID_T * m)
1245 {
1246 if (m != NO_MOID && USE (m) == A68_FALSE) {
1247 PACK_T *p = PACK (m);
1248 USE (m) = A68_TRUE;
1249 for (; p != NO_PACK; FORWARD (p)) {
1250 mark_mode (MOID (p));
1251 mark_mode (SUB (m));
1252 mark_mode (SLICE (m));
1253 }
1254 }
1255 }
1256
1257 //! @brief Traverse tree and mark modes as used.
1258
1259 void mark_moids (NODE_T * p)
1260 {
1261 for (; p != NO_NODE; FORWARD (p)) {
1262 mark_moids (SUB (p));
1263 if (MOID (p) != NO_MOID) {
1264 mark_mode (MOID (p));
1265 }
1266 }
1267 }
1268
1269 //! @brief Mark various tags as used.
1270
1271 void mark_auxilliary (NODE_T * p)
1272 {
1273 for (; p != NO_NODE; FORWARD (p)) {
1274 if (SUB (p) != NO_NODE) {
1275 // You get no warnings on unused PROC parameters. That is ok since A68 has some
1276 // parameters that you may not use at all - think of PROC (REF FILE) BOOL event
1277 // routines in transput.
1278 mark_auxilliary (SUB (p));
1279 } else if (IS (p, OPERATOR)) {
1280 TAG_T *z;
1281 if (TAX (p) != NO_TAG) {
1282 USE (TAX (p)) = A68_TRUE;
1283 }
1284 if ((z = find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG) {
1285 USE (z) = A68_TRUE;
1286 }
1287 } else if (IS (p, INDICANT)) {
1288 TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
1289 if (z != NO_TAG) {
1290 TAX (p) = z;
1291 USE (z) = A68_TRUE;
1292 }
1293 } else if (IS (p, IDENTIFIER)) {
1294 if (TAX (p) != NO_TAG) {
1295 USE (TAX (p)) = A68_TRUE;
1296 }
1297 }
1298 }
1299 }
1300
1301 //! @brief Check a single tag.
1302
1303 void unused (TAG_T * s)
1304 {
1305 for (; s != NO_TAG; FORWARD (s)) {
1306 if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) {
1307 diagnostic (A68_WARNING, NODE (s), WARNING_TAG_UNUSED, NODE (s));
1308 }
1309 }
1310 }
1311
1312 //! @brief Driver for traversing tree and warn for unused tags.
1313
1314 void warn_for_unused_tags (NODE_T * p)
1315 {
1316 for (; p != NO_NODE; FORWARD (p)) {
1317 if (SUB (p) != NO_NODE) {
1318 if (is_new_lexical_level (p) && ATTRIBUTE (TABLE (SUB (p))) != ENVIRON_SYMBOL) {
1319 unused (OPERATORS (TABLE (SUB (p))));
1320 unused (PRIO (TABLE (SUB (p))));
1321 unused (IDENTIFIERS (TABLE (SUB (p))));
1322 unused (LABELS (TABLE (SUB (p))));
1323 unused (INDICANTS (TABLE (SUB (p))));
1324 }
1325 }
1326 warn_for_unused_tags (SUB (p));
1327 }
1328 }
1329
1330 //! @brief Mark jumps and procedured jumps.
1331
1332 void jumps_from_procs (NODE_T * p)
1333 {
1334 for (; p != NO_NODE; FORWARD (p)) {
1335 if (IS (p, PROCEDURING)) {
1336 NODE_T *u = SUB_SUB (p);
1337 if (IS (u, GOTO_SYMBOL)) {
1338 FORWARD (u);
1339 }
1340 USE (TAX (u)) = A68_TRUE;
1341 } else if (IS (p, JUMP)) {
1342 NODE_T *u = SUB (p);
1343 if (IS (u, GOTO_SYMBOL)) {
1344 FORWARD (u);
1345 }
1346 if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID) && (find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG)) {
1347 (void) add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL);
1348 diagnostic (A68_ERROR, u, ERROR_UNDECLARED_TAG);
1349 } else {
1350 USE (TAX (u)) = A68_TRUE;
1351 }
1352 } else {
1353 jumps_from_procs (SUB (p));
1354 }
1355 }
1356 }
1357
1358 //! @brief Assign offset tags.
1359
1360 ADDR_T assign_offset_tags (TAG_T * t, ADDR_T base)
1361 {
1362 ADDR_T sum = base;
1363 for (; t != NO_TAG; FORWARD (t)) {
1364 ABEND (MOID (t) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NSYMBOL (NODE (t)));
1365 SIZE (t) = moid_size (MOID (t));
1366 if (VALUE (t) == NO_TEXT) {
1367 OFFSET (t) = sum;
1368 sum += SIZE (t);
1369 }
1370 }
1371 return sum;
1372 }
1373
1374 //! @brief Assign offsets table.
1375
1376 void assign_offsets_table (TABLE_T * c)
1377 {
1378 AP_INCREMENT (c) = assign_offset_tags (IDENTIFIERS (c), 0);
1379 AP_INCREMENT (c) = assign_offset_tags (OPERATORS (c), AP_INCREMENT (c));
1380 AP_INCREMENT (c) = assign_offset_tags (ANONYMOUS (c), AP_INCREMENT (c));
1381 AP_INCREMENT (c) = A68_ALIGN (AP_INCREMENT (c));
1382 }
1383
1384 //! @brief Assign offsets.
1385
1386 void assign_offsets (NODE_T * p)
1387 {
1388 for (; p != NO_NODE; FORWARD (p)) {
1389 if (SUB (p) != NO_NODE && is_new_lexical_level (p)) {
1390 assign_offsets_table (TABLE (SUB (p)));
1391 }
1392 assign_offsets (SUB (p));
1393 }
1394 }
1395
1396 //! @brief Assign offsets packs in moid list.
1397
1398 void assign_offsets_packs (MOID_T * q)
1399 {
1400 for (; q != NO_MOID; FORWARD (q)) {
1401 if (EQUIVALENT (q) == NO_MOID && IS (q, STRUCT_SYMBOL)) {
1402 PACK_T *p = PACK (q);
1403 ADDR_T offset = 0;
1404 for (; p != NO_PACK; FORWARD (p)) {
1405 SIZE (p) = moid_size (MOID (p));
1406 OFFSET (p) = offset;
1407 offset += SIZE (p);
1408 }
1409 }
1410 }
1411 }
