--- /dev/null
+/* Extract tags from phrases.
+ 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 "a68.h"
+
+/* This is part of the bottom-up parser. Here is a set of routines that gather
+ definitions from phrases. This way we can apply tags before defining them.
+ These routines do not look very elegant as they have to scan through all kind
+ of symbols to find a pattern that they recognise. */
+
+/* Insert alt equals symbol. */
+
+static void
+insert_alt_equals (NODE_T *p)
+{
+ NODE_T *q = a68_new_node ();
+ *q = *p;
+ INFO (q) = a68_new_node_info ();
+ *INFO (q) = *INFO (p);
+ GINFO (q) = a68_new_genie_info ();
+ *GINFO (q) = *GINFO (p);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), "="));
+ NEXT (p) = q;
+ PREVIOUS (q) = p;
+ if (NEXT (q) != NO_NODE)
+ PREVIOUS (NEXT (q)) = q;
+}
+
+/* Detect redefined keyword. */
+
+static void
+detect_redefined_keyword (NODE_T *p, int construct)
+{
+ if (p != NO_NODE && a68_whether (p, KEYWORD, EQUALS_SYMBOL, STOP))
+ a68_error (p, "attempt to redefine keyword Y in A",
+ NSYMBOL (p), construct);
+}
+
+/* Skip anything until a FED or ALT_ACCESS_SYMBOL is found. */
+
+static NODE_T *
+skip_module_text (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, FED_SYMBOL) || IS (p, ALT_ACCESS_SYMBOL))
+ return p;
+ }
+
+ return NO_NODE;
+}
+
+/* Skip anything until a comma, semicolon or EXIT is found. */
+
+static NODE_T *
+skip_unit (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, COMMA_SYMBOL))
+ return p;
+ else if (IS (p, SEMI_SYMBOL))
+ return p;
+ else if (IS (p, EXIT_SYMBOL))
+ return p;
+ }
+ return NO_NODE;
+}
+
+/* Attribute of entry in symbol table. */
+
+static int
+find_tag_definition (TABLE_T *table, const char *name)
+{
+ if (table != NO_TABLE)
+ {
+ int ret = 0;
+ bool found = false;
+ for (TAG_T *s = INDICANTS (table); s != NO_TAG && !found; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ {
+ ret += INDICANT;
+ found = true;
+ }
+ }
+ found = false;
+ for (TAG_T *s = OPERATORS (table); s != NO_TAG && !found; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ {
+ ret += OPERATOR;
+ found = true;
+ }
+ }
+ found = false;
+ for (TAG_T *s = MODULES (table); s != NO_TAG && !found; FORWARD (s))
+ {
+ if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0)
+ {
+ ret += MODULE_INDICANT;
+ found = true;
+ }
+ }
+
+ if (ret == 0)
+ return find_tag_definition (PREVIOUS (table), name);
+ else
+ return ret;
+ }
+ else
+ return 0;
+}
+
+/* Fill in whether bold tag is operator, indicant or module indicant. */
+
+void
+a68_elaborate_bold_tags (NODE_T *p)
+{
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, BOLD_TAG))
+ {
+ switch (find_tag_definition (TABLE (q), NSYMBOL (q)))
+ {
+ case 0:
+ a68_error (q, "tag S has not been declared properly");
+ break;
+ case INDICANT:
+ ATTRIBUTE (q) = INDICANT;
+ break;
+ case OPERATOR:
+ ATTRIBUTE (q) = OPERATOR;
+ break;
+ case MODULE_INDICANT:
+ ATTRIBUTE (q) = MODULE_INDICANT;
+ break;
+ }
+ }
+ }
+}
+
+/* Skip declarer, or argument pack and declarer. */
+
+static NODE_T *
+skip_pack_declarer (NODE_T *p)
+{
+ /* Skip () REF [] REF FLEX [] [] ... */
+ while (p != NO_NODE
+ && (a68_is_one_of (p, SUB_SYMBOL, OPEN_SYMBOL, REF_SYMBOL,
+ FLEX_SYMBOL, SHORT_SYMBOL, LONG_SYMBOL, STOP)))
+ {
+ FORWARD (p);
+ }
+
+ /* Skip STRUCT (), UNION () or PROC [()]. */
+ if (p != NO_NODE && (a68_is_one_of (p, STRUCT_SYMBOL, UNION_SYMBOL, STOP)))
+ return NEXT (p);
+ else if (p != NO_NODE && IS (p, PROC_SYMBOL))
+ return skip_pack_declarer (NEXT (p));
+ else
+ return p;
+}
+
+/* Extract a revelation. */
+
+static void
+extract_revelation (NODE_T *q, bool is_public ATTRIBUTE_UNUSED)
+{
+ /* Store in the symbol table. */
+ TAG_T *tag = a68_add_tag (TABLE (q), MODULE_SYMBOL, q, NO_MOID, STOP);
+ gcc_assert (tag != NO_TAG);
+ EXPORTED (tag) = false; // XXX depends on PUB!
+ /* Import the MOIF and install it in the tag. */
+ MOIF_T *moif = a68_open_packet (NSYMBOL (q));
+ if (moif == NULL)
+ {
+ a68_error (q, "cannot find module Z", NSYMBOL (q));
+ return;
+ }
+ MOIF (tag) = moif; // XXX add to existing list of moifs.
+
+ /* Store all the modes from the MOIF in the moid list.
+
+ The front-end depends on being able to compare any two modes by pointer
+ value. For example, the parser mode equivalence and coercion code relies
+ on this. The lowerer also relies on this to make sure the same lowered
+ trees are used for the same modes. */
+
+ for (MOID_T *m : MODES (moif))
+ {
+ /* Note that m == NO_MOID if the imported mode was already known to the
+ compiler and has been replaced. */
+ if (m != NO_MOID)
+ {
+ MOID_T *r = a68_register_extra_mode (&TOP_MOID (&A68_JOB), m);
+ if (r != m)
+ gcc_unreachable ();
+ }
+ }
+
+ /* Store mode indicants from the MOIF in the symbol table,
+ and also in the moid list. */
+ for (EXTRACT_T *e : INDICANTS (moif))
+ {
+ /* Indicants stored in the indicants area of a symbol
+ table are expected to be INDICANT nodes originating in
+ parsing, with the following subtree:
+
+ INDICANT - EQUALS_SYMBOL - DECLARER
+
+ where MOID (DECLARER) is determined to be the mode
+ associated by INDICANT, or its "equivalent" mode.
+ Therefore we have to synthesize something like that
+ here, since the mode comes from a module interface and
+ we don't have a declarer tree for it.. */
+
+ /* INDICANT node. */
+ NODE_T *n = a68_some_node (a68_demangle_symbol (NAME (moif),
+ EXTRACT_SYMBOL (e)));
+ /* EQUALS_SYMBOL node. */
+ NEXT (n) = a68_some_node ("=");
+ ATTRIBUTE (NEXT (n)) = EQUALS_SYMBOL;
+ /* DECLARER node. */
+ NEXT (NEXT (n)) = a68_some_node ("");
+ LINE (INFO (n)) = LINE (INFO (q));
+ NCHAR_IN_LINE (n) = STRING (LINE (INFO (n)));
+ MOID (NEXT (NEXT (n))) = EXTRACT_MODE (e);
+ TABLE (n) = TABLE (q);
+
+ /* Now add the INDICANT subtree to the symbol table of
+ this access clause lexical level. */
+ TAG_T *tag = a68_add_tag (TABLE (q), INDICANT, n, NO_MOID, 0);
+ gcc_assert (tag != NO_TAG);
+
+ /* Finally add the mode indicant to the moids list. Note
+ that the mode in DECLARER is associated to the
+ INDICANT in the table at some point later, via
+ EQUIVALENT. Hence the NO_MOID in the call to
+ a68_add_mode. */
+ MOID_T *effective_mode = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT,
+ 0, n, NO_MOID, NO_PACK);
+ gcc_assert (effective_mode != NO_MOID);
+ }
+
+ /* Store priorities from the MOIF. */
+ for (EXTRACT_T *e : PRIOS (moif))
+ {
+ NODE_T *n
+ = a68_some_node (a68_demangle_symbol (NAME (moif),
+ EXTRACT_SYMBOL (e)));
+ /* XXX sensible location somehow? */
+ LINE (INFO (n)) = LINE (INFO (q));
+ NCHAR_IN_LINE (n) = STRING (LINE (INFO (n)));
+ TABLE (n) = TABLE (q);
+ TAG_T *tag = a68_add_tag (TABLE (q), PRIO_SYMBOL, n, NO_MOID,
+ EXTRACT_PRIO (e));
+ gcc_assert (tag != NO_TAG);
+ MOIF (tag) = moif; // XXX add to existing list of moifs.
+ }
+
+ /* Store identifiers from the MOIF. */
+ for (EXTRACT_T *e : IDENTIFIERS (moif))
+ {
+ NODE_T *n
+ = a68_some_node (a68_demangle_symbol (NAME (moif),
+ EXTRACT_SYMBOL (e)));
+ /* XXX sensible location somehow? */
+ LINE (INFO (n)) = LINE (INFO (q));
+ NCHAR_IN_LINE (n) = STRING (LINE (INFO (n)));
+ TABLE (n) = TABLE (q);
+
+ TAG_T *tag = a68_add_tag (TABLE (q), IDENTIFIER,
+ n, EXTRACT_MODE (e), NORMAL_IDENTIFIER);
+ gcc_assert (tag != NO_TAG);
+ EXTERN_SYMBOL (tag) = ggc_strdup (EXTRACT_SYMBOL (e));
+ VARIABLE (tag) = VARIABLE (e);
+ IN_PROC (tag) = IN_PROC (e);
+ HEAP (tag) = STATIC_SYMBOL;
+ MOIF (tag) = moif;
+ }
+
+ /* Store operators from the MOIF. */
+ for (EXTRACT_T *e : OPERATORS (moif))
+ {
+ NODE_T *n
+ = a68_some_node (a68_demangle_symbol (NAME (moif),
+ EXTRACT_SYMBOL (e),
+ true /* operator */));
+ MOID (n) = EXTRACT_MODE (e);
+ LINE (INFO (n)) = LINE (INFO (q));
+ NCHAR_IN_LINE (n) = STRING (LINE (INFO (n)));
+ TABLE (n) = TABLE (q);
+ TAG_T *tag = a68_add_tag (TABLE (q), OP_SYMBOL,
+ n, EXTRACT_MODE (e), STOP);
+ gcc_assert (tag != NO_TAG);
+ VARIABLE (tag) = VARIABLE (e);
+ IN_PROC (tag) = IN_PROC (e);
+ HEAP (tag) = STATIC_SYMBOL;
+ MOIF (tag) = moif;
+ EXTERN_SYMBOL (tag) = ggc_strdup (EXTRACT_SYMBOL (e));
+ }
+}
+
+/* Search [MODE|MODULE] A = .., B = ..
+ and ACCESS A, B, ..
+ and store indicants. */
+
+void
+a68_extract_indicants (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (IS (q, ACCESS_SYMBOL) || IS (q, ALT_ACCESS_SYMBOL))
+ {
+ /* An access clause implies the declaration of module indicants,
+ provided they are found in a suitable packet. */
+ do
+ {
+ FORWARD (q);
+ detect_redefined_keyword (q, MODE_DECLARATION);
+ if (IS (q, BOLD_TAG))
+ {
+ extract_revelation (q, false /* is_public */);
+ FORWARD (q);
+ }
+ else if (a68_whether (q, PUBLIC_SYMBOL, BOLD_TAG, STOP))
+ {
+ extract_revelation (q, true /* is_public */);
+ FORWARD (q);
+ FORWARD (q);
+ }
+ }
+ while (q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else if (IS (q, MODULE_SYMBOL))
+ {
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ detect_redefined_keyword (q, MODE_DECLARATION);
+ if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP))
+ {
+ /* Store in the symbol table.
+ XXX also add to global list of modules?
+ Position of definition (q) connects to this lexical
+ level! */
+ ATTRIBUTE (q) = DEFINING_MODULE_INDICANT;
+ TAG_T *tag = a68_add_tag (TABLE (p), MODULE_SYMBOL, q, NO_MOID, STOP);
+ gcc_assert (tag != NO_TAG);
+ EXPORTED (tag) = true;
+ FORWARD (q);
+ ATTRIBUTE (q) = EQUALS_SYMBOL; /* XXX why not ALT_EQUALS_SYMBOL */
+ q = skip_module_text (NEXT (q));
+ FORWARD (q);
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else if (IS (q, MODE_SYMBOL))
+ {
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ detect_redefined_keyword (q, MODE_DECLARATION);
+ if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP))
+ {
+ /* Store in the symbol table, but also in the moid list.
+ Position of definition (q) connects to this lexical
+ level! */
+ if (a68_add_tag (TABLE (p), INDICANT, q, NO_MOID, STOP) == NO_TAG)
+ gcc_unreachable ();
+ if (a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, q, NO_MOID, NO_PACK) == NO_MOID)
+ gcc_unreachable ();
+ ATTRIBUTE (q) = DEFINING_INDICANT;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ q = skip_pack_declarer (NEXT (q));
+ FORWARD (q);
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+#define GET_PRIORITY(q, k) \
+ do \
+ { \
+ errno=0; \
+ (k) = atoi (NSYMBOL (q)); \
+ if (errno != 0) { \
+ a68_error ((q), "invalid priority declaration"); \
+ (k) = MAX_PRIORITY; \
+ } else if ((k) < 1 || (k) > MAX_PRIORITY) { \
+ a68_error ((q), "invalid priority declaration"); \
+ (k) = MAX_PRIORITY; \
+ } \
+ } \
+ while (0)
+
+/* Search PRIO X = .., Y = .. and store priorities. */
+
+void
+a68_extract_priorities (NODE_T *p)
+{
+ NODE_T *q = p;
+ while (q != NO_NODE)
+ {
+ if (IS (q, PRIO_SYMBOL))
+ {
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ detect_redefined_keyword (q, PRIORITY_DECLARATION);
+ /* An operator tag like ++ or && gives strange errors so we catch
+ it here. */
+ if (a68_whether (q, OPERATOR, OPERATOR, STOP))
+ {
+ NODE_T *y = q;
+ a68_error (q, "invalid operator tag");
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ /* Remove one superfluous operator, and hope it was only
+ one. */
+ NEXT (q) = NEXT_NEXT (q);
+ PREVIOUS (NEXT (q)) = q;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ FORWARD (q);
+ int k;
+ GET_PRIORITY (q, k);
+ ATTRIBUTE (q) = PRIORITY;
+ if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+ gcc_unreachable ();
+ FORWARD (q);
+ }
+ else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, INT_DENOTATION, STOP)
+ || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+ {
+ NODE_T *y = q;
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ FORWARD (q);
+ int k;
+ GET_PRIORITY (q, k);
+ ATTRIBUTE (q) = PRIORITY;
+ if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+ gcc_unreachable ();
+ FORWARD (q);
+ }
+ else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP))
+ {
+ siga = false;
+ }
+ else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+ {
+ NODE_T *y = q;
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ FORWARD (q);
+ int k;
+ GET_PRIORITY (q, k);
+ ATTRIBUTE (q) = PRIORITY;
+ if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+ gcc_unreachable ();
+ FORWARD (q);
+ } else if (a68_whether (q, BOLD_TAG, INT_DENOTATION, STOP)
+ || a68_whether (q, OPERATOR, INT_DENOTATION, STOP)
+ || a68_whether (q, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+ {
+ /* The scanner cannot separate operator and "=" sign so we do this here. */
+ int len = (int) strlen (NSYMBOL (q));
+ if (len > 1 && NSYMBOL (q)[len - 1] == '=')
+ {
+ NODE_T *y = q;
+ char *sym = (char *) xmalloc ((size_t) (len + 1));
+ a68_bufcpy (sym, NSYMBOL (q), len + 1);
+ sym[len - 1] = '\0';
+ NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym));
+ free (sym);
+ if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=')
+ a68_error (q, "probably a missing symbol near invalid operator S");
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ insert_alt_equals (q);
+ q = NEXT_NEXT (q);
+ int k;
+ GET_PRIORITY (q, k);
+ ATTRIBUTE (q) = PRIORITY;
+ if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+ gcc_unreachable ();
+ FORWARD (q);
+ }
+ else
+ siga = false;
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+/* Search OP [( .. ) ..] X = .., Y = .. and store operators. */
+
+void
+a68_extract_operators (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (!IS (q, OP_SYMBOL))
+ FORWARD (q);
+ else
+ {
+ bool siga = true;
+ bool in_proc = true;
+ /* Skip operator plan. */
+ if (NEXT (q) != NO_NODE && IS (NEXT (q), OPEN_SYMBOL))
+ {
+ q = skip_pack_declarer (NEXT (q));
+ in_proc = false;
+ }
+ /* Sample operators. */
+ if (q != NO_NODE)
+ {
+ do
+ {
+ FORWARD (q);
+ detect_redefined_keyword (q, OPERATOR_DECLARATION);
+ /* Unacceptable operator tags like ++ or && could give
+ strange errors. */
+ if (a68_whether (q, OPERATOR, OPERATOR, STOP))
+ {
+ a68_error (q, "invalid operator tag");
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+ if (t == NO_TAG)
+ gcc_unreachable ();
+ IN_PROC (t) = in_proc;
+ /* Remove one superfluous operator, and hope it was only one. */
+ NEXT (q) = NEXT_NEXT (q);
+ PREVIOUS (NEXT (q)) = q;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, STOP)
+ || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, STOP))
+ {
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+ if (t == NO_TAG)
+ gcc_unreachable ();
+ IN_PROC (t) = in_proc;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP))
+ {
+ siga = false;
+ }
+ else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP))
+ {
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+ if (t == NO_TAG)
+ gcc_unreachable ();
+ IN_PROC (t) = in_proc;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else if (q != NO_NODE && (a68_is_one_of (q, OPERATOR, BOLD_TAG, EQUALS_SYMBOL, STOP)))
+ {
+ /* The scanner cannot separate operator and "=" sign so
+ we do this here. */
+ int len = (int) strlen (NSYMBOL (q));
+ if (len > 1 && NSYMBOL (q)[len - 1] == '=')
+ {
+ char *sym = (char *) xmalloc ((size_t) (len + 1));
+ a68_bufcpy (sym, NSYMBOL (q), len + 1);
+ sym[len - 1] = '\0';
+ NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym));
+ if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=')
+ a68_error (q, "probably a missing symbol near invalid operator S");
+ ATTRIBUTE (q) = DEFINING_OPERATOR;
+ insert_alt_equals (q);
+ TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+ if (t == NO_TAG)
+ gcc_unreachable ();
+ IN_PROC (t) = in_proc;
+ FORWARD (q);
+ q = skip_unit (q);
+ }
+ else
+ siga = false;
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ }
+ }
+}
+
+/* Search and store labels. */
+
+void
+a68_extract_labels (NODE_T *p, int expect)
+{
+ /* Only handle candidate phrases as not to search indexers!. */
+ if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE)
+ {
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (a68_whether (q, IDENTIFIER, COLON_SYMBOL, STOP))
+ {
+ TAG_T *z = a68_add_tag (TABLE (p), LABEL, q, NO_MOID, LOCAL_LABEL);
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ UNIT (z) = NO_NODE;
+ }
+ }
+ }
+}
+
+/* Search MOID x = .., y = .. and store identifiers. */
+
+static void
+extract_identities (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (a68_whether (q, DECLARER, IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ bool siga = true;
+ do
+ {
+ if (a68_whether ((FORWARD (q)), IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+ if (tag == NO_TAG)
+ gcc_unreachable ();
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ FORWARD (q);
+ ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+ {
+ /* Handle common error in ALGOL 68 programs. */
+ a68_error (q, "mixed identity-declaration and variable-declaration");
+ if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+ gcc_unreachable ();
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+/* Search MOID x [:= ..], y [:= ..] and store identifiers. */
+
+static void
+extract_variables (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (a68_whether (q, HEAP_SYMBOL, DECLARER, IDENTIFIER, STOP)
+ || a68_whether (q, LOC_SYMBOL, DECLARER, IDENTIFIER, STOP)
+ || a68_whether (q, DECLARER, IDENTIFIER, STOP))
+ {
+ if (!IS (q, DECLARER))
+ FORWARD (q);
+
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ if (a68_whether (q, IDENTIFIER, STOP))
+ {
+ if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ /* Handle common error in ALGOL 68 programs. */
+ a68_error (q, "mixed identity-declaration and variable-declaration");
+ ATTRIBUTE (NEXT (q)) = ASSIGN_SYMBOL;
+ }
+ TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+ if (tag == NO_TAG)
+ gcc_unreachable ();
+ VARIABLE (tag) = true;
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ q = skip_unit (q);
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+/* Search PROC x = .., y = .. and stores identifiers. */
+
+static void
+extract_proc_identities (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ TAG_T *t = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+ IN_PROC (t) = true;
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+ {
+ /* Handle common error in ALGOL 68 programs. */
+ a68_error (q, "mixed identity-declaration and variable-declaration");
+ if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+ gcc_unreachable ();
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+ q = skip_unit (q);
+ }
+ else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+/* Search PROC x [:= ..], y [:= ..]; store identifiers. */
+
+static void
+extract_proc_variables (NODE_T *p)
+{
+ NODE_T *q = p;
+
+ while (q != NO_NODE)
+ {
+ if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, STOP))
+ {
+ bool siga = true;
+ do
+ {
+ FORWARD (q);
+ if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+ {
+ TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+ gcc_assert (tag != NO_TAG);
+ VARIABLE (tag) = true;
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ q = skip_unit (FORWARD (q));
+ }
+ else if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+ {
+ /* Handle common error in ALGOL 68 programs. */
+ a68_error (q, "mixed identity-declaration and variable-declaration");
+ TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+ gcc_assert (tag != NO_TAG);
+ ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+ ATTRIBUTE (FORWARD (q)) = ASSIGN_SYMBOL;
+ q = skip_unit (q);
+ } else
+ siga = false;
+ }
+ while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+ }
+ else
+ FORWARD (q);
+ }
+}
+
+/* Schedule gathering of definitions in a phrase. */
+
+void
+a68_extract_declarations (NODE_T *p)
+{
+ /* Get definitions so we know what is defined in this range. */
+ extract_identities (p);
+ extract_variables (p);
+ extract_proc_identities (p);
+ extract_proc_variables (p);
+ /* By now we know whether "=" is an operator or not. */
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, EQUALS_SYMBOL))
+ ATTRIBUTE (q) = OPERATOR;
+ else if (IS (q, ALT_EQUALS_SYMBOL))
+ ATTRIBUTE (q) = EQUALS_SYMBOL;
+ }
+
+ /* Get qualifiers. */
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (a68_whether (q, LOC_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP))
+ a68_make_sub (q, q, QUALIFIER);
+ if (a68_whether (q, HEAP_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP))
+ a68_make_sub (q, q, QUALIFIER);
+ if (a68_whether (q, LOC_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP))
+ a68_make_sub (q, q, QUALIFIER);
+ if (a68_whether (q, HEAP_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP))
+ a68_make_sub (q, q, QUALIFIER);
+ }
+
+ /* Give priorities to operators. */
+ for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+ {
+ if (IS (q, OPERATOR))
+ {
+ if (a68_find_tag_global (TABLE (q), OP_SYMBOL, NSYMBOL (q)))
+ {
+ TAG_T *s = a68_find_tag_global (TABLE (q), PRIO_SYMBOL, NSYMBOL (q));
+
+ if (s != NO_TAG)
+ PRIO (INFO (q)) = PRIO (s);
+ else
+ PRIO (INFO (q)) = 0;
+ }
+ else
+ {
+ a68_error (q, "tag S has not been declared properly");
+ PRIO (INFO (q)) = 1;
+ }
+ }
+ }
+}
projects / thirdparty / gcc.git / commitdiff
