parser-scope.c
1 //! @file parser-scope.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 //! Static scope checker.
25
26 // A static scope checker inspects the source. Note that Algol 68 also
27 // needs dynamic scope checking. This phase concludes the parser.
28
29 #include "a68g.h"
30 #include "a68g-parser.h"
31
32 typedef struct TUPLE_T TUPLE_T;
33 typedef struct SCOPE_T SCOPE_T;
34
35 struct TUPLE_T
36 {
37 int level;
38 BOOL_T transient;
39 };
40
41 struct SCOPE_T
42 {
43 NODE_T *where;
44 TUPLE_T tuple;
45 SCOPE_T *next;
46 };
47
48 enum
49 { NOT_TRANSIENT = 0, TRANSIENT };
50
51 void gather_scopes_for_youngest (NODE_T *, SCOPE_T **);
52 void scope_statement (NODE_T *, SCOPE_T **);
53 void scope_enclosed_clause (NODE_T *, SCOPE_T **);
54 void scope_formula (NODE_T *, SCOPE_T **);
55 void scope_routine_text (NODE_T *, SCOPE_T **);
56
57 // Static scope checker, at run time we check dynamic scope as well.
58
59 // Static scope checker.
60 // Also a little preparation for the monitor:
61 // - indicates UNITs that can be interrupted.
62
63 //! @brief Scope_make_tuple.
64
65 TUPLE_T scope_make_tuple (int e, int t)
66 {
67 static TUPLE_T z;
68 LEVEL (&z) = e;
69 TRANSIENT (&z) = (BOOL_T) t;
70 return z;
71 }
72
73 //! @brief Link scope information into the list.
74
75 void scope_add (SCOPE_T ** sl, NODE_T * p, TUPLE_T tup)
76 {
77 if (sl != NO_VAR) {
78 SCOPE_T *ns = (SCOPE_T *) get_temp_heap_space ((unt) SIZE_ALIGNED (SCOPE_T));
79 WHERE (ns) = p;
80 TUPLE (ns) = tup;
81 NEXT (ns) = *sl;
82 *sl = ns;
83 }
84 }
85
86 //! @brief Scope_check.
87
88 BOOL_T scope_check (SCOPE_T * top, int mask, int dest)
89 {
90 int errors = 0;
91 // Transient names cannot be stored.
92 if (mask & TRANSIENT) {
93 for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) {
94 if (TRANSIENT (&TUPLE (s)) & TRANSIENT) {
95 diagnostic (A68_ERROR, WHERE (s), ERROR_TRANSIENT_NAME);
96 STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
97 errors++;
98 }
99 }
100 }
101 // Potential scope violations.
102 for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) {
103 if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) {
104 MOID_T *ws = MOID (WHERE (s));
105 if (ws != NO_MOID) {
106 if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL)) {
107 diagnostic (A68_WARNING, WHERE (s), WARNING_SCOPE_STATIC, MOID (WHERE (s)), ATTRIBUTE (WHERE (s)));
108 }
109 }
110 STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
111 errors++;
112 }
113 }
114 return (BOOL_T) (errors == 0);
115 }
116
117 //! @brief Scope_check_multiple.
118
119 BOOL_T scope_check_multiple (SCOPE_T * top, int mask, SCOPE_T * dest)
120 {
121 BOOL_T no_err = A68_TRUE;
122 for (; dest != NO_SCOPE; FORWARD (dest)) {
123 no_err &= scope_check (top, mask, LEVEL (&TUPLE (dest)));
124 }
125 return no_err;
126 }
127
128 //! @brief Check_identifier_usage.
129
130 void check_identifier_usage (TAG_T * t, NODE_T * p)
131 {
132 for (; p != NO_NODE; FORWARD (p)) {
133 if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL) {
134 diagnostic (A68_WARNING, p, WARNING_UNINITIALISED);
135 }
136 check_identifier_usage (t, SUB (p));
137 }
138 }
139
140 //! @brief Scope_find_youngest_outside.
141
142 TUPLE_T scope_find_youngest_outside (SCOPE_T * s, int treshold)
143 {
144 TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT);
145 for (; s != NO_SCOPE; FORWARD (s)) {
146 if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold) {
147 z = TUPLE (s);
148 }
149 }
150 return z;
151 }
152
153 //! @brief Scope_find_youngest.
154
155 TUPLE_T scope_find_youngest (SCOPE_T * s)
156 {
157 return scope_find_youngest_outside (s, INT_MAX);
158 }
159
160 // Routines for determining scope of ROUTINE TEXT or FORMAT TEXT.
161
162 //! @brief Get_declarer_elements.
163
164 void get_declarer_elements (NODE_T * p, SCOPE_T ** r, BOOL_T no_ref)
165 {
166 if (p != NO_NODE) {
167 if (IS (p, BOUNDS)) {
168 gather_scopes_for_youngest (SUB (p), r);
169 } else if (IS (p, INDICANT)) {
170 if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref) {
171 scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
172 }
173 } else if (IS_REF (p)) {
174 get_declarer_elements (NEXT (p), r, A68_FALSE);
175 } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) {
176 ;
177 } else {
178 get_declarer_elements (SUB (p), r, no_ref);
179 get_declarer_elements (NEXT (p), r, no_ref);
180 }
181 }
182 }
183
184 //! @brief Gather_scopes_for_youngest.
185
186 void gather_scopes_for_youngest (NODE_T * p, SCOPE_T ** s)
187 {
188 for (; p != NO_NODE; FORWARD (p)) {
189 if ((is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE)) {
190 SCOPE_T *t = NO_SCOPE;
191 TUPLE_T tup;
192 gather_scopes_for_youngest (SUB (p), &t);
193 tup = scope_find_youngest_outside (t, LEX_LEVEL (p));
194 YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
195 // Direct link into list iso "gather_scopes_for_youngest (SUB (p), s);".
196 if (t != NO_SCOPE) {
197 SCOPE_T *u = t;
198 while (NEXT (u) != NO_SCOPE) {
199 FORWARD (u);
200 }
201 NEXT (u) = *s;
202 (*s) = t;
203 }
204 } else if (is_one_of (p, IDENTIFIER, OPERATOR, STOP)) {
205 if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE) {
206 scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
207 }
208 } else if (IS (p, DECLARER)) {
209 get_declarer_elements (p, s, A68_TRUE);
210 } else {
211 gather_scopes_for_youngest (SUB (p), s);
212 }
213 }
214 }
215
216 //! @brief Get_youngest_environs.
217
218 void get_youngest_environs (NODE_T * p)
219 {
220 for (; p != NO_NODE; FORWARD (p)) {
221 if (is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) {
222 SCOPE_T *s = NO_SCOPE;
223 TUPLE_T tup;
224 gather_scopes_for_youngest (SUB (p), &s);
225 tup = scope_find_youngest_outside (s, LEX_LEVEL (p));
226 YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
227 } else {
228 get_youngest_environs (SUB (p));
229 }
230 }
231 }
232
233 //! @brief Bind_scope_to_tag.
234
235 void bind_scope_to_tag (NODE_T * p)
236 {
237 for (; p != NO_NODE; FORWARD (p)) {
238 if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT) {
239 if (IS (NEXT_NEXT (p), FORMAT_TEXT)) {
240 SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
241 SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
242 }
243 return;
244 } else if (IS (p, DEFINING_IDENTIFIER)) {
245 if (IS (NEXT_NEXT (p), ROUTINE_TEXT)) {
246 SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
247 SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
248 }
249 return;
250 } else {
251 bind_scope_to_tag (SUB (p));
252 }
253 }
254 }
255
256 //! @brief Bind_scope_to_tags.
257
258 void bind_scope_to_tags (NODE_T * p)
259 {
260 for (; p != NO_NODE; FORWARD (p)) {
261 if (is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) {
262 bind_scope_to_tag (SUB (p));
263 } else {
264 bind_scope_to_tags (SUB (p));
265 }
266 }
267 }
268
269 //! @brief Scope_bounds.
270
271 void scope_bounds (NODE_T * p)
272 {
273 for (; p != NO_NODE; FORWARD (p)) {
274 if (IS (p, UNIT)) {
275 scope_statement (p, NO_VAR);
276 } else {
277 scope_bounds (SUB (p));
278 }
279 }
280 }
281
282 //! @brief Scope_declarer.
283
284 void scope_declarer (NODE_T * p)
285 {
286 if (p != NO_NODE) {
287 if (IS (p, BOUNDS)) {
288 scope_bounds (SUB (p));
289 } else if (IS (p, INDICANT)) {
290 ;
291 } else if (IS_REF (p)) {
292 scope_declarer (NEXT (p));
293 } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) {
294 ;
295 } else {
296 scope_declarer (SUB (p));
297 scope_declarer (NEXT (p));
298 }
299 }
300 }
301
302 //! @brief Scope_identity_declaration.
303
304 void scope_identity_declaration (NODE_T * p)
305 {
306 for (; p != NO_NODE; FORWARD (p)) {
307 scope_identity_declaration (SUB (p));
308 if (IS (p, DEFINING_IDENTIFIER)) {
309 NODE_T *unit = NEXT_NEXT (p);
310 SCOPE_T *s = NO_SCOPE;
311 TUPLE_T tup;
312 int z = PRIMAL_SCOPE;
313 if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL) {
314 check_identifier_usage (TAX (p), unit);
315 }
316 scope_statement (unit, &s);
317 (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
318 tup = scope_find_youngest (s);
319 z = LEVEL (&tup);
320 if (z < LEX_LEVEL (p)) {
321 SCOPE (TAX (p)) = z;
322 SCOPE_ASSIGNED (TAX (p)) = A68_TRUE;
323 }
324 STATUS_SET (unit, INTERRUPTIBLE_MASK);
325 return;
326 }
327 }
328 }
329
330 //! @brief Scope_variable_declaration.
331
332 void scope_variable_declaration (NODE_T * p)
333 {
334 for (; p != NO_NODE; FORWARD (p)) {
335 scope_variable_declaration (SUB (p));
336 if (IS (p, DECLARER)) {
337 scope_declarer (SUB (p));
338 } else if (IS (p, DEFINING_IDENTIFIER)) {
339 if (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) {
340 NODE_T *unit = NEXT_NEXT (p);
341 SCOPE_T *s = NO_SCOPE;
342 check_identifier_usage (TAX (p), unit);
343 scope_statement (unit, &s);
344 (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
345 STATUS_SET (unit, INTERRUPTIBLE_MASK);
346 return;
347 }
348 }
349 }
350 }
351
352 //! @brief Scope_procedure_declaration.
353
354 void scope_procedure_declaration (NODE_T * p)
355 {
356 for (; p != NO_NODE; FORWARD (p)) {
357 scope_procedure_declaration (SUB (p));
358 if (is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) {
359 NODE_T *unit = NEXT_NEXT (p);
360 SCOPE_T *s = NO_SCOPE;
361 scope_statement (unit, &s);
362 (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p));
363 STATUS_SET (unit, INTERRUPTIBLE_MASK);
364 return;
365 }
366 }
367 }
368
369 //! @brief Scope_declaration_list.
370
371 void scope_declaration_list (NODE_T * p)
372 {
373 if (p != NO_NODE) {
374 if (IS (p, IDENTITY_DECLARATION)) {
375 scope_identity_declaration (SUB (p));
376 } else if (IS (p, VARIABLE_DECLARATION)) {
377 scope_variable_declaration (SUB (p));
378 } else if (IS (p, MODE_DECLARATION)) {
379 scope_declarer (SUB (p));
380 } else if (IS (p, PRIORITY_DECLARATION)) {
381 ;
382 } else if (IS (p, PROCEDURE_DECLARATION)) {
383 scope_procedure_declaration (SUB (p));
384 } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) {
385 scope_procedure_declaration (SUB (p));
386 } else if (is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP)) {
387 scope_procedure_declaration (SUB (p));
388 } else {
389 scope_declaration_list (SUB (p));
390 scope_declaration_list (NEXT (p));
391 }
392 }
393 }
394
395 //! @brief Scope_arguments.
396
397 void scope_arguments (NODE_T * p)
398 {
399 for (; p != NO_NODE; FORWARD (p)) {
400 if (IS (p, UNIT)) {
401 SCOPE_T *s = NO_SCOPE;
402 scope_statement (p, &s);
403 (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
404 } else {
405 scope_arguments (SUB (p));
406 }
407 }
408 }
409
410 //! @brief Is_coercion.
411
412 BOOL_T is_coercion (NODE_T * p)
413 {
414 if (p != NO_NODE) {
415 switch (ATTRIBUTE (p)) {
416 case DEPROCEDURING:
417 case DEREFERENCING:
418 case UNITING:
419 case ROWING:
420 case WIDENING:
421 case VOIDING:
422 case PROCEDURING: {
423 return A68_TRUE;
424 }
425 default: {
426 return A68_FALSE;
427 }
428 }
429 } else {
430 return A68_FALSE;
431 }
432 }
433
434 //! @brief Scope_coercion.
435
436 void scope_coercion (NODE_T * p, SCOPE_T ** s)
437 {
438 if (is_coercion (p)) {
439 if (IS (p, VOIDING)) {
440 scope_coercion (SUB (p), NO_VAR);
441 } else if (IS (p, DEREFERENCING)) {
442 // Leave this to the dynamic scope checker.
443 scope_coercion (SUB (p), NO_VAR);
444 } else if (IS (p, DEPROCEDURING)) {
445 scope_coercion (SUB (p), NO_VAR);
446 } else if (IS (p, ROWING)) {
447 SCOPE_T *z = NO_SCOPE;
448 scope_coercion (SUB (p), &z);
449 (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
450 if (IS_REF_FLEX (MOID (SUB (p)))) {
451 scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
452 } else {
453 scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
454 }
455 } else if (IS (p, PROCEDURING)) {
456 // Can only be a JUMP.
457 NODE_T *q = SUB_SUB (p);
458 if (IS (q, GOTO_SYMBOL)) {
459 FORWARD (q);
460 }
461 scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT));
462 } else if (IS (p, UNITING)) {
463 SCOPE_T *z = NO_SCOPE;
464 scope_coercion (SUB (p), &z);
465 if (z != NO_SCOPE) {
466 (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
467 scope_add (s, p, scope_find_youngest (z));
468 }
469 } else {
470 scope_coercion (SUB (p), s);
471 }
472 } else {
473 scope_statement (p, s);
474 }
475 }
476
477 //! @brief Scope_format_text.
478
479 void scope_format_text (NODE_T * p, SCOPE_T ** s)
480 {
481 for (; p != NO_NODE; FORWARD (p)) {
482 if (IS (p, FORMAT_PATTERN)) {
483 scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
484 } else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE) {
485 scope_enclosed_clause (SUB_NEXT (p), s);
486 } else if (IS (p, DYNAMIC_REPLICATOR)) {
487 scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
488 } else {
489 scope_format_text (SUB (p), s);
490 }
491 }
492 }
493
494 //! @brief Scope_operand.
495
496 void scope_operand (NODE_T * p, SCOPE_T ** s)
497 {
498 if (IS (p, MONADIC_FORMULA)) {
499 scope_operand (NEXT_SUB (p), s);
500 } else if (IS (p, FORMULA)) {
501 scope_formula (p, s);
502 } else if (IS (p, SECONDARY)) {
503 scope_statement (SUB (p), s);
504 }
505 }
506
507 //! @brief Scope_formula.
508
509 void scope_formula (NODE_T * p, SCOPE_T ** s)
510 {
511 NODE_T *q = SUB (p);
512 SCOPE_T *s2 = NO_SCOPE;
513 scope_operand (q, &s2);
514 (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p));
515 if (NEXT (q) != NO_NODE) {
516 SCOPE_T *s3 = NO_SCOPE;
517 scope_operand (NEXT_NEXT (q), &s3);
518 (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p));
519 }
520 (void) s;
521 }
522
523 //! @brief Scope_routine_text.
524
525 void scope_routine_text (NODE_T * p, SCOPE_T ** s)
526 {
527 NODE_T *q = SUB (p), *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q);
528 SCOPE_T *x = NO_SCOPE;
529 scope_statement (NEXT_NEXT (routine), &x);
530 (void) scope_check (x, TRANSIENT, LEX_LEVEL (p));
531 TUPLE_T routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT);
532 scope_add (s, p, routine_tuple);
533 }
534
535 //! @brief Scope_statement.
536
537 void scope_statement (NODE_T * p, SCOPE_T ** s)
538 {
539 if (is_coercion (p)) {
540 scope_coercion (p, s);
541 } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) {
542 scope_statement (SUB (p), s);
543 } else if (is_one_of (p, NIHIL, STOP)) {
544 scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
545 } else if (IS (p, DENOTATION)) {
546 ;
547 } else if (IS (p, IDENTIFIER)) {
548 if (IS_REF (MOID (p))) {
549 if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) {
550 scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT));
551 } else {
552 if (HEAP (TAX (p)) == HEAP_SYMBOL) {
553 scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
554 } else if (SCOPE_ASSIGNED (TAX (p))) {
555 scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
556 } else {
557 scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
558 }
559 }
560 } else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) {
561 scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
562 } else if (MOID (p) == M_FORMAT && SCOPE_ASSIGNED (TAX (p)) == A68_TRUE) {
563 scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
564 }
565 } else if (IS (p, ENCLOSED_CLAUSE)) {
566 scope_enclosed_clause (SUB (p), s);
567 } else if (IS (p, CALL)) {
568 SCOPE_T *x = NO_SCOPE;
569 scope_statement (SUB (p), &x);
570 (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
571 scope_arguments (NEXT_SUB (p));
572 } else if (IS (p, SLICE)) {
573 SCOPE_T *x = NO_SCOPE;
574 MOID_T *m = MOID (SUB (p));
575 if (IS_REF (m)) {
576 if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) {
577 scope_statement (SUB (p), s);
578 } else {
579 scope_statement (SUB (p), &x);
580 (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
581 }
582 if (IS_FLEX (SUB (m))) {
583 scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
584 }
585 scope_bounds (SUB (NEXT_SUB (p)));
586 }
587 if (IS_REF (MOID (p))) {
588 scope_add (s, p, scope_find_youngest (x));
589 }
590 } else if (IS (p, FORMAT_TEXT)) {
591 SCOPE_T *x = NO_SCOPE;
592 scope_format_text (SUB (p), &x);
593 scope_add (s, p, scope_find_youngest (x));
594 } else if (IS (p, CAST)) {
595 SCOPE_T *x = NO_SCOPE;
596 scope_enclosed_clause (SUB (NEXT_SUB (p)), &x);
597 (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
598 scope_add (s, p, scope_find_youngest (x));
599 } else if (IS (p, SELECTION)) {
600 SCOPE_T *ns = NO_SCOPE;
601 scope_statement (NEXT_SUB (p), &ns);
602 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p));
603 if (is_ref_refety_flex (MOID (NEXT_SUB (p)))) {
604 scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
605 }
606 scope_add (s, p, scope_find_youngest (ns));
607 } else if (IS (p, GENERATOR)) {
608 if (IS (SUB (p), LOC_SYMBOL)) {
609 if (NON_LOCAL (p) != NO_TABLE) {
610 scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT));
611 } else {
612 scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
613 }
614 } else {
615 scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
616 }
617 scope_declarer (SUB (NEXT_SUB (p)));
618 } else if (IS (p, DIAGONAL_FUNCTION)) {
619 NODE_T *q = SUB (p);
620 SCOPE_T *ns = NO_SCOPE;
621 if (IS (q, TERTIARY)) {
622 scope_statement (SUB (q), &ns);
623 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
624 ns = NO_SCOPE;
625 FORWARD (q);
626 }
627 scope_statement (SUB_NEXT (q), &ns);
628 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
629 scope_add (s, p, scope_find_youngest (ns));
630 } else if (IS (p, TRANSPOSE_FUNCTION)) {
631 NODE_T *q = SUB (p);
632 SCOPE_T *ns = NO_SCOPE;
633 scope_statement (SUB_NEXT (q), &ns);
634 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
635 scope_add (s, p, scope_find_youngest (ns));
636 } else if (IS (p, ROW_FUNCTION)) {
637 NODE_T *q = SUB (p);
638 SCOPE_T *ns = NO_SCOPE;
639 if (IS (q, TERTIARY)) {
640 scope_statement (SUB (q), &ns);
641 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
642 ns = NO_SCOPE;
643 FORWARD (q);
644 }
645 scope_statement (SUB_NEXT (q), &ns);
646 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
647 scope_add (s, p, scope_find_youngest (ns));
648 } else if (IS (p, COLUMN_FUNCTION)) {
649 NODE_T *q = SUB (p);
650 SCOPE_T *ns = NO_SCOPE;
651 if (IS (q, TERTIARY)) {
652 scope_statement (SUB (q), &ns);
653 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
654 ns = NO_SCOPE;
655 FORWARD (q);
656 }
657 scope_statement (SUB_NEXT (q), &ns);
658 (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q));
659 scope_add (s, p, scope_find_youngest (ns));
660 } else if (IS (p, FORMULA)) {
661 scope_formula (p, s);
662 } else if (IS (p, ASSIGNATION)) {
663 NODE_T *unit = NEXT (NEXT_SUB (p));
664 SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE;
665 TUPLE_T tup;
666 scope_statement (SUB_SUB (p), &nd);
667 scope_statement (unit, &ns);
668 (void) scope_check_multiple (ns, TRANSIENT, nd);
669 tup = scope_find_youngest (nd);
670 scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT));
671 } else if (IS (p, ROUTINE_TEXT)) {
672 scope_routine_text (p, s);
673 } else if (is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP)) {
674 SCOPE_T *n = NO_SCOPE;
675 scope_statement (SUB (p), &n);
676 scope_statement (NEXT (NEXT_SUB (p)), &n);
677 (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
678 } else if (IS (p, ASSERTION)) {
679 SCOPE_T *n = NO_SCOPE;
680 scope_enclosed_clause (SUB (NEXT_SUB (p)), &n);
681 (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
682 } else if (is_one_of (p, JUMP, SKIP, STOP)) {
683 ;
684 }
685 }
686
687 //! @brief Scope_statement_list.
688
689 void scope_statement_list (NODE_T * p, SCOPE_T ** s)
690 {
691 for (; p != NO_NODE; FORWARD (p)) {
692 if (IS (p, UNIT)) {
693 STATUS_SET (p, INTERRUPTIBLE_MASK);
694 scope_statement (p, s);
695 } else {
696 scope_statement_list (SUB (p), s);
697 }
698 }
699 }
700
701 //! @brief Scope_serial_clause.
702
703 void scope_serial_clause (NODE_T * p, SCOPE_T ** s, BOOL_T terminator)
704 {
705 if (p != NO_NODE) {
706 if (IS (p, INITIALISER_SERIES)) {
707 scope_serial_clause (SUB (p), s, A68_FALSE);
708 scope_serial_clause (NEXT (p), s, terminator);
709 } else if (IS (p, DECLARATION_LIST)) {
710 scope_declaration_list (SUB (p));
711 } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) {
712 scope_serial_clause (NEXT (p), s, terminator);
713 } else if (is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) {
714 if (NEXT (p) != NO_NODE) {
715 int j = ATTRIBUTE (NEXT (p));
716 if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL) {
717 scope_serial_clause (SUB (p), s, A68_TRUE);
718 } else {
719 scope_serial_clause (SUB (p), s, A68_FALSE);
720 }
721 } else {
722 scope_serial_clause (SUB (p), s, A68_TRUE);
723 }
724 scope_serial_clause (NEXT (p), s, terminator);
725 } else if (IS (p, LABELED_UNIT)) {
726 scope_serial_clause (SUB (p), s, terminator);
727 } else if (IS (p, UNIT)) {
728 STATUS_SET (p, INTERRUPTIBLE_MASK);
729 if (terminator) {
730 scope_statement (p, s);
731 } else {
732 scope_statement (p, NO_VAR);
733 }
734 }
735 }
736 }
737
738 //! @brief Scope_closed_clause.
739
740 void scope_closed_clause (NODE_T * p, SCOPE_T ** s)
741 {
742 if (p != NO_NODE) {
743 if (IS (p, SERIAL_CLAUSE)) {
744 scope_serial_clause (p, s, A68_TRUE);
745 } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) {
746 scope_closed_clause (NEXT (p), s);
747 }
748 }
749 }
750
751 //! @brief Scope_collateral_clause.
752
753 void scope_collateral_clause (NODE_T * p, SCOPE_T ** s)
754 {
755 if (p != NO_NODE) {
756 if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) {
757 scope_statement_list (p, s);
758 }
759 }
760 }
761
762 //! @brief Scope_conditional_clause.
763
764 void scope_conditional_clause (NODE_T * p, SCOPE_T ** s)
765 {
766 scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE);
767 FORWARD (p);
768 scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
769 if ((FORWARD (p)) != NO_NODE) {
770 if (is_one_of (p, ELSE_PART, CHOICE, STOP)) {
771 scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
772 } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) {
773 scope_conditional_clause (SUB (p), s);
774 }
775 }
776 }
777
778 //! @brief Scope_case_clause.
779
780 void scope_case_clause (NODE_T * p, SCOPE_T ** s)
781 {
782 SCOPE_T *n = NO_SCOPE;
783 scope_serial_clause (NEXT_SUB (p), &n, A68_TRUE);
784 (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
785 FORWARD (p);
786 scope_statement_list (NEXT_SUB (p), s);
787 if ((FORWARD (p)) != NO_NODE) {
788 if (is_one_of (p, OUT_PART, CHOICE, STOP)) {
789 scope_serial_clause (NEXT_SUB (p), s, A68_TRUE);
790 } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) {
791 scope_case_clause (SUB (p), s);
792 } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) {
793 scope_case_clause (SUB (p), s);
794 }
795 }
796 }
797
798 //! @brief Scope_loop_clause.
799
800 void scope_loop_clause (NODE_T * p)
801 {
802 if (p != NO_NODE) {
803 if (IS (p, FOR_PART)) {
804 scope_loop_clause (NEXT (p));
805 } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) {
806 scope_statement (NEXT_SUB (p), NO_VAR);
807 scope_loop_clause (NEXT (p));
808 } else if (IS (p, WHILE_PART)) {
809 scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE);
810 scope_loop_clause (NEXT (p));
811 } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) {
812 NODE_T *do_p = NEXT_SUB (p), *un_p;
813 if (IS (do_p, SERIAL_CLAUSE)) {
814 scope_serial_clause (do_p, NO_VAR, A68_TRUE);
815 un_p = NEXT (do_p);
816 } else {
817 un_p = do_p;
818 }
819 if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) {
820 scope_serial_clause (NEXT_SUB (un_p), NO_VAR, A68_TRUE);
821 }
822 }
823 }
824 }
825
826 //! @brief Scope_enclosed_clause.
827
828 void scope_enclosed_clause (NODE_T * p, SCOPE_T ** s)
829 {
830 if (IS (p, ENCLOSED_CLAUSE)) {
831 scope_enclosed_clause (SUB (p), s);
832 } else if (IS (p, CLOSED_CLAUSE)) {
833 scope_closed_clause (SUB (p), s);
834 } else if (is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP)) {
835 scope_collateral_clause (SUB (p), s);
836 } else if (IS (p, CONDITIONAL_CLAUSE)) {
837 scope_conditional_clause (SUB (p), s);
838 } else if (is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP)) {
839 scope_case_clause (SUB (p), s);
840 } else if (IS (p, LOOP_CLAUSE)) {
841 scope_loop_clause (SUB (p));
842 }
843 }
844
845 //! @brief Whether a symbol table contains no (anonymous) definition.
846
847 BOOL_T empty_table (TABLE_T * t)
848 {
849 if (IDENTIFIERS (t) == NO_TAG) {
850 return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
851 } else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) {
852 return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
853 } else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) {
854 return (BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
855 } else {
856 return A68_FALSE;
857 }
858 }
859
860 //! @brief Indicate non-local environs.
861
862 void get_non_local_environs (NODE_T * p, int max)
863 {
864 for (; p != NO_NODE; FORWARD (p)) {
865 if (IS (p, ROUTINE_TEXT)) {
866 get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
867 } else if (IS (p, FORMAT_TEXT)) {
868 get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
869 } else {
870 get_non_local_environs (SUB (p), max);
871 NON_LOCAL (p) = NO_TABLE;
872 if (TABLE (p) != NO_TABLE) {
873 TABLE_T *q = TABLE (p);
874 while (q != NO_TABLE && empty_table (q)
875 && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max) {
876 NON_LOCAL (p) = PREVIOUS (q);
877 q = PREVIOUS (q);
878 }
879 }
880 }
881 }
882 }
883
884 //! @brief Scope_checker.
885
886 void scope_checker (NODE_T * p)
887 {
888 // Establish scopes of routine texts and format texts.
889 get_youngest_environs (p);
890 // Find non-local environs.
891 get_non_local_environs (p, PRIMAL_SCOPE);
892 // PROC and FORMAT identities can now be assigned a scope.
893 bind_scope_to_tags (p);
894 // Now check evertyhing else.
895 scope_enclosed_clause (SUB (p), NO_VAR);
896 }
