Signed-off-by: Jose E. Marchesi <[email protected]> Co-authored-by: Marcel van der Veer <[email protected]> --- gcc/algol68/a68-parser-scope.cc | 975 ++++++++++++++++++++++++++++++++ 1 file changed, 975 insertions(+) create mode 100644 gcc/algol68/a68-parser-scope.cc
diff --git a/gcc/algol68/a68-parser-scope.cc b/gcc/algol68/a68-parser-scope.cc new file mode 100644 index 00000000000..990e7ec857e --- /dev/null +++ b/gcc/algol68/a68-parser-scope.cc @@ -0,0 +1,975 @@ +/* Static scope checker. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + <http://www.gnu.org/licenses/>. */ + +/* A static scope checker inspects the source. Note that ALGOL 68 also needs + dynamic scope checking. This phase concludes the parser. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +typedef struct TUPLE_T TUPLE_T; +typedef struct SCOPE_T SCOPE_T; + +struct TUPLE_T +{ + int level; + bool transient; +}; + +struct SCOPE_T +{ + NODE_T *where; + TUPLE_T tuple; + SCOPE_T *next; +}; + +enum { NOT_TRANSIENT = 0, TRANSIENT }; + +static void gather_scopes_for_youngest (NODE_T *, SCOPE_T **); +static void scope_statement (NODE_T *, SCOPE_T **); +static void scope_enclosed_clause (NODE_T *, SCOPE_T **); +static void scope_formula (NODE_T *, SCOPE_T **); +static void scope_routine_text (NODE_T *, SCOPE_T **); + +/* + * Static scope checker. + */ + +/* Scope_make_tuple. */ + +static TUPLE_T +scope_make_tuple (int e, int t) +{ + static TUPLE_T z; + LEVEL (&z) = e; + TRANSIENT (&z) = t; + return z; +} + +/* Link scope information into the list. */ + +static void +scope_add (SCOPE_T **sl, NODE_T *p, TUPLE_T tup) +{ + if (sl != NO_VAR) + { + SCOPE_T *ns = (SCOPE_T *) xmalloc (sizeof (SCOPE_T)); + WHERE (ns) = p; + TUPLE (ns) = tup; + NEXT (ns) = *sl; + *sl = ns; + } +} + +/* Scope_check. */ + +static bool +scope_check (SCOPE_T *top, int mask, int dest) +{ + int errors = 0; + + /* Transient names cannot be stored. */ + if (mask & TRANSIENT) + { + for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) + { + if (TRANSIENT (&TUPLE (s)) & TRANSIENT) + { + a68_error (WHERE (s), "attempt at storing a transient name"); + STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); + errors++; + } + } + } + + /* Potential scope violations. */ + for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) + { + if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) + { + MOID_T *ws = MOID (WHERE (s)); + + if (ws != NO_MOID) + { + if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL)) + a68_warning (WHERE (s), OPT_Wscope, "M A is a potential scope violation", + MOID (WHERE (s)), ATTRIBUTE (WHERE (s))); + } + STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); + errors++; + } + } + return (errors == 0); +} + +/* Scope_check_multiple. */ + +static bool +scope_check_multiple (SCOPE_T *top, int mask, SCOPE_T *dest) +{ + bool no_err = true; + + for (; dest != NO_SCOPE; FORWARD (dest)) + no_err = no_err && scope_check (top, mask, LEVEL (&TUPLE (dest))); + return no_err; +} + +/* Check_identifier_usage. */ + +static void +check_identifier_usage (TAG_T *t, NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL) + a68_warning (p, OPT_Wuninitialized, "identifier S might be used uninitialised"); + check_identifier_usage (t, SUB (p)); + } +} + +/* Scope_find_youngest_outside. */ + +static TUPLE_T +scope_find_youngest_outside (SCOPE_T *s, int treshold) +{ + TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT); + + for (; s != NO_SCOPE; FORWARD (s)) + { + if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold) + z = TUPLE (s); + } + return z; +} + +/* Scope_find_youngest. */ + +static TUPLE_T +scope_find_youngest (SCOPE_T *s) +{ + return scope_find_youngest_outside (s, INT_MAX); +} + +/* + * Routines for determining scope of ROUTINE TEXT or FORMAT TEXT. + */ + +/* Get_declarer_elements. */ + +static void +get_declarer_elements (NODE_T *p, SCOPE_T **r, bool no_ref) +{ + if (p != NO_NODE) + { + if (IS (p, BOUNDS)) + gather_scopes_for_youngest (SUB (p), r); + else if (IS (p, INDICANT)) + { + if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref) + scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + else if (IS_REF (p)) + get_declarer_elements (NEXT (p), r, false); + else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) + ; + else + { + get_declarer_elements (SUB (p), r, no_ref); + get_declarer_elements (NEXT (p), r, no_ref); + } + } +} + +/* Gather_scopes_for_youngest. */ + +static void +gather_scopes_for_youngest (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if ((a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) + && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE)) + { + SCOPE_T *t = NO_SCOPE; + TUPLE_T tup; + + gather_scopes_for_youngest (SUB (p), &t); + tup = scope_find_youngest_outside (t, LEX_LEVEL (p)); + YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); + /* Direct link into list iso "gather_scopes_for_youngest (SUB (p), + s);". */ + if (t != NO_SCOPE) + { + SCOPE_T *u = t; + while (NEXT (u) != NO_SCOPE) { + FORWARD (u); + } + NEXT (u) = *s; + (*s) = t; + } + } + else if (a68_is_one_of (p, IDENTIFIER, OPERATOR, STOP)) + { + if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE) + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + else if (IS (p, DECLARER)) + get_declarer_elements (p, s, true); + else + gather_scopes_for_youngest (SUB (p), s); + } +} + +/* Get_youngest_environs. */ + +static void +get_youngest_environs (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) + { + SCOPE_T *s = NO_SCOPE; + TUPLE_T tup; + gather_scopes_for_youngest (SUB (p), &s); + tup = scope_find_youngest_outside (s, LEX_LEVEL (p)); + YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); + } + else + get_youngest_environs (SUB (p)); + } +} + +/* Bind_scope_to_tag. */ + +static void +bind_scope_to_tag (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT) + { + if (IS (NEXT_NEXT (p), FORMAT_TEXT)) + { + SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + if (IS (NEXT_NEXT (p), ROUTINE_TEXT)) + { + SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + else + bind_scope_to_tag (SUB (p)); + } +} + +/* Bind_scope_to_tags. */ + +static void +bind_scope_to_tags (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) + bind_scope_to_tag (SUB (p)); + else + bind_scope_to_tags (SUB (p)); + } +} + +/* Scope_bounds. */ + +static void +scope_bounds (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + scope_statement (p, NO_VAR); + else + scope_bounds (SUB (p)); + } +} + +/* Scope_declarer. */ + +static void +scope_declarer (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, BOUNDS)) + scope_bounds (SUB (p)); + else if (IS (p, INDICANT)) + ; + else if (IS_REF (p)) + scope_declarer (NEXT (p)); + else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) + ; + else + { + scope_declarer (SUB (p)); + scope_declarer (NEXT (p)); + } + } +} + +/* Scope_identity_declaration. */ + +static void +scope_identity_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_identity_declaration (SUB (p)); + + if (IS (p, DEFINING_IDENTIFIER)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + TUPLE_T tup; + int z = PRIMAL_SCOPE; + + if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL) + check_identifier_usage (TAX (p), unit); + scope_statement (unit, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + tup = scope_find_youngest (s); + z = LEVEL (&tup); + if (z < LEX_LEVEL (p)) + { + SCOPE (TAX (p)) = z; + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + } +} + +/* Scope_variable_declaration. */ + +static void +scope_variable_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_variable_declaration (SUB (p)); + if (IS (p, DECLARER)) + scope_declarer (SUB (p)); + else if (IS (p, DEFINING_IDENTIFIER)) + { + if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + check_identifier_usage (TAX (p), unit); + scope_statement (unit, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + return; + } + } + } +} + +/* Scope_procedure_declaration. */ + +static void +scope_procedure_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_procedure_declaration (SUB (p)); + + if (a68_is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + + scope_statement (unit, &s); + (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p)); + return; + } + } +} + +/* Scope_declaration_list. */ + +static void +scope_declaration_list (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTITY_DECLARATION)) + scope_identity_declaration (SUB (p)); + else if (IS (p, VARIABLE_DECLARATION)) + scope_variable_declaration (SUB (p)); + else if (IS (p, MODE_DECLARATION)) + scope_declarer (SUB (p)); + else if (IS (p, PRIORITY_DECLARATION)) + ; + else if (IS (p, PROCEDURE_DECLARATION)) + scope_procedure_declaration (SUB (p)); + else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + scope_procedure_declaration (SUB (p)); + else if (a68_is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP)) + scope_procedure_declaration (SUB (p)); + else + { + scope_declaration_list (SUB (p)); + scope_declaration_list (NEXT (p)); + } + } +} + +/* Scope_arguments. */ + +static void +scope_arguments (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + SCOPE_T *s = NO_SCOPE; + scope_statement (p, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + } + else + scope_arguments (SUB (p)); + } +} + +/* Is_coercion. */ + +static bool +is_coercion (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DEPROCEDURING: + case DEREFERENCING: + case UNITING: + case ROWING: + case WIDENING: + case VOIDING: + case PROCEDURING: + return true; + default: + return false; + } + } + else + return false; +} + +/* Scope_coercion. */ + +static void +scope_coercion (NODE_T *p, SCOPE_T **s) +{ + if (is_coercion (p)) + { + if (IS (p, VOIDING)) + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, DEREFERENCING)) + /* Leave this to the dynamic scope checker. */ + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, DEPROCEDURING)) + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, ROWING)) + { + SCOPE_T *z = NO_SCOPE; + + scope_coercion (SUB (p), &z); + (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); + if (IS_REF_FLEX (MOID (SUB (p)))) + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); + } + else if (IS (p, PROCEDURING)) + { + /* Can only be a JUMP. */ + NODE_T *q = SUB_SUB (p); + if (IS (q, GOTO_SYMBOL)) + FORWARD (q); + + scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT)); + } + else if (IS (p, UNITING)) + { + SCOPE_T *z = NO_SCOPE; + + scope_coercion (SUB (p), &z); + if (z != NO_SCOPE) + { + (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); + scope_add (s, p, scope_find_youngest (z)); + } + } + else + scope_coercion (SUB (p), s); + } + else + scope_statement (p, s); +} + +/* Scope_format_text. */ + +static void +scope_format_text (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, FORMAT_PATTERN)) + scope_enclosed_clause (SUB (NEXT_SUB (p)), s); + else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE) + scope_enclosed_clause (SUB_NEXT (p), s); + else if (IS (p, DYNAMIC_REPLICATOR)) + scope_enclosed_clause (SUB (NEXT_SUB (p)), s); + else + scope_format_text (SUB (p), s); + } +} + +/* Scope_operand. */ + +static void +scope_operand (NODE_T *p, SCOPE_T **s) +{ + if (IS (p, MONADIC_FORMULA)) + scope_operand (NEXT_SUB (p), s); + else if (IS (p, FORMULA)) + scope_formula (p, s); + else if (IS (p, SECONDARY)) + scope_statement (SUB (p), s); +} + +/* Scope_formula. */ + +static void +scope_formula (NODE_T *p, SCOPE_T **s) +{ + NODE_T *q = SUB (p); + SCOPE_T *s2 = NO_SCOPE; + + scope_operand (q, &s2); + (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p)); + if (NEXT (q) != NO_NODE) + { + SCOPE_T *s3 = NO_SCOPE; + scope_operand (NEXT_NEXT (q), &s3); + (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p)); + } + (void) s; +} + +/* Scope_routine_text. */ + +static void +scope_routine_text (NODE_T *p, SCOPE_T **s) +{ + NODE_T *q = SUB (p); + NODE_T *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q); + SCOPE_T *x = NO_SCOPE; + + scope_statement (NEXT_NEXT (routine), &x); + (void) scope_check (x, TRANSIENT, LEX_LEVEL (p)); + TUPLE_T routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT); + scope_add (s, p, routine_tuple); +} + +/* Scope_statement. */ + +static void +scope_statement (NODE_T *p, SCOPE_T **s) +{ + if (is_coercion (p)) + scope_coercion (p, s); + else if (a68_is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) + scope_statement (SUB (p), s); + else if (a68_is_one_of (p, NIHIL, STOP)) + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + else if (IS (p, DENOTATION)) + ; + else if (IS (p, IDENTIFIER)) + { + if (IS_REF (MOID (p))) + { + if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT)); + else + { + if (HEAP (TAX (p)) == HEAP_SYMBOL) + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + else if (SCOPE_ASSIGNED (TAX (p))) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + } + else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == true) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + else if (MOID (p) == M_FORMAT && SCOPE_ASSIGNED (TAX (p)) == true) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + } + else if (IS (p, ENCLOSED_CLAUSE)) + scope_enclosed_clause (SUB (p), s); + else if (IS (p, CALL)) + { + SCOPE_T *x = NO_SCOPE; + + scope_statement (SUB (p), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + scope_arguments (NEXT_SUB (p)); + } + else if (IS (p, SLICE)) + { + SCOPE_T *x = NO_SCOPE; + MOID_T *m = MOID (SUB (p)); + + if (IS_REF (m)) + { + if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) + scope_statement (SUB (p), s); + else + { + scope_statement (SUB (p), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + } + if (IS_FLEX (SUB (m))) + scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + scope_bounds (SUB (NEXT_SUB (p))); + } + if (IS_REF (MOID (p))) + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, FORMAT_TEXT)) + { + SCOPE_T *x = NO_SCOPE; + scope_format_text (SUB (p), &x); + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, CAST)) + { + SCOPE_T *x = NO_SCOPE; + scope_enclosed_clause (SUB (NEXT_SUB (p)), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, SELECTION)) + { + SCOPE_T *ns = NO_SCOPE; + scope_statement (NEXT_SUB (p), &ns); + (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p)); + if (a68_is_ref_refety_flex (MOID (NEXT_SUB (p)))) + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + scope_add (s, p, scope_find_youngest (ns)); + } + else if (IS (p, GENERATOR)) + { + if (IS (SUB (p), LOC_SYMBOL)) + { + if (NON_LOCAL (p) != NO_TABLE) + scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); + } + else + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + scope_declarer (SUB (NEXT_SUB (p))); + } + else if (IS (p, FORMULA)) + scope_formula (p, s); + else if (IS (p, ASSIGNATION)) + { + NODE_T *unit = NEXT (NEXT_SUB (p)); + SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE; + TUPLE_T tup; + scope_statement (SUB_SUB (p), &nd); + scope_statement (unit, &ns); + (void) scope_check_multiple (ns, TRANSIENT, nd); + tup = scope_find_youngest (nd); + scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT)); + } + else if (IS (p, ROUTINE_TEXT)) + scope_routine_text (p, s); + else if (a68_is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP)) + { + SCOPE_T *n = NO_SCOPE; + scope_statement (SUB (p), &n); + scope_statement (NEXT (NEXT_SUB (p)), &n); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + } + else if (IS (p, ASSERTION)) + { + SCOPE_T *n = NO_SCOPE; + scope_enclosed_clause (SUB (NEXT_SUB (p)), &n); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + } + else if (a68_is_one_of (p, JUMP, SKIP, STOP)) + { + ; + } +} + +/* Scope_statement_list. */ + +static void +scope_statement_list (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + scope_statement (p, s); + else + scope_statement_list (SUB (p), s); + } +} + +/* Scope_serial_clause. */ + +static void +scope_serial_clause (NODE_T *p, SCOPE_T **s, bool terminator) +{ + if (p != NO_NODE) + { + if (IS (p, INITIALISER_SERIES)) + { + scope_serial_clause (SUB (p), s, false); + scope_serial_clause (NEXT (p), s, terminator); + } + else if (IS (p, DECLARATION_LIST)) + scope_declaration_list (SUB (p)); + else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) + scope_serial_clause (NEXT (p), s, terminator); + else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) + { + if (NEXT (p) != NO_NODE) + { + int j = ATTRIBUTE (NEXT (p)); + if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL) + scope_serial_clause (SUB (p), s, true); + else + scope_serial_clause (SUB (p), s, false); + } + else + scope_serial_clause (SUB (p), s, true); + scope_serial_clause (NEXT (p), s, terminator); + } + else if (IS (p, LABELED_UNIT)) + scope_serial_clause (SUB (p), s, terminator); + else if (IS (p, UNIT)) + { + if (terminator) + scope_statement (p, s); + else + scope_statement (p, NO_VAR); + } + } +} + +/* Scope_closed_clause. */ + +static void +scope_closed_clause (NODE_T *p, SCOPE_T **s) +{ + if (p != NO_NODE) + { + if (IS (p, SERIAL_CLAUSE)) + scope_serial_clause (p, s, true); + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) + scope_closed_clause (NEXT (p), s); + } +} + +/* Scope_collateral_clause. */ + +static void +scope_collateral_clause (NODE_T *p, SCOPE_T **s) +{ + if (p != NO_NODE) + { + if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) + || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) + { + scope_statement_list (p, s); + } + } +} + +/* Scope_conditional_clause. */ + +static void +scope_conditional_clause (NODE_T *p, SCOPE_T **s) +{ + scope_serial_clause (NEXT_SUB (p), NO_VAR, true); + FORWARD (p); + scope_serial_clause (NEXT_SUB (p), s, true); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP)) + scope_serial_clause (NEXT_SUB (p), s, true); + else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) + scope_conditional_clause (SUB (p), s); + } +} + +/* Scope_case_clause. */ + +static void +scope_case_clause (NODE_T *p, SCOPE_T **s) +{ + SCOPE_T *n = NO_SCOPE; + scope_serial_clause (NEXT_SUB (p), &n, true); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + FORWARD (p); + scope_statement_list (NEXT_SUB (p), s); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + scope_serial_clause (NEXT_SUB (p), s, true); + else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) + scope_case_clause (SUB (p), s); + else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) + scope_case_clause (SUB (p), s); + } +} + +/* Scope_loop_clause. */ + +static void +scope_loop_clause (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, FOR_PART)) + scope_loop_clause (NEXT (p)); + else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) + { + scope_statement (NEXT_SUB (p), NO_VAR); + scope_loop_clause (NEXT (p)); + } + else if (IS (p, WHILE_PART)) + { + scope_serial_clause (NEXT_SUB (p), NO_VAR, true); + scope_loop_clause (NEXT (p)); + } + else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP)) + { + NODE_T *do_p = NEXT_SUB (p); + + if (IS (do_p, SERIAL_CLAUSE)) + scope_serial_clause (do_p, NO_VAR, true); + } + } +} + +/* Scope_enclosed_clause. */ + +static void +scope_enclosed_clause (NODE_T *p, SCOPE_T **s) +{ + if (IS (p, ENCLOSED_CLAUSE)) + scope_enclosed_clause (SUB (p), s); + else if (IS (p, CLOSED_CLAUSE)) + scope_closed_clause (SUB (p), s); + else if (a68_is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP)) + scope_collateral_clause (SUB (p), s); + else if (IS (p, CONDITIONAL_CLAUSE)) + scope_conditional_clause (SUB (p), s); + else if (a68_is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP)) + scope_case_clause (SUB (p), s); + else if (IS (p, LOOP_CLAUSE)) + scope_loop_clause (SUB (p)); +} + +/* Whether a symbol table contains no (anonymous) definition. */ + +static bool +empty_table (TABLE_T * t) +{ + if (IDENTIFIERS (t) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else + return false; +} + +/* Indicate non-local environs. */ + +static void +get_non_local_environs (NODE_T *p, int max) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, ROUTINE_TEXT)) + get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); + else if (IS (p, FORMAT_TEXT)) + get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); + else + { + get_non_local_environs (SUB (p), max); + NON_LOCAL (p) = NO_TABLE; + if (TABLE (p) != NO_TABLE) + { + TABLE_T *q = TABLE (p); + while (q != NO_TABLE && empty_table (q) + && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max) + { + NON_LOCAL (p) = PREVIOUS (q); + q = PREVIOUS (q); + } + } + } + } +} + +/* The static scope checker. */ + +void +a68_scope_checker (NODE_T *p) +{ + /* Establish scopes of routine texts and format texts. */ + get_youngest_environs (p); + /* Find non-local environs. */ + get_non_local_environs (p, PRIMAL_SCOPE); + /* PROC and FORMAT identities can now be assigned a scope. */ + bind_scope_to_tags (p); + /* Now check evertyhing else. */ + scope_enclosed_clause (SUB (p), NO_VAR); +} -- 2.30.2
