--- /dev/null
+/* Symbol table management.
+ 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/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/*
+ * Symbol table handling, managing TAGS.
+ */
+
+/* Forward declarations for several functions defined below. */
+
+static TAG_T *find_tag_local (TABLE_T *table, int a, const char *name);
+
+/* Set level for procedures. */
+
+void
+a68_set_proc_level (NODE_T *p, int n)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ PROCEDURE_LEVEL (INFO (p)) = n;
+ if (IS (p, ROUTINE_TEXT))
+ a68_set_proc_level (SUB (p), n + 1);
+ else
+ a68_set_proc_level (SUB (p), n);
+ }
+}
+
+/* Set nests for diagnostics. */
+
+void
+a68_set_nest (NODE_T *p, NODE_T *s)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ NEST (p) = s;
+ if (IS (p, PARTICULAR_PROGRAM))
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0)
+ a68_set_nest (SUB (p), p);
+ else
+ a68_set_nest (SUB (p), s);
+ }
+}
+
+/*
+ * Routines that work with tags and symbol tables.
+ */
+
+static void tax_tags (NODE_T *);
+static void tax_specifier_list (NODE_T *);
+static void tax_parameter_list (NODE_T *);
+static void tax_format_texts (NODE_T *);
+
+/* Find a tag, searching symbol tables towards the root. */
+
+int
+a68_first_tag_global (TABLE_T * table, const char *name)
+{
+ if (table != NO_TABLE)
+ {
+ for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return IDENTIFIER;
+ }
+ for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return INDICANT;
+ }
+ for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return LABEL;
+ }
+ for (TAG_T *s = OPERATORS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return OP_SYMBOL;
+ }
+ for (TAG_T *s = MODULES (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return MODULE_SYMBOL;
+ }
+ for (TAG_T *s = PRIO (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return PRIO_SYMBOL;
+ }
+ return a68_first_tag_global (PREVIOUS (table), name);
+ }
+ else
+ return STOP;
+}
+
+/* Whether routine can be "lengthety-mapped". */
+
+static bool
+is_mappable_routine (const char *z)
+{
+#define ACCEPT(u, v) {\
+ if (strlen (u) >= strlen (v)) {\
+ if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\
+ return true;\
+ }}}
+
+ /* Math routines. */
+ ACCEPT (z, "arccos");
+ ACCEPT (z, "arccosdg");
+ ACCEPT (z, "arccot");
+ ACCEPT (z, "arccotdg");
+ ACCEPT (z, "arcsin");
+ ACCEPT (z, "arcsindg");
+ ACCEPT (z, "arctan");
+ ACCEPT (z, "arctandg");
+ ACCEPT (z, "beta");
+ ACCEPT (z, "betainc");
+ ACCEPT (z, "cbrt");
+ ACCEPT (z, "cos");
+ ACCEPT (z, "cosdg");
+ ACCEPT (z, "cospi");
+ ACCEPT (z, "cot");
+ ACCEPT (z, "cot");
+ ACCEPT (z, "cotdg");
+ ACCEPT (z, "cotpi");
+ ACCEPT (z, "curt");
+ ACCEPT (z, "erf");
+ ACCEPT (z, "erfc");
+ ACCEPT (z, "exp");
+ ACCEPT (z, "gamma");
+ ACCEPT (z, "gammainc");
+ ACCEPT (z, "gammaincg");
+ ACCEPT (z, "gammaincgf");
+ ACCEPT (z, "ln");
+ ACCEPT (z, "log");
+ ACCEPT (z, "pi");
+ ACCEPT (z, "sin");
+ ACCEPT (z, "sindg");
+ ACCEPT (z, "sinpi");
+ ACCEPT (z, "sqrt");
+ ACCEPT (z, "tan");
+ ACCEPT (z, "tandg");
+ ACCEPT (z, "tanpi");
+ /* Random generator. */
+ ACCEPT (z, "nextrandom");
+ ACCEPT (z, "random");
+ /* BITS. */
+ ACCEPT (z, "bitspack");
+ /* Enquiries. */
+ ACCEPT (z, "maxint");
+ ACCEPT (z, "intwidth");
+ ACCEPT (z, "maxreal");
+ ACCEPT (z, "realwidth");
+ ACCEPT (z, "expwidth");
+ ACCEPT (z, "maxbits");
+ ACCEPT (z, "bitswidth");
+ ACCEPT (z, "byteswidth");
+ ACCEPT (z, "smallreal");
+ return false;
+#undef ACCEPT
+}
+
+/* Map "short sqrt" onto "sqrt" etcetera. */
+
+static TAG_T *
+bind_lengthety_identifier (const char *u)
+{
+#define CAR(u, v) (strncmp (u, v, strlen(v)) == 0)
+ /* We can only map routines blessed by "is_mappable_routine", so there is no
+ "short print" or "long char in string". */
+ if (CAR (u, "short"))
+ {
+ do
+ {
+ u = &u[strlen ("short")];
+ const char *v = TEXT (a68_add_token (&A68 (top_token), u));
+ TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
+ if (w != NO_TAG && is_mappable_routine (v))
+ return w;
+ }
+ while (CAR (u, "short"));
+ }
+ else if (CAR (u, "long"))
+ {
+ do
+ {
+ u = &u[strlen ("long")];
+ const char *v = TEXT (a68_add_token (&A68 (top_token), u));
+ TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
+ if (w != NO_TAG && is_mappable_routine (v))
+ return w;
+ }
+ while (CAR (u, "long"));
+ }
+
+ return NO_TAG;
+#undef CAR
+}
+
+/* Bind identifier tags to the symbol table. */
+
+static void
+bind_identifier_tag_to_symbol_table (NODE_T * p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ bind_identifier_tag_to_symbol_table (SUB (p));
+
+ if (a68_is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP))
+ {
+ int att = a68_first_tag_global (TABLE (p), NSYMBOL (p));
+
+ if (att == STOP)
+ {
+ TAG_T *z = bind_lengthety_identifier (NSYMBOL (p));
+
+ if (z != NO_TAG)
+ MOID (p) = MOID (z);
+ TAX (p) = z;
+ }
+ else
+ {
+ TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p));
+
+ if (att == IDENTIFIER && z != NO_TAG)
+ MOID (p) = MOID (z);
+ else if (att == LABEL && z != NO_TAG)
+ ;
+ else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG)
+ MOID (p) = MOID (z);
+ else
+ {
+ a68_error (p, "tag S has not been declared properly");
+ z = a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
+ MOID (p) = M_ERROR;
+ }
+ TAX (p) = z;
+ if (IS (p, DEFINING_IDENTIFIER))
+ NODE (z) = p;
+ }
+ }
+ }
+}
+
+/* Tell whether the given tree refers to the applied indicant INDICANT in an
+ actual declarer. */
+
+static bool
+declarer_contains_indicant (NODE_T *p, NODE_T *indicant)
+{
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, DECLARER)
+ && IS (SUB (q), INDICANT)
+ && ((TAX (SUB (q)) && IS_RECURSIVE (TAX (SUB (q))))
+ || IS_LITERALLY (SUB (q), NSYMBOL (indicant))))
+ {
+ return true;
+ }
+
+ if (declarer_contains_indicant (SUB (q), indicant))
+ return true;
+ }
+
+ return false;
+}
+
+/* Bind indicant tags to the symbol table. */
+
+static void
+bind_indicant_tag_to_symbol_table (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ bind_indicant_tag_to_symbol_table (SUB (p));
+
+ if (a68_is_one_of (p, INDICANT, DEFINING_INDICANT, STOP))
+ {
+ TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
+
+ if (z != NO_TAG)
+ {
+ MOID (p) = MOID (z);
+ TAX (p) = z;
+ if (IS (p, DEFINING_INDICANT))
+ {
+ NODE (z) = p;
+ IS_RECURSIVE (z) = declarer_contains_indicant (NEXT_NEXT (p), p);
+ }
+ }
+ }
+ }
+}
+
+/* Enter specifier identifiers in the symbol table. */
+
+static void
+tax_specifiers (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_specifiers (SUB (p));
+
+ if (SUB (p) != NO_NODE && IS (p, SPECIFIER))
+ tax_specifier_list (SUB (p));
+ }
+}
+
+/* Enter specifier identifiers in the symbol table. */
+
+static void
+tax_specifier_list (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, OPEN_SYMBOL))
+ tax_specifier_list (NEXT (p));
+ else if (a68_is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP))
+ ;
+ else if (IS (p, IDENTIFIER))
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER);
+ HEAP (z) = LOC_SYMBOL;
+ }
+ else if (IS (p, DECLARER))
+ {
+ tax_specifiers (SUB (p));
+ tax_specifier_list (NEXT (p));
+ /* last identifier entry is identifier with this declarer. */
+ if (IDENTIFIERS (TABLE (p)) != NO_TAG
+ && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER)
+ MOID (IDENTIFIERS (TABLE (p))) = MOID (p);
+ }
+ }
+}
+
+/* Enter parameter identifiers in the symbol table. */
+
+static void
+tax_parameters (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (SUB (p) != NO_NODE)
+ {
+ tax_parameters (SUB (p));
+ if (IS (p, PARAMETER_PACK))
+ tax_parameter_list (SUB (p));
+ }
+ }
+}
+
+/* Enter parameter identifiers in the symbol table. */
+
+static void
+tax_parameter_list (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+ tax_parameter_list (NEXT (p));
+ else if (IS (p, CLOSE_SYMBOL))
+ ;
+ else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP))
+ {
+ tax_parameter_list (NEXT (p));
+ tax_parameter_list (SUB (p));
+ }
+ else if (IS (p, IDENTIFIER))
+ {
+ /* parameters are always local. */
+ HEAP (a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL;
+ }
+ else if (IS (p, DECLARER))
+ {
+ tax_parameter_list (NEXT (p));
+ /* last identifier entries are identifiers with this declarer. */
+ for (TAG_T *s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s))
+ MOID (s) = MOID (p);
+ tax_parameters (SUB (p));
+ }
+ }
+}
+
+/* Enter FOR identifiers in the symbol table. */
+
+static void
+tax_for_identifiers (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_for_identifiers (SUB (p));
+
+ if (IS (p, FOR_SYMBOL))
+ {
+ if ((FORWARD (p)) != NO_NODE)
+ (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_INT, LOOP_IDENTIFIER);
+ }
+ }
+}
+
+/* Enter routine texts in the symbol table. */
+
+static void
+tax_routine_texts (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_routine_texts (SUB (p));
+
+ if (IS (p, ROUTINE_TEXT))
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT);
+ TAX (p) = z;
+ HEAP (z) = LOC_SYMBOL;
+ USE (z) = true;
+ }
+ }
+}
+
+/* Enter format texts in the symbol table. */
+
+static void
+tax_format_texts (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_format_texts (SUB (p));
+
+ if (IS (p, FORMAT_TEXT))
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_TEXT);
+ TAX (p) = z;
+ USE (z) = true;
+ }
+ else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE)
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_IDENTIFIER);
+ TAX (p) = z;
+ USE (z) = true;
+ }
+ }
+}
+
+/* Enter FORMAT pictures in the symbol table. */
+
+static void
+tax_pictures (NODE_T * p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_pictures (SUB (p));
+
+ if (IS (p, PICTURE))
+ TAX (p) = a68_add_tag (TABLE (p), ANONYMOUS, p, M_COLLITEM, FORMAT_IDENTIFIER);
+ }
+}
+
+/* Enter generators in the symbol table. */
+
+static void
+tax_generators (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ tax_generators (SUB (p));
+
+ if (IS (p, GENERATOR))
+ {
+ if (IS (SUB (p), LOC_SYMBOL))
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR);
+ HEAP (z) = LOC_SYMBOL;
+ USE (z) = true;
+ TAX (p) = z;
+ }
+ }
+ }
+}
+
+/* Find a firmly related operator for operands. */
+
+static TAG_T *
+find_firmly_related_op (TABLE_T *c, const char *n, MOID_T *l, MOID_T *r, TAG_T *self)
+{
+ if (c != NO_TABLE)
+ {
+ TAG_T *s = OPERATORS (c);
+
+ for (; s != NO_TAG; FORWARD (s))
+ {
+ if (s != self && NSYMBOL (NODE (s)) == n)
+ {
+ PACK_T *t = PACK (MOID (s));
+ if (t != NO_PACK && a68_is_firm (MOID (t), l))
+ {
+ /* catch monadic operator. */
+ if ((FORWARD (t)) == NO_PACK)
+ {
+ if (r == NO_MOID)
+ return s;
+ }
+ else
+ {
+ /* catch dyadic operator. */
+ if (r != NO_MOID && a68_is_firm (MOID (t), r))
+ return s;
+ }
+ }
+ }
+ }
+ }
+ return NO_TAG;
+}
+
+/* Check for firmly related operators in this range. */
+
+static void
+test_firmly_related_ops_local (NODE_T *p, TAG_T *s)
+{
+ if (s != NO_TAG)
+ {
+ PACK_T *u = PACK (MOID (s));
+
+ if (u != NO_PACK)
+ {
+ MOID_T *l = MOID (u);
+ MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID);
+ TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s);
+
+ if (t != NO_TAG)
+ {
+ a68_error (p, "M Z is firmly related to M Z",
+ MOID (s), NSYMBOL (NODE (s)), MOID (t),
+ NSYMBOL (NODE (t)));
+ }
+ else
+ {
+ /* Warn for hidden firmly related operators defined in outer
+ ranges, if requested. */
+ for (TABLE_T *prev = PREVIOUS (TAG_TABLE (s));
+ prev != NO_TABLE;
+ prev = PREVIOUS (prev))
+ {
+ TAG_T *t = find_firmly_related_op (prev, NSYMBOL (NODE (s)), l, r,
+ NO_TAG /* self */);
+ if (t != NO_TAG)
+ {
+ if (TAG_TABLE (t) == A68_STANDENV
+ && warn_algol68_hidden_declarations > 0)
+ {
+ if (a68_warning (p, OPT_Whidden_declarations_,
+ "Z hides a firmly related operator in a larger reach",
+ NSYMBOL (NODE (s))))
+ {
+ a68_inform (NO_NODE,
+ "operator M Z defined in the standard prelude",
+ MOID (t), NSYMBOL (NODE (t)));
+ }
+ }
+ else if (warn_algol68_hidden_declarations > 1)
+ {
+ if (a68_warning (p, OPT_Whidden_declarations_,
+ "Z hides a firmly related operator in a larger reach",
+ NSYMBOL (NODE (s))))
+ {
+ a68_inform (NODE (t),
+ "previous hidden declaration of S declared here",
+ NSYMBOL (NODE (s)));
+ }
+ }
+
+ /* Report only one level of hidding or it gets messy. */
+ break;
+ }
+ }
+ }
+ }
+ if (NEXT (s) != NO_TAG)
+ test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s));
+ }
+}
+
+/* Find firmly related operators in this program. */
+
+static void
+test_firmly_related_ops (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+ {
+ TAG_T *oops = OPERATORS (TABLE (SUB (p)));
+
+ if (oops != NO_TAG)
+ test_firmly_related_ops_local (NODE (oops), oops);
+ }
+ test_firmly_related_ops (SUB (p));
+ }
+}
+
+/* Driver for the processing of TAXes. */
+
+void
+a68_collect_taxes (NODE_T *p)
+{
+ tax_tags (p);
+ tax_specifiers (p);
+ tax_parameters (p);
+ tax_for_identifiers (p);
+ tax_routine_texts (p);
+ tax_pictures (p);
+ tax_format_texts (p);
+ tax_generators (p);
+ bind_identifier_tag_to_symbol_table (p);
+ bind_indicant_tag_to_symbol_table (p);
+ test_firmly_related_ops (p);
+ test_firmly_related_ops_local (NO_NODE, OPERATORS (A68_STANDENV));
+}
+
+/* Whether tag has already been declared in this range. */
+
+static void
+already_declared (NODE_T *n, int a)
+{
+ if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG)
+ a68_error (n, "multiple declaration of tag S");
+}
+
+/* Whether tag has already been declared in this range. */
+
+static void
+already_declared_hidden (NODE_T *n, int a)
+{
+ if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG)
+ a68_error (n, "multiple declaration of tag S");
+
+ TAG_T *s = a68_find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n));
+
+ if (s != NO_TAG
+ && ((TAG_TABLE (s) == A68_STANDENV && warn_algol68_hidden_declarations > 0)
+ || (TAG_TABLE (s) != A68_STANDENV && warn_algol68_hidden_declarations > 1)))
+ {
+ if (a68_warning (n, OPT_Whidden_declarations_,
+ "Z hides a declaration with larger reach",
+ NSYMBOL (n)))
+ {
+ if (TAG_TABLE (s) == A68_STANDENV)
+ a68_inform (NO_NODE,
+ "M Z defined in the standard prelude",
+ MOID (s), NSYMBOL (NODE (s)));
+ else
+ a68_inform (NODE (s),
+ "previous hidden declaration of S declared here",
+ NSYMBOL (n));
+ }
+ }
+}
+
+/* Add tag to local symbol table. */
+
+TAG_T *
+a68_add_tag (TABLE_T *s, int a, NODE_T *n, MOID_T *m, int p)
+{
+#define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);}
+ if (s != NO_TABLE)
+ {
+ TAG_T *z = a68_new_tag ();
+
+ TAG_TABLE (z) = s;
+ PRIO (z) = p;
+ MOID (z) = m;
+ NODE (z) = n;
+ /* TAX(n) = z;. */
+ switch (a)
+ {
+ case IDENTIFIER:
+ already_declared_hidden (n, IDENTIFIER);
+ already_declared_hidden (n, LABEL);
+ INSERT_TAG (&IDENTIFIERS (s), z);
+ break;
+ case INDICANT:
+ already_declared_hidden (n, INDICANT);
+ already_declared (n, OP_SYMBOL);
+ already_declared (n, PRIO_SYMBOL);
+ INSERT_TAG (&INDICANTS (s), z);
+ break;
+ case LABEL:
+ already_declared_hidden (n, LABEL);
+ already_declared_hidden (n, IDENTIFIER);
+ INSERT_TAG (&LABELS (s), z);
+ break;
+ case OP_SYMBOL:
+ already_declared (n, INDICANT);
+ INSERT_TAG (&OPERATORS (s), z);
+ break;
+ case MODULE_SYMBOL:
+ already_declared (n, INDICANT);
+ INSERT_TAG (&MODULES (s), z);
+ break;
+ case PRIO_SYMBOL:
+ already_declared (n, PRIO_SYMBOL);
+ already_declared (n, INDICANT);
+ INSERT_TAG (&PRIO (s), z);
+ break;
+ case ANONYMOUS:
+ INSERT_TAG (&ANONYMOUS (s), z);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ return z;
+ }
+ else
+ return NO_TAG;
+}
+
+/* Find a tag, searching symbol tables towards the root. */
+
+TAG_T *
+a68_find_tag_global (TABLE_T *table, int a, const char *name)
+{
+ if (table != NO_TABLE)
+ {
+ TAG_T *s = NO_TAG;
+ switch (a)
+ {
+ case IDENTIFIER:
+ s = IDENTIFIERS (table);
+ break;
+ case INDICANT:
+ s = INDICANTS (table);
+ break;
+ case LABEL:
+ s = LABELS (table);
+ break;
+ case OP_SYMBOL:
+ s = OPERATORS (table);
+ break;
+ case MODULE_SYMBOL:
+ s = MODULES (table);
+ break;
+ case PRIO_SYMBOL:
+ s = PRIO (table);
+ break;
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ for (; s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return s;
+ }
+ return a68_find_tag_global (PREVIOUS (table), a, name);
+ }
+ else
+ return NO_TAG;
+}
+
+/* Whether identifier or label global. */
+
+int
+a68_is_identifier_or_label_global (TABLE_T *table, const char *name)
+{
+ if (table != NO_TABLE)
+ {
+ for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return IDENTIFIER;
+ }
+ for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return LABEL;
+ }
+ return a68_is_identifier_or_label_global (PREVIOUS (table), name);
+ }
+ else
+ return 0;
+}
+
+/* Find a tag, searching only local symbol table. */
+
+static TAG_T *
+find_tag_local (TABLE_T *table, int a, const char *name)
+{
+ if (table != NO_TABLE)
+ {
+ TAG_T *s = NO_TAG;
+
+ if (a == OP_SYMBOL)
+ s = OPERATORS (table);
+ else if (a == MODULE_SYMBOL)
+ s = MODULES (table);
+ else if (a == PRIO_SYMBOL)
+ s = PRIO (table);
+ else if (a == IDENTIFIER)
+ s = IDENTIFIERS (table);
+ else if (a == INDICANT)
+ s = INDICANTS (table);
+ else if (a == LABEL)
+ s = LABELS (table);
+ else
+ gcc_unreachable ();
+
+ for (; s != NO_TAG; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ return s;
+ }
+ }
+ return NO_TAG;
+}
+
+/* Whether context specifies HEAP or LOC for an identifier.
+
+ The boolean *E is set to true if an explicit qualifier was found, false
+ otherwise. */
+
+static int
+tab_qualifier (NODE_T *p, bool *e)
+{
+ *e = false;
+ if (p != NO_NODE)
+ {
+ if (a68_is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP))
+ return tab_qualifier (SUB (p), e);
+ else if (a68_is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, STOP))
+ {
+ *e = true;
+ return ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL;
+ }
+ else
+ return LOC_SYMBOL;
+ }
+ else
+ return LOC_SYMBOL;
+}
+
+/* Enter identity declarations in the symbol table.
+
+ E is true if HEAP or LOC got specified explicitly in the identity
+ declaration's formal parameter. */
+
+static void
+tax_identity_dec (NODE_T *p, MOID_T **m)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, IDENTITY_DECLARATION))
+ {
+ tax_identity_dec (SUB (p), m);
+ tax_identity_dec (NEXT (p), m);
+ }
+ else if (IS (p, DECLARER))
+ {
+ tax_tags (SUB (p));
+ *m = MOID (p);
+ tax_identity_dec (NEXT (p), m);
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ {
+ tax_identity_dec (NEXT (p), m);
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+ gcc_assert (entry != NO_TAG);
+
+ MOID (p) = *m;
+ HEAP (entry) = LOC_SYMBOL;
+ TAX (p) = entry;
+ MOID (entry) = *m;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ bool e;
+ if (ATTRIBUTE (*m) == REF_SYMBOL)
+ {
+ HEAP (entry) = tab_qualifier (NEXT_NEXT (p), &e);
+ if (e && HEAP (entry) == LOC_SYMBOL && PUBLICIZED (entry))
+ a68_warning (p, 0, "value of local generator will be out of scope");
+ }
+ tax_identity_dec (NEXT_NEXT (p), m);
+ }
+ else
+ tax_tags (p);
+ }
+}
+
+/* Enter variable declarations in the symbol table.
+
+ E is true if an explicit sample generator was specified in the variable
+ declaration. */
+
+static void
+tax_variable_dec (NODE_T *p, int *q, MOID_T **m, bool e)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, VARIABLE_DECLARATION))
+ {
+ tax_variable_dec (SUB (p), q, m, e);
+ tax_variable_dec (NEXT (p), q, m, e);
+ }
+ else if (IS (p, DECLARER))
+ {
+ tax_tags (SUB (p));
+ *m = MOID (p);
+ tax_variable_dec (NEXT (p), q, m, e);
+ }
+ else if (IS (p, QUALIFIER))
+ {
+ *q = ATTRIBUTE (SUB (p));
+ tax_variable_dec (NEXT (p), q, m, true);
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ {
+ tax_variable_dec (NEXT (p), q, m, e);
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+ MOID (p) = *m;
+ TAX (p) = entry;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+
+ if (PUBLICIZED (p) && e && *q == LOC_SYMBOL)
+ a68_error (p, "publicized variable should not be allocated on the stack");
+
+ if (PUBLICIZED (p))
+ HEAP (entry) = STATIC_SYMBOL;
+ else
+ HEAP (entry) = *q;
+
+ if (HEAP (entry) == LOC_SYMBOL)
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR);
+ HEAP (z) = LOC_SYMBOL;
+ USE (z) = true;
+ BODY (entry) = z;
+ }
+ else
+ {
+ BODY (entry) = NO_TAG;
+ }
+ MOID (entry) = *m;
+ tax_variable_dec (NEXT (p), q, m, e);
+ }
+ else
+ tax_tags (p);
+ }
+}
+
+/* Enter procedure variable declarations in the symbol table.
+
+ E is true if an explicit sample generator was specified in the procedure
+ variable declaration. */
+
+static void
+tax_proc_variable_dec (NODE_T *p, int *q, bool e)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+ {
+ tax_proc_variable_dec (SUB (p), q, e);
+ tax_proc_variable_dec (NEXT (p), q, e);
+ }
+ else if (IS (p, QUALIFIER))
+ {
+ *q = ATTRIBUTE (SUB (p));
+ tax_proc_variable_dec (NEXT (p), q, true);
+ }
+ else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP))
+ {
+ tax_proc_variable_dec (NEXT (p), q, e);
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+ TAX (p) = entry;
+ MOID (entry) = MOID (p);
+ PUBLICIZED (entry) = PUBLICIZED (p);
+
+ if (PUBLICIZED (p) && e && *q == LOC_SYMBOL)
+ a68_error (p, "publicized variable should not be allocated on the stack");
+
+ if (PUBLICIZED (p))
+ HEAP (entry) = STATIC_SYMBOL;
+ else
+ HEAP (entry) = *q;
+
+ if (HEAP (entry) == LOC_SYMBOL)
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR);
+ HEAP (z) = LOC_SYMBOL;
+ USE (z) = true;
+ BODY (entry) = z;
+ }
+ else
+ {
+ BODY (entry) = NO_TAG;
+ }
+ tax_proc_variable_dec (NEXT (p), q, e);
+ }
+ else
+ tax_tags (p);
+ }
+}
+
+/* Enter procedure declarations in the symbol table. */
+
+static void
+tax_proc_dec (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, PROCEDURE_DECLARATION))
+ {
+ tax_proc_dec (SUB (p));
+ tax_proc_dec (NEXT (p));
+ }
+ else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP))
+ {
+ tax_proc_dec (NEXT (p));
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+ MOID_T *m = MOID (NEXT_NEXT (p));
+ MOID (p) = m;
+ TAX (p) = entry;
+ HEAP (entry) = LOC_SYMBOL;
+ MOID (entry) = m;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ tax_proc_dec (NEXT (p));
+ }
+ else
+ tax_tags (p);
+ }
+}
+
+/* Check validity of operator declaration. */
+
+static void
+check_operator_dec (NODE_T *p, MOID_T *u)
+{
+ int k = 0;
+
+ if (u == NO_MOID)
+ {
+ NODE_T *pack = SUB_SUB (NEXT_NEXT (p)); /* Where the parameter pack
+ is. */
+ if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT)
+ pack = SUB (pack);
+ k = 1 + a68_count_operands (pack);
+ }
+ else
+ k = a68_count_pack_members (PACK (u));
+
+ if (k < 1 || k > 2)
+ {
+ a68_error (p, "incorrect number of operands for S");
+ k = 0;
+ }
+
+ if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT)
+ {
+ a68_error (p, "monadic S cannot start with a character from Z", NOMADS);
+ }
+ else if (k == 2 && !a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p)))
+ {
+ a68_error (p, "dyadic S has no priority declaration");
+ }
+}
+
+/* Enter operator declarations in the symbol table. */
+
+static void
+tax_op_dec (NODE_T *p, MOID_T **m)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, OPERATOR_DECLARATION))
+ {
+ tax_op_dec (SUB (p), m);
+ tax_op_dec (NEXT (p), m);
+ }
+ else if (IS (p, OPERATOR_PLAN))
+ {
+ tax_tags (SUB (p));
+ *m = MOID (p);
+ tax_op_dec (NEXT (p), m);
+ }
+ else if (IS (p, OP_SYMBOL))
+ {
+ tax_op_dec (NEXT (p), m);
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ {
+ tax_op_dec (NEXT (p), m);
+ }
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ TAG_T *entry = OPERATORS (TABLE (p));
+ check_operator_dec (p, *m);
+ while (entry != NO_TAG && NODE (entry) != p)
+ FORWARD (entry);
+ MOID (p) = *m;
+ TAX (p) = entry;
+ HEAP (entry) = LOC_SYMBOL;
+ MOID (entry) = *m;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ tax_op_dec (NEXT (p), m);
+ }
+ else
+ {
+ tax_tags (p);
+ }
+ }
+}
+
+/* Enter module declarations in the symbol table. */
+
+static void
+tax_module_dec (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, MODULE_DECLARATION))
+ {
+ tax_module_dec (SUB (p));
+ tax_module_dec (NEXT (p));
+ }
+ else if (IS (p, MODULE_SYMBOL))
+ {
+ tax_module_dec (NEXT (p));
+ }
+ else if (IS (p, COMMA_SYMBOL))
+ {
+ tax_module_dec (NEXT (p));
+ }
+ else if (IS (p, DEFINING_MODULE_INDICANT))
+ {
+ TAG_T *entry = MODULES (TABLE (p));
+ while (entry != NO_TAG && NODE (entry) != p)
+ FORWARD (entry);
+ MOID (p) = NO_MOID;
+ TAX (p) = entry;
+ HEAP (entry) = LOC_SYMBOL;
+ MOID (entry) = NO_MOID;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ tax_module_dec (NEXT (p));
+ }
+ else
+ {
+ tax_tags (p);
+ }
+ }
+}
+
+/* Enter brief operator declarations in the symbol table. */
+
+static void
+tax_brief_op_dec (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, BRIEF_OPERATOR_DECLARATION))
+ {
+ tax_brief_op_dec (SUB (p));
+ tax_brief_op_dec (NEXT (p));
+ }
+ else if (a68_is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP))
+ {
+ tax_brief_op_dec (NEXT (p));
+ }
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ TAG_T *entry = OPERATORS (TABLE (p));
+ MOID_T *m = MOID (NEXT_NEXT (p));
+ check_operator_dec (p, NO_MOID);
+ while (entry != NO_TAG && NODE (entry) != p)
+ FORWARD (entry);
+ MOID (p) = m;
+ TAX (p) = entry;
+ HEAP (entry) = LOC_SYMBOL;
+ MOID (entry) = m;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ tax_brief_op_dec (NEXT (p));
+ }
+ else
+ {
+ tax_tags (p);
+ }
+ }
+}
+
+/* Enter priority declarations in the symbol table. */
+
+static void tax_prio_dec (NODE_T *p)
+{
+ if (p != NO_NODE)
+ {
+ if (IS (p, PRIORITY_DECLARATION))
+ {
+ tax_prio_dec (SUB (p));
+ tax_prio_dec (NEXT (p));
+ }
+ else if (a68_is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP))
+ {
+ tax_prio_dec (NEXT (p));
+ }
+ else if (IS (p, DEFINING_OPERATOR))
+ {
+ TAG_T *entry = PRIO (TABLE (p));
+ while (entry != NO_TAG && NODE (entry) != p)
+ FORWARD (entry);
+ MOID (p) = NO_MOID;
+ TAX (p) = entry;
+ HEAP (entry) = LOC_SYMBOL;
+ PUBLICIZED (entry) = PUBLICIZED (p);
+ tax_prio_dec (NEXT (p));
+ }
+ else
+ {
+ tax_tags (p);
+ }
+ }
+}
+
+/* Enter TAXes in the symbol table. */
+
+static void
+tax_tags (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ int heap = LOC_SYMBOL;
+ MOID_T *m = NO_MOID;
+
+ if (IS (p, IDENTITY_DECLARATION))
+ tax_identity_dec (p, &m);
+ else if (IS (p, VARIABLE_DECLARATION))
+ tax_variable_dec (p, &heap, &m, false);
+ else if (IS (p, PROCEDURE_DECLARATION))
+ tax_proc_dec (p);
+ else if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+ tax_proc_variable_dec (p, &heap, false);
+ else if (IS (p, OPERATOR_DECLARATION))
+ tax_op_dec (p, &m);
+ else if (IS (p, BRIEF_OPERATOR_DECLARATION))
+ tax_brief_op_dec (p);
+ else if (IS (p, PRIORITY_DECLARATION))
+ tax_prio_dec (p);
+ else if (IS (p, MODULE_DECLARATION))
+ tax_module_dec (p);
+ else
+ tax_tags (SUB (p));
+ }
+}
+
+/* Reset symbol table nest count. */
+
+void
+a68_reset_symbol_table_nest_count (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+ NEST (TABLE (SUB (p))) = A68 (symbol_table_count)++;
+ a68_reset_symbol_table_nest_count (SUB (p));
+ }
+}
+
+//! @brief Bind routines in symbol table to the tree.
+
+void
+a68_bind_routine_tags_to_tree (NODE_T *p)
+{
+ /* By inserting coercions etc. some may have shifted. */
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG)
+ NODE (TAX (p)) = p;
+ a68_bind_routine_tags_to_tree (SUB (p));
+ }
+}
+
+/* Bind formats in symbol table to tree. */
+
+static void
+bind_format_tags_to_tree (NODE_T *p)
+{
+ /* By inserting coercions etc. some may have shifted. */
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG)
+ NODE (TAX (p)) = p;
+ else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG)
+ NODE (TAX (p)) = p;
+
+ bind_format_tags_to_tree (SUB (p));
+ }
+}
+
+/* Fill outer level of symbol table. */
+
+void
+a68_fill_symbol_table_outer (NODE_T *p, TABLE_T *s)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (TABLE (p) != NO_TABLE)
+ OUTER (TABLE (p)) = s;
+
+ if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT))
+ a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
+ else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT))
+ a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
+ else if (SUB (p) != NO_NODE && IS (p, MODULE_TEXT))
+ a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
+ else
+ a68_fill_symbol_table_outer (SUB (p), s);
+ }
+}
+
+/* Flood branch in tree with local symbol table S. */
+
+static void
+flood_with_symbol_table_restricted (NODE_T *p, TABLE_T *s)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ TABLE (p) = s;
+ if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT)
+ {
+ if (a68_is_new_lexical_level (p))
+ PREVIOUS (TABLE (SUB (p))) = s;
+ else
+ flood_with_symbol_table_restricted (SUB (p), s);
+ }
+ }
+}
+
+/* Final structure of symbol table after parsing. */
+
+void
+a68_finalise_symbol_table_setup (NODE_T *p, int l)
+{
+ TABLE_T *s = TABLE (p);
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ /* routine texts are ranges. */
+ if (IS (q, ROUTINE_TEXT))
+ flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s));
+
+ /* specifiers are ranges. */
+ else if (IS (q, SPECIFIED_UNIT))
+ flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s));
+
+ /* level count and recursion. */
+ if (SUB (q) != NO_NODE)
+ {
+ if (a68_is_new_lexical_level (q))
+ {
+ LEX_LEVEL (SUB (q)) = l + 1;
+ gcc_assert (TABLE (SUB (q)) != s);
+ PREVIOUS (TABLE (SUB (q))) = s;
+ a68_finalise_symbol_table_setup (SUB (q), l + 1);
+ if (IS (q, WHILE_PART))
+ {
+ /* This was a bug that went unnoticed for 15 years!. */
+ TABLE_T *s2 = TABLE (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ return;
+ if (IS (q, ALT_DO_PART))
+ {
+ PREVIOUS (TABLE (SUB (q))) = s2;
+ LEX_LEVEL (SUB (q)) = l + 2;
+ a68_finalise_symbol_table_setup (SUB (q), l + 2);
+ }
+ }
+ if (IS (q, DEF_PART))
+ {
+ TABLE_T *s2 = TABLE (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ return;
+ if (IS (q, POSTLUDE_PART))
+ {
+ PREVIOUS (TABLE (SUB (q))) = s2;
+ LEX_LEVEL (SUB (q)) = l + 2;
+ a68_finalise_symbol_table_setup (SUB (q), l + 2);
+ }
+ }
+ }
+ else
+ {
+ TABLE (SUB (q)) = s;
+ a68_finalise_symbol_table_setup (SUB (q), l);
+ }
+ }
+ TABLE (q) = s;
+
+ if (IS (q, FOR_SYMBOL))
+ FORWARD (q);
+ FORWARD (q);
+ }
+
+ /* FOR identifiers are in the DO ... OD range. */
+ for (q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, FOR_SYMBOL))
+ TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q)));
+ }
+}
+
+/* First structure of symbol table for parsing. */
+
+void
+a68_preliminary_symbol_table_setup (NODE_T *p)
+{
+ TABLE_T *s = TABLE (p);
+ bool not_a_for_range = false;
+
+ /* Let the tree point to the current symbol table. */
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ TABLE (q) = s;
+
+ /* insert new tables when required. */
+ for (NODE_T *q = p; q != NO_NODE && !not_a_for_range; FORWARD (q))
+ {
+ if (SUB (q) != NO_NODE)
+ {
+ /* BEGIN ... END, CODE ... EDOC, DO ... OD, $ ... $, { ... } are
+ ranges. */
+ if (a68_is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL,
+ FORMAT_DELIMITER_SYMBOL, STOP))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ /* ( ... ) is a range. */
+ else if (IS (q, OPEN_SYMBOL))
+ {
+ if (a68_whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP))
+ {
+ TABLE (SUB (q)) = s;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ FORWARD (q);
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ not_a_for_range = true;
+ else
+ {
+ if (IS (q, THEN_BAR_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ if (IS (q, OPEN_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ }
+ else
+ {
+ /* Don't worry about STRUCT (...), UNION (...), PROC (...)
+ yet. */
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* IF ... THEN ... ELSE ... FI are ranges. */
+ else if (IS (q, IF_SYMBOL))
+ {
+ if (a68_whether (q, IF_SYMBOL, THEN_SYMBOL, STOP))
+ {
+ TABLE (SUB (q)) = s;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ FORWARD (q);
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ not_a_for_range = true;
+ else
+ if (IS (q, ELSE_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ if (IS (q, IF_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ else
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* CASE ... IN ... OUT ... ESAC are ranges. */
+ else if (IS (q, CASE_SYMBOL))
+ {
+ if (a68_whether (q, CASE_SYMBOL, IN_SYMBOL, STOP))
+ {
+ TABLE (SUB (q)) = s;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ FORWARD (q);
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ not_a_for_range = true;
+ else
+ {
+ if (IS (q, OUT_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ if (IS (q, CASE_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ }
+ else
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (s);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* WHILE ... DO ... OD are ranges. */
+ else if (IS (q, WHILE_SYMBOL))
+ {
+ TABLE_T *u = a68_new_symbol_table (s);
+ TABLE (SUB (q)) = u;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if ((FORWARD (q)) == NO_NODE)
+ not_a_for_range = true;
+ else if (IS (q, ALT_DO_SYMBOL))
+ {
+ TABLE (SUB (q)) = a68_new_symbol_table (u);
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* ACCESS ... DEF ...POSTLUDE ...FED are ranges. */
+ else if (IS (q, ALT_ACCESS_SYMBOL))
+ {
+ TABLE_T *u = a68_new_symbol_table (s);
+ TABLE (SUB (q)) = u;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if (NEXT (q) == NO_NODE)
+ not_a_for_range = true;
+ else if (IS ((FORWARD (q)), DEF_SYMBOL))
+ {
+ TABLE_T *v = a68_new_symbol_table (u);
+ TABLE (SUB (q)) = v;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* DEF ... POSTLUDE ... FED are ranges. */
+ else if (IS (q, DEF_SYMBOL))
+ {
+ TABLE_T *u = a68_new_symbol_table (s);
+ PUBLIC_RANGE (u) = true;
+ TABLE (SUB (q)) = u;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if (NEXT (q) == NO_NODE)
+ not_a_for_range = true;
+ else if (IS ((FORWARD (q)), POSTLUDE_SYMBOL))
+ {
+ TABLE_T *v = a68_new_symbol_table (u);
+ TABLE (SUB (q)) = v;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ /* ACCESS ... CONTROLLED_CLAUSE are ranges. */
+ else if (IS (q, ACCESS_SYMBOL))
+ {
+ TABLE_T *u = a68_new_symbol_table (s);
+ TABLE (SUB (q)) = u;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ if (NEXT (q) == NO_NODE)
+ not_a_for_range = true;
+ }
+ else
+ {
+ TABLE (SUB (q)) = s;
+ a68_preliminary_symbol_table_setup (SUB (q));
+ }
+ }
+ }
+ /* FOR identifiers will go to the DO ... OD range. */
+ if (!not_a_for_range)
+ {
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, FOR_SYMBOL))
+ {
+ NODE_T *r = q;
+ TABLE (NEXT (q)) = NO_TABLE;
+ for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r))
+ {
+ if ((a68_is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP))
+ && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE))
+ {
+ TABLE (NEXT (q)) = TABLE (SUB (r));
+ SEQUENCE (NEXT (q)) = SUB (r);
+ }
+ }
+ }
+ }
+ }
+}
+
+/* Mark a mode as in use. */
+
+static void
+mark_mode (MOID_T *m)
+{
+ if (m != NO_MOID && USE (m) == false)
+ {
+ PACK_T *p = PACK (m);
+ USE (m) = true;
+ for (; p != NO_PACK; FORWARD (p))
+ {
+ mark_mode (MOID (p));
+ mark_mode (SUB (m));
+ mark_mode (SLICE (m));
+ }
+ }
+}
+
+//! @brief Traverse tree and mark modes as used.
+
+void
+a68_mark_moids (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ a68_mark_moids (SUB (p));
+ if (MOID (p) != NO_MOID)
+ mark_mode (MOID (p));
+ }
+}
+
+/* Mark various tags as used. */
+
+void
+a68_mark_auxilliary (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (SUB (p) != NO_NODE)
+ {
+ /* You get no warnings on unused PROC parameters. That is ok since
+ A68 has some parameters that you may not use at all - think of
+ PROC (REF FILE) BOOL event routines in transput. */
+ a68_mark_auxilliary (SUB (p));
+ }
+ else if (IS (p, OPERATOR))
+ {
+ TAG_T *z;
+
+ if (TAX (p) != NO_TAG)
+ USE (TAX (p)) = true;
+
+ if ((z = a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG)
+ USE (z) = true;
+ }
+ else if (IS (p, INDICANT))
+ {
+ TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
+
+ if (z != NO_TAG)
+ {
+ TAX (p) = z;
+ USE (z) = true;
+ }
+ }
+ else if (IS (p, IDENTIFIER))
+ {
+ if (TAX (p) != NO_TAG)
+ USE (TAX (p)) = true;
+ }
+ }
+}
+
+/* Check a single tag. */
+
+static void
+unused (TAG_T *s)
+{
+ for (; s != NO_TAG; FORWARD (s))
+ {
+ if (LINE_NUMBER (NODE (s)) > 0 && !USE (s))
+ a68_warning (NODE (s), OPT_Wunused, "tag S is not used", NODE (s));
+ }
+}
+
+/* Driver for traversing tree and warn for unused tags. */
+
+void
+a68_warn_for_unused_tags (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (SUB (p) != NO_NODE)
+ {
+ if (a68_is_new_lexical_level (p))
+ {
+ unused (MODULES (TABLE (SUB (p))));
+ unused (OPERATORS (TABLE (SUB (p))));
+ unused (PRIO (TABLE (SUB (p))));
+ unused (IDENTIFIERS (TABLE (SUB (p))));
+ unused (LABELS (TABLE (SUB (p))));
+ unused (INDICANTS (TABLE (SUB (p))));
+ }
+ }
+ a68_warn_for_unused_tags (SUB (p));
+ }
+}
+
+/* Mark jumps and procedured jumps. */
+
+void
+a68_jumps_from_procs (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, PROCEDURING))
+ {
+ NODE_T *u = SUB_SUB (p);
+
+ if (IS (u, GOTO_SYMBOL))
+ FORWARD (u);
+ USE (TAX (u)) = true;
+ }
+ else if (IS (p, JUMP))
+ {
+ NODE_T *u = SUB (p);
+
+ if (IS (u, GOTO_SYMBOL))
+ FORWARD (u);
+ if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID)
+ && (a68_find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG))
+ {
+ (void) a68_add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL);
+ a68_error (u, "tag S has not been declared properly");
+ }
+ else
+ USE (TAX (u)) = true;
+ }
+ else
+ a68_jumps_from_procs (SUB (p));
+ }
+}
projects / thirdparty / gcc.git / commitdiff
