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