This commit adds the parsing support code and the entry point to the parser.
Signed-off-by: Jose E. Marchesi <[email protected]> Co-authored-by: Marcel van der Veer <[email protected]> --- gcc/algol68/a68-parser.cc | 1134 +++++++++++++++++++++++++++++++++++++ 1 file changed, 1134 insertions(+) create mode 100644 gcc/algol68/a68-parser.cc diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc new file mode 100644 index 00000000000..04ce9db78ed --- /dev/null +++ b/gcc/algol68/a68-parser.cc @@ -0,0 +1,1134 @@ +/* ALGOL 68 parser. + 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/>. */ + +/* + This is a Mailloux-type parser driver. + + The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar + that incorporates, as syntactical rules, the semantical rules in + other languages. Examples are correct use of symbols, modes and + scope. + + This code constitutes an effective "VW Algol 68 parser". A + pragmatic approach was chosen since in the early days of Algol 68, + many "ab initio" implementations failed, probably because + techniques to parse a language like Algol 68 had yet to be + invented. + + This is a Mailloux-type parser, in the sense that it scans a + "phrase" for definitions needed for parsing. Algol 68 allows for + tags to be used before they are defined, which gives freedom in + top-down programming. + + B. J. Mailloux. On the implementation of Algol 68. + Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968]. + + Technically, Mailloux's approach renders the two-level grammar + LALR. + + First part of the parser is the scanner. The source file is read, is + tokenised. The result is a linear list of tokens that is input for the + parser, that will transform the linear list into a syntax tree. + + This front-end tokenises all symbols before the bottom-up parser is invoked. + This means that scanning does not use information from the parser. The + scanner does of course some rudimentary parsing. + + The scanner supports two stropping regimes: "bold" (or "upper") and + "quote". Examples of both: + + bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END + + quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END' + + Quote stropping was used frequently in the (excusez-le-mot) + punch-card age. Hence, bold stropping is the default. There also + existed point stropping, but that has not been implemented here. + + Next part of the parser is a recursive-descent type to check + parenthesis. Also a first set-up is made of symbol tables, needed + by the bottom-up parser. Next part is the bottom-up parser, that + parses without knowing modes while parsing and reducing. It can + therefore not exchange "[]" with "()" as was blessed by the Revised + Report. This is solved by treating CALL and SLICE as equivalent for + the moment and letting the mode checker sort it out later. + + Parsing progresses in various phases to avoid spurious diagnostics + from a recovering parser. Every phase "tightens" the grammar more. + An error in any phase makes the parser quit when that phase ends. + The parser is forgiving in case of superfluous semicolons. + + These are the parser phases: + + (1) Parenthesis are checked to see whether they match. Then, a top-down + parser determines the basic-block structure of the program + so symbol tables can be set up that the bottom-up parser will consult + as you can define things before they are applied. + + (2) A bottom-up parser resolves the structure of the program. + + (3) After the symbol tables have been finalised, a small rearrangement of the + tree may be required where JUMPs have no GOTO. This leads to the + non-standard situation that JUMPs without GOTO can have the syntactic + position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also + does not check VICTAL correctness of declarers. This is done separately. + + The parser sets up symbol tables and populates them as far as needed to parse + the source. After the bottom-up parser terminates succesfully, the symbol tables + are completed. + + (4) Next, modes are collected and rules for well-formedness and structural + equivalence are applied. Then the symbol-table is completed now moids are + all known. + + (5) Next phases are the mode checker and coercion inserter. The syntax tree is + traversed to determine and check all modes, and to select operators. Then + the tree is traversed again to insert coercions. + + (6) A static scope checker detects where objects are transported out of scope. + At run time, a dynamic scope checker will check that what the static scope + checker cannot see. + + (7) A serial-clause dynamic stack allocation (DSA) phase annotates the + serial clauses that contain phrases whose elaboration may result in + dynamic stack adjustments. +*/ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "diagnostic.h" +#include "tree.h" + +#include "a68.h" + +/* Global state kept by the parser. */ + +PARSER_T a68_parser_state; + +/* A few forward declarations of functions defined below. */ + +static void make_special_mode (MOID_T ** n, int m); +static void tie_label_to_serial (NODE_T *p); +static void tie_label_to_unit (NODE_T *p); + +/* Is_ref_refety_flex. */ + +bool +a68_is_ref_refety_flex (MOID_T *m) +{ + if (IS_REF_FLEX (m)) + return true; + else if (IS_REF (m)) + return a68_is_ref_refety_flex (SUB (m)); + else + return false; +} + +/* Count number of operands in operator parameter list. */ + +int +a68_count_operands (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, DECLARER)) + return a68_count_operands (NEXT (p)); + else if (IS (p, COMMA_SYMBOL)) + return 1 + a68_count_operands (NEXT (p)); + else + return a68_count_operands (NEXT (p)) + a68_count_operands (SUB (p)); + } + else + return 0; +} + +/* Count formal bounds in declarer in tree. */ + +int +a68_count_formal_bounds (NODE_T * p) +{ + if (p == NO_NODE) + return 0; + else + { + if (IS (p, COMMA_SYMBOL)) + return 1; + else + return a68_count_formal_bounds (NEXT (p)) + a68_count_formal_bounds (SUB (p)); + } +} + +/* Count pictures. */ + +void +a68_count_pictures (NODE_T *p, int *k) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, PICTURE)) + (*k)++; + a68_count_pictures (SUB (p), k); + } +} + +/* Whether token cannot follow semicolon or EXIT. */ + +bool +a68_is_semicolon_less (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case BUS_SYMBOL: + case CLOSE_SYMBOL: + case END_SYMBOL: + case SEMI_SYMBOL: + case EXIT_SYMBOL: + case THEN_BAR_SYMBOL: + case ELSE_BAR_SYMBOL: + case THEN_SYMBOL: + case ELIF_SYMBOL: + case ELSE_SYMBOL: + case FI_SYMBOL: + case IN_SYMBOL: + case OUT_SYMBOL: + case OUSE_SYMBOL: + case ESAC_SYMBOL: + case OD_SYMBOL: + return true; + default: + return false; + } +} + +/* Whether formal bounds. */ + +bool +a68_is_formal_bounds (NODE_T *p) +{ + if (p == NO_NODE) + return true; + + switch (ATTRIBUTE (p)) + { + case OPEN_SYMBOL: + case CLOSE_SYMBOL: + case SUB_SYMBOL: + case BUS_SYMBOL: + case COMMA_SYMBOL: + case COLON_SYMBOL: + case INT_DENOTATION: + case IDENTIFIER: + case OPERATOR: + return (a68_is_formal_bounds (SUB (p)) + && a68_is_formal_bounds (NEXT (p))); + default: + return false; + } +} + +/* Whether token terminates a unit. */ + +bool +a68_is_unit_terminator (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case BUS_SYMBOL: + case CLOSE_SYMBOL: + case END_SYMBOL: + case SEMI_SYMBOL: + case EXIT_SYMBOL: + case COMMA_SYMBOL: + case THEN_BAR_SYMBOL: + case ELSE_BAR_SYMBOL: + case THEN_SYMBOL: + case ELIF_SYMBOL: + case ELSE_SYMBOL: + case FI_SYMBOL: + case IN_SYMBOL: + case OUT_SYMBOL: + case OUSE_SYMBOL: + case ESAC_SYMBOL: + return true; + default: + return false; + } +} + +/* Whether token is a unit-terminator in a loop clause. */ + +bool +a68_is_loop_keyword (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case FOR_SYMBOL: + case FROM_SYMBOL: + case BY_SYMBOL: + case TO_SYMBOL: + case WHILE_SYMBOL: + case DO_SYMBOL: + return true; + default: + return false; + } +} + +/* Get good attribute. */ + +enum a68_attribute +a68_get_good_attribute (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case UNIT: + case TERTIARY: + case SECONDARY: + case PRIMARY: + return a68_get_good_attribute (SUB (p)); + default: + return ATTRIBUTE (p); + } +} + +/* Preferably don't put intelligible diagnostic here. */ + +bool +a68_dont_mark_here (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ALT_DO_SYMBOL: + case ALT_EQUALS_SYMBOL: + case ANDF_SYMBOL: + case ASSERT_SYMBOL: + case ASSIGN_SYMBOL: + case ASSIGN_TO_SYMBOL: + case AT_SYMBOL: + case BEGIN_SYMBOL: + case BITS_SYMBOL: + case BOLD_COMMENT_SYMBOL: + case BOLD_PRAGMAT_SYMBOL: + case BOLD_COMMENT_BEGIN_SYMBOL: + case BOLD_COMMENT_END_SYMBOL: + case BOOL_SYMBOL: + case BUS_SYMBOL: + case BY_SYMBOL: + case BYTES_SYMBOL: + case CASE_SYMBOL: + case CHANNEL_SYMBOL: + case CHAR_SYMBOL: + case CLOSE_SYMBOL: + case COLON_SYMBOL: + case COMMA_SYMBOL: + case COMPLEX_SYMBOL: + case COMPL_SYMBOL: + case DO_SYMBOL: + case ELIF_SYMBOL: + case ELSE_BAR_SYMBOL: + case ELSE_SYMBOL: + case EMPTY_SYMBOL: + case END_SYMBOL: + case EQUALS_SYMBOL: + case ESAC_SYMBOL: + case EXIT_SYMBOL: + case FALSE_SYMBOL: + case FILE_SYMBOL: + case FI_SYMBOL: + case FLEX_SYMBOL: + case FOR_SYMBOL: + case FROM_SYMBOL: + case GO_SYMBOL: + case GOTO_SYMBOL: + case HEAP_SYMBOL: + case IF_SYMBOL: + case IN_SYMBOL: + case INT_SYMBOL: + case ISNT_SYMBOL: + case IS_SYMBOL: + case LOC_SYMBOL: + case LONG_SYMBOL: + case MAIN_SYMBOL: + case MODE_SYMBOL: + case NIL_SYMBOL: + case OD_SYMBOL: + case OF_SYMBOL: + case OPEN_SYMBOL: + case OP_SYMBOL: + case ORF_SYMBOL: + case OUSE_SYMBOL: + case OUT_SYMBOL: + case PAR_SYMBOL: + case POINT_SYMBOL: + case PRIO_SYMBOL: + case PROC_SYMBOL: + case REAL_SYMBOL: + case REF_SYMBOL: + case ROWS_SYMBOL: + case ROW_SYMBOL: + case SEMA_SYMBOL: + case SEMI_SYMBOL: + case SHORT_SYMBOL: + case SKIP_SYMBOL: + case STRING_SYMBOL: + case STRUCT_SYMBOL: + case STYLE_I_COMMENT_SYMBOL: + case STYLE_II_COMMENT_SYMBOL: + case STYLE_I_PRAGMAT_SYMBOL: + case SUB_SYMBOL: + case THEN_BAR_SYMBOL: + case THEN_SYMBOL: + case TO_SYMBOL: + case TRUE_SYMBOL: + case UNION_SYMBOL: + case VOID_SYMBOL: + case WHILE_SYMBOL: + case SERIAL_CLAUSE: + case ENQUIRY_CLAUSE: + case INITIALISER_SERIES: + case DECLARATION_LIST: + return true; + default: + return false; + } +} + +/* Renumber nodes in the given subtree P, starting with number N. */ + +static void +renumber_nodes (NODE_T *p, int *n) +{ + for (; p != NO_NODE; FORWARD (p)) + { + NUMBER (p) = (*n)++; + renumber_nodes (SUB (p), n); + } +} + +/* Parse an ALGOL 68 source file. */ + +void +a68_parser (const char *filename) +{ + int renum = 0; + + /* Initialisation. */ + A68 (top_keyword) = NO_KEYWORD; + A68 (top_token) = NO_TOKEN; + A68_PARSER (error_tag) = (TAG_T *) a68_new_tag (); + TOP_NODE (&A68_JOB) = NO_NODE; + TOP_MOID (&A68_JOB) = NO_MOID; + TOP_LINE (&A68_JOB) = NO_LINE; + STANDENV_MOID (&A68_JOB) = NO_MOID; + a68_set_up_tables (); + ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0; + + /* Tokeniser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + bool ok = a68_lexical_analyser (filename); + + if (!ok) + return; + + /* An empty file is not a valid program. */ + if (TOP_NODE (&A68_JOB) == NO_NODE) + { + a68_error (NO_NODE, "file is empty, expected a program"); + return; + } + + TREE_LISTING_SAFE (&A68_JOB) = true; + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Final initialisations. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + A68_STANDENV = NO_TABLE; + a68_init_postulates (); + A68 (mode_count) = 0; + make_special_mode (&M_HIP, A68 (mode_count)++); + make_special_mode (&M_UNDEFINED, A68 (mode_count)++); + make_special_mode (&M_ERROR, A68 (mode_count)++); + make_special_mode (&M_VACUUM, A68 (mode_count)++); + make_special_mode (&M_C_STRING, A68 (mode_count)++); + make_special_mode (&M_COLLITEM, A68 (mode_count)++); + } + + /* Top-down parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_check_parenthesis (TOP_NODE (&A68_JOB)); + if (ERROR_COUNT (&A68_JOB) == 0) + { + if (OPTION_BRACKETS (&A68_JOB)) + a68_substitute_brackets (TOP_NODE (&A68_JOB)); + A68 (symbol_table_count) = 0; + A68_STANDENV = a68_new_symbol_table (NO_TABLE); + LEVEL (A68_STANDENV) = 0; + a68_top_down_parser (TOP_NODE (&A68_JOB)); + } + + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Standard environment builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + TABLE (TOP_NODE (&A68_JOB)) = a68_new_symbol_table (A68_STANDENV); + a68_make_standard_environ (); + STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB); + } + + /* Bottom-up parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_preliminary_symbol_table_setup (TOP_NODE (&A68_JOB)); + a68_bottom_up_parser (TOP_NODE (&A68_JOB)); + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_bottom_up_error_check (TOP_NODE (&A68_JOB)); + a68_victal_checker (TOP_NODE (&A68_JOB)); + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2); + NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; + a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); + a68_fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB))); + a68_set_nest (TOP_NODE (&A68_JOB), NO_NODE); + a68_set_proc_level (TOP_NODE (&A68_JOB), 1); + } + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Mode table builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_make_moid_list (&A68_JOB); + CROSS_REFERENCE_SAFE (&A68_JOB) = true; + + /* Symbol table builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_collect_taxes (TOP_NODE (&A68_JOB)); + + /* Post parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_rearrange_goto_less_jumps (TOP_NODE (&A68_JOB)); + + /* Mode checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_mode_checker (TOP_NODE (&A68_JOB)); + + /* Coercion inserter. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_coercion_inserter (TOP_NODE (&A68_JOB)); + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Application checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_mark_moids (TOP_NODE (&A68_JOB)); + a68_mark_auxilliary (TOP_NODE (&A68_JOB)); + a68_jumps_from_procs (TOP_NODE (&A68_JOB)); + a68_warn_for_unused_tags (TOP_NODE (&A68_JOB)); + } + + /* Static scope checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + tie_label_to_serial (TOP_NODE (&A68_JOB)); + tie_label_to_unit (TOP_NODE (&A68_JOB)); + a68_bind_routine_tags_to_tree (TOP_NODE (&A68_JOB)); + a68_scope_checker (TOP_NODE (&A68_JOB)); + } + + /* Serial dynamic stack allocation checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_serial_dsa (TOP_NODE (&A68_JOB)); + } + + /* Finalise syntax tree. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + int num = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &num); + NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; + a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); + } +} + +/* New_node_info. */ + +NODE_INFO_T * +a68_new_node_info (void) +{ + NODE_INFO_T *z = (NODE_INFO_T *) xmalloc (sizeof (NODE_INFO_T)); + + A68 (new_node_infos)++; + PROCEDURE_LEVEL (z) = 0; + CHAR_IN_LINE (z) = NO_TEXT; + SYMBOL (z) = NO_TEXT; + PRAGMENT (z) = NO_TEXT; + PRAGMENT_TYPE (z) = 0; + LINE (z) = NO_LINE; + return z; +} + +/* New_genie_info. */ + +GINFO_T * +a68_new_genie_info (void) +{ + GINFO_T *z = (GINFO_T *) xmalloc (sizeof (GINFO_T)); + + A68 (new_genie_infos)++; + PARTIAL_PROC (z) = NO_MOID; + PARTIAL_LOCALE (z) = NO_MOID; + return z; +} + +/* Allocate and return a new parse tree node with proper defaults. */ + +NODE_T * +a68_new_node (void) +{ + NODE_T *z = (NODE_T *) xmalloc (sizeof (NODE_T)); + + A68 (new_nodes)++; + TABLE (z) = NO_TABLE; + INFO (z) = NO_NINFO; + GINFO (z) = NO_GINFO; + ATTRIBUTE (z) = STOP; + ANNOTATION (z) = STOP; + MOID (z) = NO_MOID; + NEXT (z) = NO_NODE; + PREVIOUS (z) = NO_NODE; + SUB (z) = NO_NODE; + NEST (z) = NO_NODE; + NON_LOCAL (z) = NO_TABLE; + TAX (z) = NO_TAG; + SEQUENCE (z) = NO_NODE; + PACK (z) = NO_PACK; + CDECL (z) = NULL_TREE; + DYNAMIC_STACK_ALLOCS (z) = false; + return z; +} + +/* Some_node. */ + +NODE_T * +a68_some_node (const char *t) +{ + NODE_T *z = a68_new_node (); + INFO (z) = a68_new_node_info (); + GINFO (z) = a68_new_genie_info (); + NSYMBOL (z) = t; + return z; +} + +/* New_symbol_table. */ + +TABLE_T * +a68_new_symbol_table (TABLE_T *p) +{ + TABLE_T *z = (TABLE_T *) xmalloc (sizeof (TABLE_T)); + + NUM (z) = A68 (symbol_table_count); + LEVEL (z) = A68 (symbol_table_count)++; + NEST (z) = A68 (symbol_table_count); + ATTRIBUTE (z) = 0; + INITIALISE_FRAME (z) = true; + PROC_OPS (z) = true; + INITIALISE_ANON (z) = true; + PREVIOUS (z) = p; + OUTER (z) = NO_TABLE; + IDENTIFIERS (z) = NO_TAG; + OPERATORS (z) = NO_TAG; + PRIO (z) = NO_TAG; + INDICANTS (z) = NO_TAG; + LABELS (z) = NO_TAG; + ANONYMOUS (z) = NO_TAG; + JUMP_TO (z) = NO_NODE; + SEQUENCE (z) = NO_NODE; + return z; +} + +/* New_moid. */ + +MOID_T * +a68_new_moid (void) +{ + MOID_T *z = (MOID_T *) xmalloc (sizeof (MOID_T)); + + A68 (new_modes)++; + ATTRIBUTE (z) = 0; + NUMBER (z) = 0; + DIM (z) = 0; + USE (z) = false; + HAS_ROWS (z) = false; + PORTABLE (z) = true; + DERIVATE (z) = false; + NODE (z) = NO_NODE; + PACK (z) = NO_PACK; + SUB (z) = NO_MOID; + EQUIVALENT_MODE (z) = NO_MOID; + SLICE (z) = NO_MOID; + TRIM (z) = NO_MOID; + DEFLEXED (z) = NO_MOID; + NAME (z) = NO_MOID; + MULTIPLE_MODE (z) = NO_MOID; + NEXT (z) = NO_MOID; + CTYPE (z) = NULL_TREE; + return z; +} + +/* New_pack. */ + +PACK_T * +a68_new_pack (void) +{ + PACK_T *z = (PACK_T *) xmalloc (sizeof (PACK_T)); + + MOID (z) = NO_MOID; + TEXT (z) = NO_TEXT; + NODE (z) = NO_NODE; + NEXT (z) = NO_PACK; + PREVIOUS (z) = NO_PACK; + return z; +} + +/* New_tag. */ + +TAG_T * +a68_new_tag (void) +{ + TAG_T *z = (TAG_T *) xmalloc (sizeof (TAG_T)); + + STATUS (z) = NULL_MASK; + TAG_TABLE (z) = NO_TABLE; + MOID (z) = NO_MOID; + NODE (z) = NO_NODE; + UNIT (z) = NO_NODE; + VALUE (z) = NO_TEXT; + SCOPE (z) = PRIMAL_SCOPE; + SCOPE_ASSIGNED (z) = false; + PRIO (z) = 0; + USE (z) = false; + IN_PROC (z) = false; + HEAP (z) = false; + YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE; + LOC_ASSIGNED (z) = false; + NEXT (z) = NO_TAG; + BODY (z) = NO_TAG; + PORTABLE (z) = true; + VARIABLE (z) = false; + IS_RECURSIVE (z) = false; + ASCRIBED_ROUTINE_TEXT (z) = false; + LOWERER (z) = NO_LOWERER; + TAX_TREE_DECL (z) = NULL_TREE; + NUMBER (z) = ++A68_PARSER (tag_number); + return z; +} + +/* Make special, internal mode. */ + +static void +make_special_mode (MOID_T ** n, int m) +{ + (*n) = a68_new_moid (); + ATTRIBUTE (*n) = 0; + NUMBER (*n) = m; + PACK (*n) = NO_PACK; + SUB (*n) = NO_MOID; + EQUIVALENT (*n) = NO_MOID; + DEFLEXED (*n) = NO_MOID; + NAME (*n) = NO_MOID; + SLICE (*n) = NO_MOID; + TRIM (*n) = NO_MOID; + ROWED (*n) = NO_MOID; +} + +/* Whether attributes match in subsequent nodes. */ + +bool +a68_whether (NODE_T * p, ...) +{ + va_list vl; + va_start (vl, p); + int a; + while ((a = va_arg (vl, int)) != STOP) + { + if (p != NO_NODE && a == WILDCARD) + FORWARD (p); + else if (p != NO_NODE && (a == KEYWORD)) + { + if (a68_find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD) + FORWARD (p); + else + { + va_end (vl); + return false; + } + } + else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) + FORWARD (p); + else + { + va_end (vl); + return false; + } + } + va_end (vl); + return true; +} + +/* Whether one of a series of attributes matches a node. */ + +bool +a68_is_one_of (NODE_T *p, ...) +{ + if (p != NO_NODE) + { + bool match = false; + int a; + + va_list vl; + va_start (vl, p); + while ((a = va_arg (vl, int)) != STOP) + match = (match | IS (p, a)); + va_end (vl); + return match; + } + else + return false; +} + + +/* Isolate nodes p-q making p a branch to p-q + + From x - p - a - b - c - q - y + To x - t - y + | + p - a - b - c - q +*/ + +void +a68_make_sub (NODE_T *p, NODE_T *q, enum a68_attribute t) +{ + NODE_T *z = a68_new_node (); + + gcc_assert (p != NO_NODE && q != NO_NODE); + *z = *p; + + if (GINFO (p) != NO_GINFO) + GINFO (z) = a68_new_genie_info (); + + PREVIOUS (z) = NO_NODE; + + if (p == q) + NEXT (z) = NO_NODE; + else + { + if (NEXT (p) != NO_NODE) + PREVIOUS (NEXT (p)) = z; + NEXT (p) = NEXT (q); + if (NEXT (p) != NO_NODE) + PREVIOUS (NEXT (p)) = p; + NEXT (q) = NO_NODE; + } + + SUB (p) = z; + ATTRIBUTE (p) = t; +} + +/* Find symbol table at level I. */ + +static TABLE_T * +find_level (NODE_T *n, int i) +{ + if (n == NO_NODE) + return NO_TABLE; + else + { + TABLE_T *s = TABLE (n); + + if (s != NO_TABLE && LEVEL (s) == i) + return s; + else if ((s = find_level (SUB (n), i)) != NO_TABLE) + return s; + else if ((s = find_level (NEXT (n), i)) != NO_TABLE) + return s; + else + return NO_TABLE; + } +} + +/* Whether P is top of lexical level. */ + +bool +a68_is_new_lexical_level (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ALT_DO_PART: + case BRIEF_ELIF_PART: + case BRIEF_OUSE_PART: + case BRIEF_CONFORMITY_OUSE_PART: + case CHOICE: + case CLOSED_CLAUSE: + case CONDITIONAL_CLAUSE: + case DO_PART: + case ELIF_PART: + case ELSE_PART: + case CASE_CLAUSE: + case CASE_CHOICE_CLAUSE: + case CASE_IN_PART: + case CASE_OUSE_PART: + case OUT_PART: + case ROUTINE_TEXT: + case SPECIFIED_UNIT: + case THEN_PART: + case CONFORMITY_CLAUSE: + case CONFORMITY_CHOICE: + case CONFORMITY_IN_PART: + case CONFORMITY_OUSE_PART: + case WHILE_PART: + return true; + default: + return false; + } +} + +/* + * Couple of utility functions. + */ + +/* Safely append to buffer. */ + +void +a68_bufcat (char *dst, const char *src, int len) +{ + if (src != NO_TEXT) { + char *d = dst; + const char *s = src; + int n = len; +// Find end of dst and left-adjust; do not go past end + for (; n-- != 0 && d[0] != '\0'; d++) { + ; + } + int dlen = (int) (d - dst); + n = len - dlen; + if (n > 0) { + while (s[0] != '\0') { + if (n != 1) { + (d++)[0] = s[0]; + n--; + } + s++; + } + d[0] = '\0'; + } +// Better sure than sorry + dst[len - 1] = '\0'; + } +} + +/* Safely copy to buffer. */ + +void +a68_bufcpy (char *dst, const char *src, int len) +{ + if (src != NO_TEXT) { + char *d = dst; + const char *s = src; + int n = len; +// Copy as many as fit + if (n > 0 && --n > 0) { + do { + if (((d++)[0] = (s++)[0]) == '\0') { + break; + } + } while (--n > 0); + } + if (n == 0 && len > 0) { +// Not enough room in dst, so terminate + d[0] = '\0'; + } +// Better sure than sorry + dst[len - 1] = '\0'; + } +} + +/* Make a new copy of concatenated strings. */ + +char * +a68_new_string (const char *t, ...) +{ + va_list vl; + va_start (vl, t); + const char *q = t; + if (q == NO_TEXT) { + va_end (vl); + return NO_TEXT; + } + int len = 0; + while (q != NO_TEXT) { + len += (int) strlen (q); + q = va_arg (vl, char *); + } + va_end (vl); + len++; + char *z = (char *) xmalloc ((size_t) len); + z[0] = '\0'; + q = t; + va_start (vl, t); + while (q != NO_TEXT) { + a68_bufcat (z, q, len); + q = va_arg (vl, char *); + } + va_end (vl); + return z; +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label_to_serial (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, SERIAL_CLAUSE)) + { + bool valid_follow; + + if (NEXT (p) == NO_NODE) + valid_follow = true; + else if (IS (NEXT (p), CLOSE_SYMBOL)) + valid_follow = true; + else if (IS (NEXT (p), END_SYMBOL)) + valid_follow = true; + else if (IS (NEXT (p), OD_SYMBOL)) + valid_follow = true; + else + valid_follow = false; + + if (valid_follow) + JUMP_TO (TABLE (SUB (p))) = NO_NODE; + } + + tie_label_to_serial (SUB (p)); + } +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label (NODE_T *p, NODE_T *unit) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_IDENTIFIER)) + UNIT (TAX (p)) = unit; + tie_label (SUB (p), unit); + } +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label_to_unit (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, LABELED_UNIT)) + tie_label (SUB_SUB (p), NEXT_SUB (p)); + tie_label_to_unit (SUB (p)); + } +} + +/* Table with attribute names. */ + +static const char *attribute_names[] = +{ + "STOP", +#define A68_ATTR(ATTR,DESCR) DESCR, +#include "a68-parser-attrs.def" +#undef A68_ATTR +}; + +/* Get the name of an attribute. */ + +const char * +a68_attribute_name (enum a68_attribute attr) +{ + return attribute_names[attr]; +} + +/* Get the location of node P as a GCC location. */ + +location_t +a68_get_node_location (NODE_T *p) +{ + LINE_T *line = LINE (INFO (p)); + + if (line == NO_LINE) + return UNKNOWN_LOCATION; + + unsigned line_number = NUMBER (line); + unsigned column_number = CHAR_IN_LINE (INFO (p)) - STRING (line) + 1; + const char *filename = FILENAME (line); + + location_t gcc_location; + + linemap_add (line_table, LC_ENTER, 0, filename, line_number); + linemap_line_start (line_table, line_number, 0); + gcc_location = linemap_position_for_column (line_table, column_number); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + + return gcc_location; +} + +/* Get the location of POS inside LINE as a GCC location. */ + +location_t +a68_get_line_location (LINE_T *line, const char *pos) +{ + location_t loc; + + linemap_add (line_table, LC_ENTER, 0, FILENAME (line), NUMBER (line)); + linemap_line_start (line_table, NUMBER (line), 0); + loc = linemap_position_for_column (line_table, pos - STRING (line) + 1); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + return loc; +} -- 2.30.2
