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