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