This commit introduces a new pass for the Algol 68 parser, that computes a set of static properties of certain source constructs, namely the ones yielding values. The resulting static properties are then to be used by the lowerer pass in order to avoid unnecessary copies and implement certain other optimizations.
At the moment two static properties are implemented: the "origin" and the "access". The first reflects static information about the original value conforming the source construct, as well as keeping track of certain transformations; this makes it possible, for example, to determine whether certain values have been ever dereferenced. The second reflects the access in which the value yielded by the source construct is to be accessed once lowered. Signed-off-by: Jose E. Marchesi <[email protected]> gcc/algol68/ChangeLog * a68.h: Add prototypes for a68_sprops, a68_yields_value and a68_is_declaration. * a68-types.h (a68_access): New type. (a68_kindo): Likewise. (ORIGIN_T): Likewise. (ACCESS_T): Likewise. (NODE_T): Add fields origin and access. (TAG_T): Likewise. (ACCESS_NIHIL): Remove. (ACCESS_CONSTANT): Likewise. (ACCESS_DIRIDEN): Likewise. (ACCESS_INDIDEN): Likewise. (ACCESS_DIRWOST): Likewise. (DEFLEX): Likewise. (FLEXO): Likewise. (BNO): Define. (DEFLEX): Likewise. (DIAGO): Likewise. * a68-parser-sprops.cc: New file. * a68-parser-attrs.def: New comment. * a68-parser-bottom-up.cc (reduce_enquiry_clauses): Add a few comments to improve readability. * a68-parser.cc (a68_is_declaration): New function. (a68_yields_value): Likewise. (a68_parser): Run the sprops pass. (a68_new_node): Initialize ORIGIN and ACCESS. (a68_new_tag): Likewise, for tags. * Make-lang.in (ALGOL68_OBJS): Build algol68/a68-parser-sprops.o. * a68-parser-debug.cc (a68_dump_parse_tree_1): Show static properties whenever requested. * a68-low-clauses.cc: Fix grammar for initialiser series and closed clause in comments. * a68-low.cc (a68_low_assignation): Fix comment. --- gcc/algol68/Make-lang.in | 1 + gcc/algol68/a68-low-clauses.cc | 19 +- gcc/algol68/a68-low.cc | 2 +- gcc/algol68/a68-parser-attrs.def | 3 + gcc/algol68/a68-parser-bottom-up.cc | 2 + gcc/algol68/a68-parser-debug.cc | 49 +- gcc/algol68/a68-parser-sprops.cc | 1362 +++++++++++++++++++++++++++ gcc/algol68/a68-parser.cc | 89 ++ gcc/algol68/a68-types.h | 120 +-- gcc/algol68/a68.h | 9 +- 10 files changed, 1582 insertions(+), 74 deletions(-) create mode 100644 gcc/algol68/a68-parser-sprops.cc diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in index 5ad6bec3a20..bf71433911e 100644 --- a/gcc/algol68/Make-lang.in +++ b/gcc/algol68/Make-lang.in @@ -82,6 +82,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \ algol68/a68-parser-scanner.o \ algol68/a68-parser-scope.o \ algol68/a68-parser-serial-dsa.o \ + algol68/a68-parser-sprops.o \ algol68/a68-parser-taxes.o \ algol68/a68-parser-top-down.o \ algol68/a68-parser-victal.o \ diff --git a/gcc/algol68/a68-low-clauses.cc b/gcc/algol68/a68-low-clauses.cc index e6731810012..683755217d4 100644 --- a/gcc/algol68/a68-low-clauses.cc +++ b/gcc/algol68/a68-low-clauses.cc @@ -164,10 +164,9 @@ a68_lower_completer (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) Parse tree: - initialiser series : serial clause, semi symbol, declaration list; - initialiser series, declaration list; - initialiser series, semi symbol, unit; - initialiser series, semi symbol, labeled unit; + initialiser series : declaration list; + serial clause, semi symbol, declaration list; + enquiry clause, semi symbol, declaration list; initialiser series, semi symbol, declaration list. GENERIC: @@ -196,7 +195,6 @@ a68_lower_initialiser_series (NODE_T *p, LOW_CTX_T ctx) unit; serial clause, semi symbol, unit; serial clause, exit symbol, labeled unit; - serial clause, semi_symbol, declaration list; initialiser series, semi symbol, unit; initialiser series, semi symbol, labeled unit. @@ -230,8 +228,7 @@ a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx) } else { - /* Append the result of either the unit or the declarations list in - the current statements list. */ + /* Append the result of the unit in the current statements list. */ a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); } } @@ -240,8 +237,8 @@ a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx) /* Traverse down for side-effects. */ (void) a68_lower_tree (SUB (p), ctx); - /* Append the result of either the unit or the declarations list in the - current statements list. */ + /* Append the result of the unit or labeled unit in the current + statements list. */ a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); } else @@ -1369,9 +1366,7 @@ a68_lower_parallel_clause (NODE_T *p ATTRIBUTE_UNUSED, /* Lower a closed clause. closed clause : open symbol, serial clause, close symbol; - open symbol, initialiser series, close symbol; - begin symbol, serial clause, end symbol; - begin symbol, initialiser series, end symbol; + begin symbol, serial clause, end symbol. This function returns a BIND_EXPR. */ diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc index ea69206c5cc..8fc112cd76f 100644 --- a/gcc/algol68/a68-low.cc +++ b/gcc/algol68/a68-low.cc @@ -1051,7 +1051,7 @@ a68_low_assignation (NODE_T *p, else { /* The name at the lhs is either a variable or a component ref as - a l-value. It is ok to evaluate it as an r-value as well as + an l-value. It is ok to evaluate it as an r-value as well as doing so introduces no side-effects. */ effective_lhs = lhs; } diff --git a/gcc/algol68/a68-parser-attrs.def b/gcc/algol68/a68-parser-attrs.def index 2d615409da1..c474a2653db 100644 --- a/gcc/algol68/a68-parser-attrs.def +++ b/gcc/algol68/a68-parser-attrs.def @@ -20,6 +20,9 @@ messages and debug dumps. Please make sure to write them in a way you would expect to be used in statements like "[...] near ATT". */ +/* If you add a new entry, please update the a68_is_* classifier functions in + a68-parser.cc. */ + A68_ATTR(A68_PATTERN, "transput pattern") A68_ATTR(ACCESS_CLAUSE, "access clause") A68_ATTR(ACCESS_SYMBOL, "access-symbol") diff --git a/gcc/algol68/a68-parser-bottom-up.cc b/gcc/algol68/a68-parser-bottom-up.cc index ccbcba93211..c17436536b3 100644 --- a/gcc/algol68/a68-parser-bottom-up.cc +++ b/gcc/algol68/a68-parser-bottom-up.cc @@ -2416,6 +2416,7 @@ reduce_enquiry_clauses (NODE_T *p) ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, ENQUIRY_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP); + /* Errors */ reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, @@ -2435,6 +2436,7 @@ reduce_enquiry_clauses (NODE_T *p) ENQUIRY_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, &siga, INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP); + /* Errors */ reduce (q, strange_separator, &siga, ENQUIRY_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP); reduce (q, strange_separator, &siga, diff --git a/gcc/algol68/a68-parser-debug.cc b/gcc/algol68/a68-parser-debug.cc index 28646b3f31a..a44c48f8912 100644 --- a/gcc/algol68/a68-parser-debug.cc +++ b/gcc/algol68/a68-parser-debug.cc @@ -36,7 +36,8 @@ static void a68_dump_parse_tree_1 (NODE_T *p, const text_art::dump_widget_info &dwi, - text_art::tree_widget &widget, bool tables, bool levels) + text_art::tree_widget &widget, bool tables, bool levels, + bool sprops) { for (; p != NO_NODE; FORWARD (p)) { @@ -63,6 +64,40 @@ a68_dump_parse_tree_1 (NODE_T *p, const text_art::dump_widget_info &dwi, else levelsinfo = xstrdup (""); + char *spropsinfo; + if (sprops && a68_yields_value (p)) + { + const char *kindo, *access; + + switch (KINDO (p)) + { + case KINDO_NIL: kindo = "nil"; break; + case KINDO_CST: kindo = "cst"; break; + case KINDO_IDE: kindo = "ide"; break; + case KINDO_VAR: kindo = "var"; break; + case KINDO_GEN: kindo = "gen"; break; + default: + gcc_unreachable (); + } + + switch (ACCESS (p)) + { + case NO_ACCESS: access = "voided"; break; + case ACCESS_DIR: access = "dir"; break; + case ACCESS_IND: access = "ind"; break; + case ACCESS_VAR: access = "var"; break; + default: + gcc_unreachable (); + } + + spropsinfo = xasprintf ("(%s,%d,%d,%d) %s", + kindo, BNO (p), + DEREFO (p), GENO (p), + access); + } + else + spropsinfo = xstrdup (""); + char mode[BUFFER_SIZE]; mode[0] = '\0'; if (MOID (p) != NO_MOID) @@ -87,7 +122,7 @@ a68_dump_parse_tree_1 (NODE_T *p, const text_art::dump_widget_info &dwi, location_t loc = a68_get_node_location (p); std::unique_ptr<text_art::tree_widget> cwidget = text_art::tree_widget::from_fmt (dwi, nullptr, - "%s:%d:%d [%d] %s%s%s%s%s", + "%s:%d:%d [%d] %s%s%s%s%s%s", LOCATION_FILE (loc), LOCATION_LINE (loc), LOCATION_COLUMN (loc), @@ -96,18 +131,20 @@ a68_dump_parse_tree_1 (NODE_T *p, const text_art::dump_widget_info &dwi, symbol, mode, tableinfo, - levelsinfo); + levelsinfo, + spropsinfo); free (symbol); free (tableinfo); free (levelsinfo); + free (spropsinfo); - a68_dump_parse_tree_1 (SUB (p), dwi, *cwidget, tables, levels); + a68_dump_parse_tree_1 (SUB (p), dwi, *cwidget, tables, levels, sprops); widget.add_child (std::move (cwidget)); } } void -a68_dump_parse_tree (NODE_T *p, bool tables, bool levels) +a68_dump_parse_tree (NODE_T *p, bool tables, bool levels, bool sprops) { text_art::style_manager sm; text_art::style::id_t default_style_id (sm.get_or_create_id (text_art::style ())); @@ -116,7 +153,7 @@ a68_dump_parse_tree (NODE_T *p, bool tables, bool levels) std::unique_ptr<text_art::tree_widget> widget = text_art::tree_widget::from_fmt (dwi, nullptr, "Parse Tree"); - a68_dump_parse_tree_1 (p, dwi, *widget, tables, levels); + a68_dump_parse_tree_1 (p, dwi, *widget, tables, levels, sprops); text_art::canvas c (widget->to_canvas (sm)); pretty_printer *const pp = global_dc->get_reference_printer (); diff --git a/gcc/algol68/a68-parser-sprops.cc b/gcc/algol68/a68-parser-sprops.cc new file mode 100644 index 00000000000..dc82ffd5393 --- /dev/null +++ b/gcc/algol68/a68-parser-sprops.cc @@ -0,0 +1,1362 @@ +/* Compute some static properties of values. + Copyright (C) 2026 Jose E. Marchesi. + + Written 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" + +/* This parser pass computes a set of static properties of certain parse tree + nodes and symtab entries representing source constructs. It is somewhat + inspired on the treatment of static properties described in + + An Optimized Translation Process and Its Application to ALGOL 68 + P. Branquart et al. + + However, the compilation system described in Branquart et al translates + constructs to an IR which is considerably lower in abstraction compared to + GENERIC, and therefore our management of static properties is different. + The underlying ideas, however, are very similar. */ + +/* The origin + ────────── + + The "origin" is a static property of source constructs that yield values. + Its purpose is to record the properties of the original value from which the + construct is derived, as well as the transformations the value has been + submitted to before appearing in the construct. This static property is + composed by several fields described below. + + kindo is the "kind of the origin". + ───── + + It keeps track of the fact that a value is issued from + + ╭─────────╮ + │KINDO_IDE│ an identifier in a VAR_DECL, + ╰─────────╯ + ╭─────────╮ + │KINDO_VAR│ a variable in a VAR_DECL, + ╰─────────╯ + ╭─────────╮ + │KINDO_CST│ a constant in a VAR_DECL with TREE_CONSTANT=1, + ╰─────────╯ + ╭─────────╮ + │KINDO_GEN│ a generator i.e. a malloc or alloca, + ╰─────────╯ + ╭─────────╮ + │KINDO_NIL│ or another construct. + ╰─────────╯ + + This property remains invariant through the static elaboration of a number + of actions such as slices, selection and dereferencings. + + bno is the "block number of the origin". + ─── + + Its meaning for a particular construct is to be interpreted along with its + kindo. For KINDO_IDE and KINDO_VAR, bno indicates the depth number of + the block where the identifier or the variable is declared. For + KINDO_GEN, when it corresponds to a local generator, bno indicates the + depth number of the block where the generator appears. For + KINDO_CONSTANT, and for KINDO_GEN when it corresponds to a heap generator, + bno is always zero. + + derefo is the "flag dereferencing of the origin". + ────── + + This flag indicates whether a dereferencing action has taken place + starting from the construct in whcih kindo has been set up. This + information allows, in some cases, to statically detect the absence of + side-effects, and subsequently to avoid some copies of values. + + geno is the "flag local generator of the origin". + ──── + + This flag indicates whether a local generator is involved in the + construction of this value. + + diago contains the "diagnostics of the origin". + ───── + + This property contains location information of the construct originating + the value. It is useful in order to emit good diagnostic messages in + dynamic checks pointing to the source program construct giving rise to the + value involved in the dynamic check. */ + +/* The access + ────────── + + In the "low" pass parse tree nodes denoting units will be lowered to GCC + GENERIC trees. These trees compute the values yielded by the units. For + example, a DENOTATION node for an integral value may be lowered to an + INTEGER_CST tree, a FORMULA node to a PLUS_EXPR tree, an applied IDENTIFIER + to a VAR_DECL, and a DEREFERENCING node to an INDIRECT_REF tree. + + In principle, it would be expected for the resulting trees to directly + compute the value denoted by the parse nodes originating them. However, for + reasons of efficiency, this is not always the case. + + Parse nodes lowering to trees that directly compute the value yielded by the + unit are said to have "direct access". Examples: + + ● Consider a denotation "10". The parser builds a parse node DENOTATION + with the value 10 for it, and the "low" pass lowers that parse node into a + GENERIC tree consisting in a single INTEGER_CST tree node, with value 10. + In this case, the tree indeed computes the value yielded by the DENOTATION + node. + + ● An applied IDENTIFIER "maxint" with mode int that has been declared via an + identity declaration, with some integral value ascribed to it. The "low" + pass lowers it into a VAR_DECL with TREE_TYPE int. Again, this node has + "direct access", because the VAR_DECL in a GENERIC r-value position + computes the value ascribed to the IDENTIFIER. + + Parse nodes denoting units that yield names, lowering to VAR_DECL trees + whose address is the value yielded by the unit are said to have "variable + access". Examples: + + ● Suppose that another applied IDENTIFIER "count" with mode int has been + declared, this time via a variable declaration. The value ascribed to the + identifier is in this case a name with mode "ref int". Such a name would + generally be lowered to a tree of type *int, i.e. the address of the + variable, but in this case the node will be lowered to a VAR_DECL with + type int instead. This is an optimization whose goal is to avoid + unnecessary indirect addressing. The tree represents the name and can be + moved around as-is, but when it comes to access the actual value of the + name, i.e. the address of the integral value referenced by the name, it + becomes necessary to take the address of the VAR_DECL. + + Parse nodes lowering to trees that need to be indirected in order to compute + the value yielded by the unit are said to have "indirect access". Examples: + + ● Consider what happens when a DEREFERENCING node has a coercend with + "variable access" which is of mode "ref int", or alternatively a coercend + with "direct access" also of mode "ref int". In the first case, the + coercend will be lowered to a VAR_DECL with type int, as an optimization. + In the second case, the coercend will be lowered to some tree with type + *int. It would make sense for the DEREFERENCING node to be of "direct + class" and be lowered to an INDIRECT_REF tree taking as argument the + address of the VAR_DECL in the first case, and just the value of the + VAR_DECL in the second case. However, as an optimization, the + dereferencing of nodes with "direct class" or "variable class" doesn't + require any run-time action (other than perhaps checking for nil) and the + DEREFERENCING node is lowered to the coercend tree without any + modification. Only when the dereferenced value is actually used, + indirection will be performed. + + ● The value yielded by the last unit in a serial clause doesn't need to be + copied into the outer range if the yielded value is accessible in that + range. Instead, the unit gets lowered to a tree computing the address of + the value, and is given indirect access. + + The different access classes are summarized below: + + ╭──────────╮ + │ACCESS_IND│ indirect access. + ╰──────────╯ + ╭──────────╮ + │ACCESS_DIR│ direct access. + ╰──────────╯ + ╭──────────╮ + │ACCESS_VAR│ variable access. + ╰──────────╯ + + + IND DIR VAR + ─── ─── ─── + node mode: int int ref int + tree type: *int int int + + + The purpose of this static property is thus to guide the lowering pass, but + there is certain level of circularity, as the calculation of the access is + also influenced by the behavior of the lowering pass. + + It is important to remember that the access static property only makes sense + for constructs that yield values, i.e. units. Nodes that are not units are + annotated with NO_ACCESS, which denotes no access. */ + +/* Handling of choice constructs + ───────────────────────────── + + Choice constructs include: + + ● Serial clauses with completers. + ● Conditional clauses. + ● Conformity clauses. + ● Case clauses. + + The characteristic of these constructs is that they need to perform + balancing on a set of alternatives, like the values yielded by the then-part + and the else-part of a conditional clause, in order to determine the static + properties of the value yielded by the choice construct. + + Given a choice construct involving sub-values V1, V2, .. Vn, with their + respective "a priori" static properties, the "a posteriori" static + properties of the resulting value Vr are derived as follows: + + ● The mode of Vr (which is a static property, albeit not handled here) is + determined from the balancing of the modes of V1, V2, ... Vn. This has + already been done by the parser at this stage and the parse tree nodes are + annotated with the "a posteriori" mode of the choice construct. Suitable + coercions are also in the parse tree. + + ● If all sub-values have the same "a priori" origin, then that's the origin + of Vr. Otherwise, we act conservatively by setting KINDO (Vr) to + KINDO_NIL, DEREFO to true iff any of the sub-values have DEREFO set, and + GENO to true iff any of the sub-values have GENO set. + + + ● If all sub-values have the same "a priori" access, then that's the access + of Vr. Otherwise, use direct access. + + These rules are implemented in the corresponding handlers for choice + constructs, below. */ + +/* Allocate a new origin and return it. The particular properties used to + initialize the value are arbitrary and the user should not rely on them. */ + +static ORIGIN_T * +make_origin (void) +{ + ORIGIN_T *ori = ggc_alloc<ORIGIN_T> (); + ori->kindo = KINDO_NIL; + ori->bno = 0; + ori->derefo = false; + ori->geno = false; + ori->diago = UNKNOWN_LOCATION; + return ori; +} + +/* Allocate a copy of ORI and return it. */ + +static ORIGIN_T * +dup_origin (ORIGIN_T *ori) +{ + ORIGIN_T *res = ggc_alloc<ORIGIN_T> (); + *res = *ori; + return res; +} + +/* Determine whether ORI1 and ORI2 reflect the same origin. */ + +static bool +origin_equal_p (ORIGIN_T *ori1, ORIGIN_T *ori2) +{ + return (ori1 != NO_ORIGIN + && ori2 != NO_ORIGIN + && (ori1 == ori2 + || (ori1->kindo == ori2->kindo + && ori1->derefo == ori2->derefo + && ori1->geno == ori2->geno + && ori1->diago == ori2->diago))); +} + +/* Denotations + ─────────── + + Denotations of any mode introduce their own constant origin, and always have + direct access. */ + +static void +sprops_for_denotation (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_CST; + DIAGO (p) = a68_get_node_location (p); + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_DIR; +} + +/* Widening coercion + ───────────────── + + Widening of integral and real values result into direct real and complex + values. The widening of bits and bytes result into direct multiple values. + This is a kernel invariant operation, so the origin stays unchanged. */ + +static void +sprops_for_widening (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (SUB (p)); + ACCESS (p) = ACCESS_DIR; +} + +/* Voiding coercion + ──────────────── + + The origin of the voiding construct is the origin of the voided value. The + resulting voided voided value has acess NIL, denoting the absence of value. + This is a kernel invariant operation, so the origin stays unchanged. */ + +static void +sprops_for_voiding (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (SUB (p)); + ACCESS (p) = ACCESS_NIL; +} + +/* Dereferencing coercion + ────────────────────── + + The origin of the dereferenced value is like the origin of the coercend but + with DEREFO set. We always use an indirect access for the coercee so we + delay actual indirection for when (and if) the dereferenced value actually + gets used. */ + +static void +sprops_for_dereferencing (NODE_T *p) +{ + ORIGIN (p) = dup_origin (ORIGIN (SUB (p))); + DEREFO (p) = true; + ACCESS (p) = ACCESS_IND; +} + +/* Deproceduring coercion + ────────────────────── + + It is not possible to detemine the origin of the value yielded by the + elaboration of the procedure, so we create a new one with KINDO_NIL. The + access of the yielded value is always direct. */ + +static void +sprops_for_deproceduring (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DIAGO (p) = a68_get_node_location (p); + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_DIR; +} + +/* Proceduring + ─────────── + + Procedured jumps result into a proc value. The origin is new and is of + KINDO_NIL. The access for the resulting procedure is always direct. */ + +static void +sprops_for_proceduring (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DIAGO (p) = a68_get_node_location (p); + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_DIR; +} + +/* Rowing coercion + ─────────────── + + The origin of the coercee is the origin of the coercend. The access of the + resulting value is always direct: reals, complex or multiples of bools or + chars. This is a kernel invariant operation, so the origin stays + unchanged. */ + +static void +sprops_for_rowing (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (SUB (p)); + ACCESS (p) = ACCESS_DIR; +} + +/* Uniting coercion + ──────────────── + + The origin of the coercee is the origin of the coercend. XXX this is a sort + of multiple choices problem as well. This is a kernel invariant operation, + so the origin stays unchanged. */ + +static void +sprops_for_uniting (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (SUB (p)); + ACCESS (p) = ACCESS_DIR; /* XXX */ +} + +/* Loop clauses + ──────────── + + The loop clause effectively acts like voiding, so it has its own origin. We + use NIL access, which denotes the absence of value. */ + +static void +sprops_for_loop_clause (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DIAGO (p) = a68_get_node_location (p); + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_NIL; +} + +/* Enclosed clauses + ──────────────── + + The origin and access of the value of an enclosed clause is the origin and + access of the value of its enclosed clause :-O */ + +static void +sprops_for_enclosed_clause (NODE_T *p) +{ + NODE_T *enclosed_clause = SUB (p); + ORIGIN (p) = ORIGIN (enclosed_clause); + ACCESS (p) = ACCESS (enclosed_clause); +} + +/* Access clauses + ────────────── + + The origin/access of the access clause is the origin/access of the + controlled clause. */ + +static void +sprops_for_access_clause (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (NEXT_SUB (p)); +} + +/* Enquiry clauses + ─────────────── + + The origin of the enquiry clause is the origin of the unit yielded by the + underlying serial clause, which is assured to not have choices. The enquiry + clause always yields a boolean value, which much have direct access. */ + +static void +sprops_for_enquiry_clause (NODE_T *p) +{ + if (IS (SUB (p), UNIT)) + ORIGIN (p) = ORIGIN (SUB (p)); + else if (IS (SUB (p), ENQUIRY_CLAUSE) || IS (SUB (p), INITIALISER_SERIES)) + ORIGIN (p) = ORIGIN (NEXT (NEXT_SUB (p))); + else + gcc_unreachable (); + ACCESS (p) = ACCESS_DIR; +} + +/* Serial clauses + ────────────── + + Serial clauses that have completers are choice constructs, in the sense they + yield one of several units determined at run-time, and therefore it becomes + necessary to do some "balancing" at compile-time. See the comment "Handling + of choice constructs" above for a description of the strategy we follow for + the "origin" and "access" static properties in such constructs. */ + +static void +sprops_for_serial_clause (NODE_T *p) +{ + NODE_T *last_unit = NO_NODE, *completer = NO_NODE; + + if (IS (SUB (p), UNIT)) + last_unit = SUB (p); + else if (IS (SUB (p), LABELED_UNIT)) + last_unit = NEXT_SUB (SUB (p)); + else + { + gcc_assert (IS (SUB (p), SERIAL_CLAUSE) || IS (SUB (p), INITIALISER_SERIES)); + + if (IS (NEXT_SUB (p), EXIT_SYMBOL)) + completer = SUB (p); + + NODE_T *q = NEXT (NEXT_SUB (p)); + if (IS (q, UNIT)) + last_unit = q; + else + { + gcc_assert (IS (q, LABELED_UNIT)); + last_unit = NEXT_SUB (q); + } + } + + gcc_assert (last_unit != NO_NODE); + gcc_assert (ORIGIN (last_unit) != NO_ORIGIN); + + if (completer == NO_NODE) + { + ORIGIN (p) = ORIGIN (last_unit); + ACCESS (p) = ACCESS (last_unit); + } + else + { + /* Balance origin. */ + if (origin_equal_p (ORIGIN (completer), ORIGIN (last_unit))) + ORIGIN (p) = ORIGIN (completer); + else + { + bool found_derefo = DEREFO (last_unit) | DEREFO (completer); + bool found_geno = GENO (last_unit) | GENO (completer); + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DEREFO (p) = found_derefo; + GENO (p) = found_geno; + BNO (p) = 0; + } + + /* Balance access. */ + if (ACCESS (completer) == ACCESS (last_unit)) + ACCESS (p) = ACCESS (completer); + else + ACCESS (p) = ACCESS_DIR; + } +} + +/* Parallel clauses + ──────────────── + + A parallel clause yields void, thus we create a fresh origin with KINDO_NIL. + The access is NIL. */ + +static void +sprops_for_parallel_clause (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + BNO (p) = 0; + DEREFO (p) = false; + GENO (p) = false; + ACCESS (p) = ACCESS_NIL; +} + +/* Closed clauses + ────────────── + + The origin/access of a closed clause is the origin/access of its contained + serial clause. */ + +static void +sprops_for_closed_clause (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (NEXT_SUB (p)); +} + +/* Conditional clauses + ─────────────────── + + The if-part and else-part of the conditional clause makes it a choice + construct in terms of static properties propagation. See "Handling of + choice constructs" above. */ + +static void +sprops_for_conditional_clause (NODE_T *p) +{ + NODE_T *then_part = NO_NODE, *else_part = NO_NODE; + + /* IF or ELIF part,SUB is an enquiry clause. */ + NODE_T *s = SUB (p); + + /* THEN part, SUB is a serial clause. */ + FORWARD (s); + then_part = NEXT_SUB (s); + + /* ELSE part. */ + FORWARD (s); + if (IS (s, CHOICE) || IS (s, ELSE_PART)) + else_part = NEXT (NEXT_SUB (s)); + else if (IS (s, CLOSE_SYMBOL) || IS (s, FI_SYMBOL)) + ; + else + { + /* ELIF part. Recurse. */ + sprops_for_conditional_clause (s); + else_part = s; + } + + if (else_part == NO_NODE) + { + ORIGIN (p) = ORIGIN (then_part); + ACCESS (p) = ACCESS (then_part); + } + else + { + /* Balance origin. */ + if (origin_equal_p (ORIGIN (then_part), ORIGIN (else_part))) + ORIGIN (p) = ORIGIN (else_part); + else + { + bool found_derefo = DEREFO (then_part) | DEREFO (else_part); + bool found_geno = GENO (then_part) | GENO (else_part); + + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DEREFO (p) = found_derefo; + GENO (p) = found_geno; + BNO (p) = 0; + } + + /* Balance access. */ + if (ACCESS (then_part) == ACCESS (else_part)) + ACCESS (p) = ACCESS (else_part); + else + ACCESS (p) = ACCESS_DIR; + } +} + +/* Case clauses + ──────────── + + The existence of several alterantives in a case clause makes it a choice + construct in terms of static properties propagation. See "Handling of + choice constructs" above. */ + +static void +sprops_for_case_unit (NODE_T *p, + bool found_mismatch, + ORIGIN_T **postulated_origin, + bool *found_derefo, bool *found_geno, + ACCESS_T *postulated_access) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + *found_derefo |= DEREFO (p); + *found_geno |= GENO (p); + + if (*postulated_origin == NO_ORIGIN && !found_mismatch) + *postulated_origin = ORIGIN (p); + else if (!origin_equal_p (ORIGIN (p), *postulated_origin)) + { + *postulated_origin = NO_ORIGIN; + found_mismatch = true; + } + } + else + sprops_for_case_unit (SUB (p), + found_mismatch, + postulated_origin, + found_derefo, found_geno, + postulated_access); + } +} + +static void +sprops_for_case_clause (NODE_T *p) +{ + NODE_T *out_part = NO_NODE; + + /* CASE or OUSE. */ + NODE_T *s = SUB (p); + + /* IN. */ + NODE_T *in_parts = FORWARD (s); + + /* OUT. */ + FORWARD (s); + if (IS (s, CHOICE) || IS (s, OUT_PART)) + out_part = NEXT (NEXT_SUB (s)); + else if (IS (s, CLOSE_SYMBOL) || IS (s, ESAC_SYMBOL)) + ; + else + { + /* Recurse. */ + sprops_for_case_clause (s); + out_part = s; + } + + /* We start by postulating the properties of the out-part, if it exists, then + go through all the in-parts. */ + + ORIGIN_T *postulated_origin = NO_ORIGIN; + ACCESS_T postulated_access = NO_ACCESS; + + bool found_derefo = false, found_geno = false; + + if (out_part != NO_NODE) + postulated_origin = ORIGIN (out_part); + + sprops_for_case_unit (in_parts, false, + &postulated_origin, + &found_derefo, &found_geno, + &postulated_access); + + /* Balance origin. */ + if (postulated_origin != NO_ORIGIN) + ORIGIN (p) = postulated_origin; + else + { + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DEREFO (p) = found_derefo; + GENO (p) = found_geno; + BNO (p) = 0; + } + + /* Balance access. */ + if (postulated_access != NO_ACCESS) + ACCESS (p) = postulated_access; + else + ACCESS (p) = ACCESS_DIR; + +} + +/* Collateral clauses + ────────────────── + + We distinguish between two cases when handling the static properties of + collateral clauses: + + ● VOID-collateral-clauses yield void, and therefore they have origin of kind + NIL and access NIL. + + ● Row- and struct-displays yield a multiple value, with origin constant and + direct access. */ + +static void +sprops_for_collateral_clause (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + BNO (p) = 0; + GENO (p) = 0; + DEREFO (p) = 0; + + if (MOID (p) == M_VOID) + { + KINDO (p) = KINDO_NIL; + ACCESS (p) = ACCESS_NIL; + } + else + { + KINDO (p) = KINDO_CST; + ACCESS (p) = ACCESS_DIR; + } +} + +/* Conformity clauses + ────────────────── + + The existence of several alterantives in a conformity clause makes it a + choice construct in terms of static properties propagation. See "Handling + of choice constructs" above. */ + +static void +sprops_for_unite_case_unit (NODE_T *p, + bool found_mismatch, + ORIGIN_T **postulated_origin, + bool *found_derefo, bool *found_geno, + ACCESS_T *postulated_access) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, SPECIFIER)) + { + NODE_T *spec_unit = NEXT_NEXT (p); + + *found_derefo |= DEREFO (spec_unit); + *found_geno |= GENO (spec_unit); + + if (*postulated_origin == NO_ORIGIN && !found_mismatch) + *postulated_origin = ORIGIN (spec_unit); + else if (!origin_equal_p (ORIGIN (spec_unit), *postulated_origin)) + { + *postulated_origin = NO_ORIGIN; + found_mismatch = true; + } + + FORWARD (p); /* Skip specifier. */ + FORWARD (p); /* Skip unit. */ + /* The unit is skipped in the for loop post-action. */ + } + else + sprops_for_unite_case_unit (SUB (p), + found_mismatch, + postulated_origin, + found_derefo, found_geno, + postulated_access); + } +} + +static void +sprops_for_conformity_clause (NODE_T *p) +{ + NODE_T *out_part = NO_NODE; + + /* CASE or OUSE. */ + NODE_T *s = SUB (p); + + /* IN. */ + NODE_T *in_parts = FORWARD (s); + + /* OUT. */ + FORWARD (s); + if (IS (s, CHOICE) || IS (s, OUT_PART)) + out_part = NEXT (NEXT_SUB (s)); + else if (IS (s, CLOSE_SYMBOL) || IS (s, ESAC_SYMBOL)) + ; + else + { + /* Recurse. */ + sprops_for_conformity_clause (s); + out_part = s; + } + + /* We start by postulating the properties of the out-part, if it exists, then + go through all the in-parts. */ + + ORIGIN_T *postulated_origin = NO_ORIGIN; + ACCESS_T postulated_access = NO_ACCESS; + + bool found_derefo = false, found_geno = false; + + if (out_part != NO_NODE) + postulated_origin = ORIGIN (out_part); + + sprops_for_unite_case_unit (in_parts, false, + &postulated_origin, + &found_derefo, &found_geno, + &postulated_access); + + /* Balance origin. */ + if (postulated_origin != NO_ORIGIN) + ORIGIN (p) = postulated_origin; + else + { + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + DEREFO (p) = found_derefo; + GENO (p) = found_geno; + BNO (p) = 0; + } + + /* Balance access. */ + if (postulated_access != NO_ACCESS) + ACCESS (p) = postulated_access; + else + ACCESS (p) = ACCESS_DIR; +} + +/* Identity relations + ────────────────── + + The identity relation yields a new boolean value with a fresh origin. Its + access is always direct. */ + +static void +sprops_for_identity_relation (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + KINDO (p) = KINDO_NIL; + BNO (p) = 0; + DEREFO (p) = false; + GENO (p) = false; + ACCESS (p) = ACCESS_DIR; +} + +/* Assignations + ──────────── + + If according to previsions the assignation is immediately dereferenced, the + dereferencing is combined with the assignation by the lowerer, and we use + the static properties of the source instaed of those of the destination. */ + +static void +sprops_for_assignation (NODE_T *p) +{ + NODE_T *destination = SUB (p); + ORIGIN (p) = ORIGIN (destination); + /* XXX implement prevision. */ + ACCESS (p) = ACCESS_DIR; +} + +/* Slices + ────── + + The origin of a slice is the origin of the primary being sliced. The access + is alwyas direct. This is a kernel invariant operation, so the origin stays + unchanged. */ + +static void +sprops_for_slice (NODE_T *p) +{ + NODE_T *primary = SUB (p); + ORIGIN (p) = ORIGIN (primary); + ACCESS (p) = ACCESS_DIR; +} + +/* Selections + ────────── + + The origin of a selection is the origin of the secondary being selected. + The access is always direct. This is a kernel invariant operation, so the + origin stays unchanged. */ + +static void +sprops_for_selection (NODE_T *p) +{ + NODE_T *secondary; + + if (IS (SUB (p), SELECTOR)) + secondary = NEXT_SUB (p); + else + { + gcc_assert (IS (SUB (p), SECONDARY)); + secondary = SUB (p); + } + ORIGIN (p) = ORIGIN (secondary); + ACCESS (p) = ACCESS_DIR; +} + +/* Logical functions + ───────────────── + + The logical function constructs (or_function, and_function) introduce a new + origin, which is of class KINDO_NIL. The value yielded by these constructs + is a boolean and its access is always direct. */ + +static void +sprops_for_logical_function (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_NIL; + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_DIR; +} + +/* Casts + ───── + + Both origin and access of the coercee are the same origin and access o the + coercend in the strong context introduced by the cast. This is a kernel + invariant operation, so the origin stays unchanged. */ + +static void +sprops_for_cast (NODE_T *p) +{ + NODE_T *coercend = NEXT_SUB (p); + ORIGIN (p) = ORIGIN (coercend); + ACCESS (p) = ACCESS (coercend); +} + +/* Calls + ───── + + The value yielded by a call has a fresh origin of class NIL. The access is + always direct. */ + +static void +sprops_for_call (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_NIL; + BNO (p) = 0; + DEREFO (p) = false; +} + +/* Generators + ────────── + + Generators introduce a fresh origin of class GEN, and appropriate + attributes. The access is always IND. */ + +static void +sprops_for_generator (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_GEN; + DEREFO (p) = false; + if (IS (SUB (p), LOC_SYMBOL)) + { + BNO (p) = 0; /* XXX */ + GENO (p) = true; + } + else + { + BNO (p) = 0; + GENO (p) = false; + } +} + +/* Monadic formulas + ──────────────── + + The value yielded by a monadic formula has the same origin than the single + operand. The access is always direct. */ + +static void +sprops_for_monadic_formula (NODE_T *p) +{ + ORIGIN (p) = ORIGIN (NEXT (SUB (p))); + ACCESS (p) = ACCESS_DIR; +} + +/* Dyadic formulas + ─────────────── + + If both operands of the formula have the same origin, then that is the + origin of the value yielded by the formula. Otherwise a fresh origin is + created with class NIL. The value yielded by the formula always have direct + access. */ + +static void +sprops_for_formula (NODE_T *p) +{ + if (IS (SUB (p), MONADIC_FORMULA) && NEXT_SUB (p) == NO_NODE) + ORIGIN (p) = ORIGIN (SUB (p)); + else + { + NODE_T *arg1 = SUB (p); + NODE_T *arg2 = NEXT (NEXT (SUB (p))); + + if (origin_equal_p (ORIGIN (arg1), ORIGIN (arg2))) + ORIGIN (p) = ORIGIN (arg1); + else + { + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_NIL; + DEREFO (p) = 0; + BNO (p) = 0; + GENO (p) = false; + } + } + ACCESS (p) = ACCESS_DIR; +} + +/* Identifiers + ─────────── + + Both the access and origin of the value yielded by an applied identifier is + obtained from the symtab. If the applied identifier appears before its + declaration, the symtab will not have the properties installed; in that + case, an origin is allocated in the symtab. XXX we need to install a + pointer to the access in the symtab. */ + +static void +sprops_for_applied_identifier (NODE_T *p) +{ + if (ORIGIN (TAX (p)) == NO_ORIGIN) + ORIGIN (TAX (p)) = make_origin (); + ORIGIN (p) = ORIGIN (TAX (p)); + ACCESS (p) = ACCESS (TAX (p)); +} + +/* Assertions + ────────── + + Assertions introduce a fresh origin of class NIL. The access is also + NIL. */ + +static void +sprops_for_assertion (NODE_T *p) +{ + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_NIL; + BNO (p) = 0; + DEREFO (p) = false; + ACCESS (p) = ACCESS_NIL; +} + +/* Fill in the static properties for the symtab entry for the identifier + declared in P, which is a parse node for a declaration. This function shall + handle all node types for which a68_is_declaration returns `true'. */ + +static void +sprops_for_decl (NODE_T *p) +{ + /* Declarations do not yield values themselves, but we set the origin and + access of their defining identifiers in their symtab entries. */ + + ORIGIN (p) = NO_ORIGIN; + ACCESS (p) = NO_ACCESS; + + /* Get the defining identifier. */ + NODE_T *defining_identifier = NO_NODE; + + switch (ATTRIBUTE (p)) + { + case IDENTITY_DECLARATION: + if (IS (SUB (p), IDENTITY_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), PUBLIC_SYMBOL)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), DECLARER)) + defining_identifier = NEXT_SUB (p); + else + gcc_unreachable (); + break; + case PROCEDURE_DECLARATION: + if (IS (SUB (p), PROCEDURE_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), PUBLIC_SYMBOL)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), PROC_SYMBOL)) + defining_identifier = NEXT_SUB (p); + else + gcc_unreachable (); + break; + case BRIEF_OPERATOR_DECLARATION: + if (IS (SUB (p), BRIEF_OPERATOR_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), PUBLIC_SYMBOL)) + defining_identifier = NEXT (NEXT_SUB (p)); + else + defining_identifier = NEXT_SUB (p); + break; + case OPERATOR_DECLARATION: + if (IS (SUB (p), OPERATOR_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else if (IS (SUB (p), PUBLIC_SYMBOL)) + defining_identifier = NEXT (NEXT_SUB (p)); + else + defining_identifier = NEXT_SUB (p); + break; + case VARIABLE_DECLARATION: + if (IS (SUB (p), VARIABLE_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else + { + NODE_T *q = SUB (p); + + if (IS (q, PUBLIC_SYMBOL)) + FORWARD (q); + + if (IS (q, QUALIFIER)) + defining_identifier = NEXT (NEXT (q)); + else if (IS (q, DECLARER)) + defining_identifier = NEXT (q); + else + gcc_unreachable (); + } + break; + case PROCEDURE_VARIABLE_DECLARATION: + if (IS (SUB (p), PROCEDURE_VARIABLE_DECLARATION)) + defining_identifier = NEXT (NEXT_SUB (p)); + else + { + NODE_T *q = SUB (p); + + if (IS (q, PUBLIC_SYMBOL)) + FORWARD (q); + + if (IS (q, PROC_SYMBOL)) + defining_identifier = NEXT (q); + else if (IS (q, QUALIFIER)) + defining_identifier = NEXT (NEXT (q)); + else + gcc_unreachable (); + } + break; + default: + break; + } + + /* Set the static attributes in the symtab for the defining identifier. */ + if (defining_identifier != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case IDENTITY_DECLARATION: + case PROCEDURE_DECLARATION: + { + TAG_T *tax = TAX (defining_identifier); + if (ORIGIN (tax) == NO_ORIGIN) + ORIGIN (tax) = make_origin (); + DIAGO (tax) = a68_get_node_location (p); + KINDO (tax) = KINDO_IDE; + ACCESS (tax) = ACCESS_DIR; + break; + } + case VARIABLE_DECLARATION: + case PROCEDURE_VARIABLE_DECLARATION: + { + TAG_T *tax = TAX (defining_identifier); + if (ORIGIN (tax) == NO_ORIGIN) + ORIGIN (tax) = make_origin (); + DIAGO (tax) = a68_get_node_location (p); + KINDO (tax) = KINDO_VAR; + ACCESS (tax) = ACCESS_VAR; + break; + } + case MODE_DECLARATION: + case PRIORITY_DECLARATION: + case BRIEF_OPERATOR_DECLARATION: + case OPERATOR_DECLARATION: + /* These declarations do not ascribe values to identifiers so there + is nothing to do. */ + break; + default: + gcc_unreachable (); + } + } +} + +/* Fill in the static properties for P, which is a parse node for a construct + yielding some value. This function shall handle all node types for which + a68_yields_value returns `true'. */ + +static void +sprops_for_unit (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case UNIT: + case PRIMARY: + case SECONDARY: + case TERTIARY: + ORIGIN (p) = ORIGIN (SUB (p)); + break; + case FORMAL_HOLE: + case JUMP: + case SKIP: + case NIHIL: + case EMPTY_SYMBOL: + case ROUTINE_TEXT: + ORIGIN (p) = make_origin (); + DIAGO (p) = a68_get_node_location (p); + KINDO (p) = KINDO_NIL; + DEREFO (p) = false; + BNO (p) = 0; + ACCESS (p) = ACCESS_DIR; + break; + case DENOTATION: + sprops_for_denotation (p); + break; + case IDENTIFIER: + sprops_for_applied_identifier (p); + break; + case MONADIC_FORMULA: + sprops_for_monadic_formula (p); + break; + case FORMULA: + sprops_for_formula (p); + break; + case GENERATOR: + sprops_for_generator (p); + break; + case SELECTION: + sprops_for_selection (p); + break; + case DEREFERENCING: + sprops_for_dereferencing (p); + break; + case DEPROCEDURING: + sprops_for_deproceduring (p); + break; + case PROCEDURING: + sprops_for_proceduring (p); + break; + case SLICE: + sprops_for_slice (p); + break; + case WIDENING: + sprops_for_widening (p); + break; + case UNITING: + sprops_for_uniting (p); + break; + case ROWING: + sprops_for_rowing (p); + break; + case VOIDING: + sprops_for_voiding (p); + break; + case ASSIGNATION: + sprops_for_assignation (p); + break; + case IDENTITY_RELATION: + sprops_for_identity_relation (p); + break; + case ACCESS_CLAUSE: + sprops_for_access_clause (p); + break; + case ENQUIRY_CLAUSE: + sprops_for_enquiry_clause (p); + break; + case LOOP_CLAUSE: + sprops_for_loop_clause (p); + break; + case ENCLOSED_CLAUSE: + sprops_for_enclosed_clause (p); + break; + case SERIAL_CLAUSE: + sprops_for_serial_clause (p); + break; + case CLOSED_CLAUSE: + sprops_for_closed_clause (p); + break; + case PARALLEL_CLAUSE: + sprops_for_parallel_clause (p); + break; + case CONDITIONAL_CLAUSE: + sprops_for_conditional_clause (p); + break; + case CONFORMITY_CLAUSE: + sprops_for_conformity_clause (p); + break; + case CASE_CLAUSE: + sprops_for_case_clause (p); + break; + case COLLATERAL_CLAUSE: + sprops_for_collateral_clause (p); + break; + case CALL: + sprops_for_call (p); + break; + case AND_FUNCTION: + case OR_FUNCTION: + sprops_for_logical_function (p); + break; + case ASSERTION: + sprops_for_assertion (p); + break; + case CAST: + sprops_for_cast (p); + break; + default: + gcc_unreachable (); + } + + /* Sanity check. */ + gcc_assert (ACCESS (p) != NO_ACCESS); + gcc_assert (ORIGIN (p) != NO_ORIGIN); +} + +/* Entry point for the sprops parser pass. */ + +void +a68_sprops (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + a68_sprops (SUB (p)); + + if (a68_yields_value (p)) + sprops_for_unit (p); + else if (a68_is_declaration (p)) + sprops_for_decl (p); + else + { + ORIGIN (p) = NO_ORIGIN; + ACCESS (p) = NO_ACCESS; + } + } +} diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc index 40ebe507492..2f64b0a8628 100644 --- a/gcc/algol68/a68-parser.cc +++ b/gcc/algol68/a68-parser.cc @@ -298,6 +298,82 @@ a68_is_loop_keyword (NODE_T *p) } } +/* Whether the construct denoted by P is a declaration that introduces some + defining identifier or indicant. */ + +bool +a68_is_declaration (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case IDENTITY_DECLARATION: + case VARIABLE_DECLARATION: + case PROCEDURE_DECLARATION: + case PROCEDURE_VARIABLE_DECLARATION: + case PRIORITY_DECLARATION: + case BRIEF_OPERATOR_DECLARATION: + case OPERATOR_DECLARATION: + case MODE_DECLARATION: + return true; + default: + return false; + } +} + +/* Whether the construct denoted by P yields a value. */ + +bool +a68_yields_value (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ACCESS_CLAUSE: + case ASSERTION: + case UNIT: + case ROUTINE_TEXT: + case ASSIGNATION: + case TERTIARY: + case MONADIC_FORMULA: + case FORMULA: + case SECONDARY: + case SLICE: + case SELECTION: + case PRIMARY: + case GENERATOR: + case CALL: + case CAST: + case AND_FUNCTION: + case OR_FUNCTION: + case FORMAL_HOLE: + case IDENTITY_RELATION: + case EMPTY_SYMBOL: + case NIHIL: + case SKIP: + case PARALLEL_CLAUSE: + case SERIAL_CLAUSE: + case CLOSED_CLAUSE: + case ENCLOSED_CLAUSE: + case LOOP_CLAUSE: + case CONDITIONAL_CLAUSE: + case CASE_CLAUSE: + case CONFORMITY_CLAUSE: + case COLLATERAL_CLAUSE: + case DENOTATION: + case IDENTIFIER: + case DEREFERENCING: + case DEPROCEDURING: + case PROCEDURING: + case WIDENING: + case UNITING: + case ROWING: + case VOIDING: + case JUMP: + return true; + default: + return false; + } +} + /* Get good attribute. */ enum a68_attribute @@ -599,6 +675,15 @@ a68_parser (const char *filename) a68_serial_dsa (TOP_NODE (&A68_JOB)); } + /* Static properties. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_sprops (TOP_NODE (&A68_JOB)); + } + + // XXX + // a68_dump_parse_tree (TOP_NODE (&A68_JOB), false, false, true); + /* Finalise syntax tree. */ if (ERROR_COUNT (&A68_JOB) == 0) { @@ -671,6 +756,8 @@ a68_new_node (void) DYNAMIC_STACK_ALLOCS (z) = false; PUBLICIZED (z) = false; NEGATED (z) = false; + ORIGIN (z) = NO_ORIGIN; + ACCESS (z) = ACCESS_DIR; return z; } @@ -791,6 +878,8 @@ a68_new_tag (void) PUBLICIZED (z) = false; ASCRIBED_ROUTINE_TEXT (z) = false; LOWERER (z) = NO_LOWERER; + ORIGIN (z) = NO_ORIGIN; + ACCESS (z) = ACCESS_DIR; TAX_TREE_DECL (z) = NULL_TREE; MOIF (z) = NO_MOIF; EXTERN_SYMBOL (z) = NO_TEXT; diff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h index 472a8bb29ef..e34817cd123 100644 --- a/gcc/algol68/a68-types.h +++ b/gcc/algol68/a68-types.h @@ -69,6 +69,28 @@ enum a68_tree_index ATI_MAX }; +enum a68_access +{ + /* Access. See a68-parser-sprops.cc. */ + NO_ACCESS = 0, + ACCESS_NIL, + ACCESS_DIR, + ACCESS_IND, + ACCESS_VAR +}; + +typedef enum a68_access ACCESS_T; + +enum a68_kindo +{ + /* Kind of origin. See a68-parser-sprops.cc. */ + KINDO_NIL = 0, + KINDO_CST, + KINDO_IDE, + KINDO_VAR, + KINDO_GEN +}; + /* * Type definitions. */ @@ -318,52 +340,25 @@ struct GTY(()) OPTIONS_T bool nil_checking; }; -/* The access class static property of a stored value determines how the value - can be reached at run-time. It is used by the lowering pass in order to - minimize copies at run-time. - - CONSTANT is for constant literals. At run-time these literals will either - reside in operand instructions or in space allocated in CONSTAB%. - - DIRIDEN (direct identifier) means that the value is stored on IDST% at some - static address. This is the access class used for values ascribed to - identifiers as long as the block in hich they are declared has not been - left. It is also used for values resulting from actions such as the - selection from a value possessed by an identifier or the dereferencing fo a - name corespodning to a variable. - - VARIDEN (variable identifier) is used for values which are names/variables. - The name is stored on IDST%. The static elaboration of the dereferencing of - a variable with access VARIDEN results in a value with access DIRIDEN, not - requiring any run-time action. Same happens with selections of variables of - access VARIDEN. - - INDIDEN (indirect identifier) is used for values that are stored in a memory - location in IDST%. The static elaboration of a dereferencing applied to a - value of access DIRIDEN. - - DIRWOST (direct working stack) is very much like DIRIDEN, except that the - value is stored in WOST% rather than in IDST%. This access is used for the - result of an action when this result does not preexist in memory and hence - has to be constructed in WOST%. - - INDWOST (indirect working stack) is very similar to INDIDEN. Such an access - can be obtained for example through the static elaboration of the - dereferencing of a name the access of which is DIRWOST. - - NIHIL is used to characterize the absence of value. This is used in the - static elaboration of a jump, a voiding and a call ith a void result. - - Note that in all these classes we assume as run-time the intermediate - language level we are lowering to, i.e. GENERIC. A DIRIDEN value, for - example, can very well stored in a register depending on further compiler - optimizations. */ - -#define ACCESS_NIHIL 0 -#define ACCESS_CONSTANT 1 -#define ACCESS_DIRIDEN 2 -#define ACCESS_INDIDEN 3 -#define ACCESS_DIRWOST 4 +/* An ORIGIN_T is a set of static properties that keep track of the story of + the value represented by an AST node, i.e. the way it has been obtained. + + KINDO is the kind of the origin. + BNO is the block number of the origin. + DEREFO is the flag dereferencing of the origin. + GENO is the flag local generator of the origin. + DIAGO is the location of the origin. */ + +#define NO_ORIGIN ((ORIGIN_T *) 0) + +struct GTY(()) ORIGIN_T +{ + enum a68_kindo kindo; + int bno; + bool derefo; + bool geno; + location_t diago; +}; /* A NODE_T is a node in the A68 Syntax tree produced by the lexer-scanner and later expanded by the Mailloux parser. @@ -424,7 +419,11 @@ struct GTY(()) OPTIONS_T pass. ORIGIN is a static property that describes the history of the entity denoted - by the node. This is only used in nodes denoting values. + by the node. This is only used in nodes denoting constructs that yield a + value, i.e. units. + + ACCESS is a static property that describes how to compute the value yielded + by the node given the GENERIC tree it lowers to. DYNAMIC_STACK_ALLOCS is a flag used in serial clause nodes. It determines whether the elaboration of the phrases in the serial clause may involve @@ -459,6 +458,8 @@ struct GTY((chain_next ("%h.next"), chain_prev ("%h.previous"))) NODE_T bool dynamic_stack_allocs; bool publicized; bool negated; + ORIGIN_T *origin; + enum a68_access access; }; #define NO_NODE ((NODE_T *) 0) @@ -620,7 +621,13 @@ struct GTY(()) TABLE_T module declaration. This is only used in entries where MOIF is not NO_MOIF. LOWERER is a lowering routine defined in a68-low-prelude.cc. These are used - in taxes that denote some pre-defined operator. */ + in taxes that denote some pre-defined operator. + + ORIGIN is a static property that describes the history of the value being + ascribed to the identifier. + + ACCESS is a static property that describes how to compute the value yielded + by the identifier given the GENERIC tree it lowers to. */ struct GTY((chain_next ("%h.next"))) TAG_T { @@ -635,6 +642,8 @@ struct GTY((chain_next ("%h.next"))) TAG_T tree tree_decl; MOIF_T *moif; LOWERER_T lowerer; + ORIGIN_T *origin; + enum a68_access access; TAG_T *next, *body; const char *extern_symbol; }; @@ -911,16 +920,16 @@ struct GTY(()) A68_T * in order to achieve a nice ALGOL-like field OF struct style. */ +#define ACCESS(p) ((p)->access) #define ASM_LABEL(m) ((m)->asm_label) #define BACKWARD(p) (p = PREVIOUS (p)) -#define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) -#define FORWARD(p) ((p) = NEXT (p)) #define A(p) ((p)->a) #define ANNOTATION(p) ((p)->annotation) #define ANONYMOUS(p) ((p)->anonymous) #define ATTRIBUTE(p) ((p)->attribute) #define ASCRIBED_ROUTINE_TEXT(p) ((p)->ascribed_routine_text) #define B(p) ((p)->b) +#define BNO(p) ((p)->origin->bno) #define BODY(p) ((p)->body) #define CAST(p) ((p)->cast) #define CHAR_IN_LINE(p) ((p)->char_in_line) @@ -931,9 +940,11 @@ struct GTY(()) A68_T #define COMMENT_LINE(p) ((p)->comment_line) #define COMMENT_TYPE(p) ((p)->comment_type) #define CTYPE(p) ((p)->ctype) +#define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) #define DEFLEXED(p) ((p)->deflexed_mode) -#define DEREFO(p) ((p).derefo) +#define DEREFO(p) ((p)->origin->derefo) #define DERIVATE(p) ((p)->derivate) +#define DIAGO(p) ((p)->origin->diago) #define DIM(p) ((p)->dim) #define DYNAMIC_STACK_ALLOCS(p) ((p)->dynamic_stack_allocs) #define EQUIVALENT(p) ((p)->equivalent_mode) @@ -950,11 +961,10 @@ struct GTY(()) A68_T #define F(p) ((p)->f) #define FILE_SOURCE_FD(p) ((p)->file_source_fd) #define FILE_SOURCE_NAME(p) ((p)->file_source_name) -#define FLEXO(p) ((p).flexo) -#define FLEXO_KNOWN(p) ((p).flexo_known) +#define FORWARD(p) ((p) = NEXT (p)) #define G(p) ((p)->g) #define GINFO(p) ((p)->genie) -#define GENO(p) ((p).geno) +#define GENO(p) ((p)->origin->geno) #define GET(p) ((p)->get) #define GPARENT(p) (PARENT (GINFO (p))) #define GREEN(p) ((p)->green) @@ -986,6 +996,7 @@ struct GTY(()) A68_T #define JUMP_STAT(p) ((p)->jump_stat) #define JUMP_TO(p) ((p)->jump_to) #define K(q) ((q)->k) +#define KINDO(p) ((p)->origin->kindo) #define LABELS(p) ((p)->labels) #define LAST(p) ((p)->last) #define LAST_LINE(p) ((p)->last_line) @@ -1059,6 +1070,7 @@ struct GTY(()) A68_T #define OPTION_LIST(p) (OPTIONS (p).list) #define OPTION_LOCAL(p) (OPTIONS (p).local) #define OPTION_NODEMASK(p) (OPTIONS (p).nodemask) +#define ORIGIN(p) ((p)->origin) #define OUT(p) ((p)->out) #define OUTER(p) ((p)->outer) #define P(q) ((q)->p) diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h index bf0e00e6d84..16642c6e0bd 100644 --- a/gcc/algol68/a68.h +++ b/gcc/algol68/a68.h @@ -340,6 +340,8 @@ char *a68_new_string (const char *t, ...); const char *a68_attribute_name (enum a68_attribute attr); location_t a68_get_node_location (NODE_T *p); location_t a68_get_line_location (LINE_T *line, const char *pos); +bool a68_yields_value (NODE_T *p); +bool a68_is_declaration (NODE_T *p); /* a68-parser-top-down.cc */ @@ -523,6 +525,10 @@ void a68_scope_checker (NODE_T *p); void a68_serial_dsa (NODE_T *p); +/* a68-parser-sprops.cc */ + +void a68_sprops (NODE_T *p); + /* a68-parser-pragmat.cc */ void a68_handle_pragmats (NODE_T *p); @@ -1096,7 +1102,8 @@ char *a68_find_archive_export_data (const char *filename, int fd, size_t *size); /* a68-parser-debug.cc */ -void a68_dump_parse_tree (NODE_T *p, bool tables = false, bool levels = false); +void a68_dump_parse_tree (NODE_T *p, bool tables = false, bool levels = false, + bool sprops = false); void a68_dump_modes (MOID_T *m); void a68_dump_moif (MOIF_T *moif); -- 2.39.5
