Signed-off-by: Jose E. Marchesi <[email protected]>
gcc/ChangeLog
* algol68/a68-low.cc: New file.
* algol68/a68-low-misc.cc: Likewise.
---
gcc/algol68/a68-low-misc.cc | 213 +++++++
gcc/algol68/a68-low.cc | 1153 +++++++++++++++++++++++++++++++++++
2 files changed, 1366 insertions(+)
create mode 100644 gcc/algol68/a68-low-misc.cc
create mode 100644 gcc/algol68/a68-low.cc
diff --git a/gcc/algol68/a68-low-misc.cc b/gcc/algol68/a68-low-misc.cc
new file mode 100644
index 00000000000..e2ad5cb412b
--- /dev/null
+++ b/gcc/algol68/a68-low-misc.cc
@@ -0,0 +1,213 @@
+/* Lower miscellaneous tree nodes to GENERIC.
+ Copyright (C) 2025 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/>. */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "print-tree.h"
+#include "gimplify.h"
+#include "dumpfile.h"
+#include "convert.h"
+
+#include "a68.h"
+
+/* Lower an assertion.
+
+ assertion : assert symbol, enclosed clause.
+*/
+
+tree
+a68_lower_assertion (NODE_T *p, LOW_CTX_T ctx)
+{
+ if (!OPTION_ASSERT (&A68_JOB))
+ return a68_get_empty();
+
+ /* Build the call to the assert run-time function. */
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_ASSERT,
+ void_type_node, 2,
+ filename,
+ build_int_cst (unsigned_type_node, lineno));
+ /* Check condition and call assert if required. */
+ tree assertion = fold_build2_loc (a68_get_node_location (p),
+ COMPOUND_EXPR,
+ a68_void_type,
+ build2_loc (a68_get_node_location (p),
+ TRUTH_ORIF_EXPR,
+ a68_int_type,
+ a68_lower_tree (NEXT (SUB (p)),
ctx),
+ fold_build2 (COMPOUND_EXPR,
+ a68_int_type,
+ call,
+ build_int_cst
(a68_int_type, 0))),
+ a68_get_empty ());
+ TREE_SIDE_EFFECTS (assertion) = 1;
+ return assertion;
+}
+
+/* Lower a jump to a label.
+
+ jump : goto symbol, identifier;
+ identifier.
+
+ A jump lowers into a ({ GOTO_EXPR; EMPTY }). */
+
+tree
+a68_lower_jump (NODE_T *p, LOW_CTX_T ctx)
+{
+ NODE_T *label_identifier = SUB (p);
+ MOID_T *jump_mode = MOID (p);
+ if (!IS (label_identifier, IDENTIFIER))
+ FORWARD (label_identifier);
+
+ /* Create LABEL_DECL if necessary and chain it in both current block and bind
+ expression. */
+ if (TAX_TREE_DECL (TAX (label_identifier)) == NULL_TREE)
+ {
+ tree label_decl = build_decl (a68_get_node_location (label_identifier),
+ LABEL_DECL,
+ a68_get_mangled_identifier (NSYMBOL
(label_identifier)),
+ void_type_node);
+ TAX_TREE_DECL (TAX (label_identifier)) = label_decl;
+ }
+
+ MOID (label_identifier) = M_VOID;
+ return fold_build2_loc (a68_get_node_location (p),
+ COMPOUND_EXPR,
+ CTYPE (jump_mode),
+ fold_build1_loc (a68_get_node_location (p),
+ GOTO_EXPR,
+ void_type_node,
+ a68_lower_tree (label_identifier,
ctx)),
+ a68_get_skip_tree (jump_mode));
+}
+
+/* Lower a parameter into a chain of PARAM_DECLs.
+
+ parameter : declarer, identifier;
+ parameter, comma symbol, identifier.
+*/
+
+tree
+a68_lower_parameter (NODE_T *p, LOW_CTX_T ctx)
+{
+ tree prev_parm_decls = NULL_TREE;
+ NODE_T *identifier = NO_NODE;
+ if (IS (SUB (p), PARAMETER))
+ {
+ prev_parm_decls = a68_lower_tree (SUB (p), ctx);
+ identifier = NEXT (NEXT (SUB (p)));
+ }
+ else
+ identifier = NEXT (SUB (p));
+
+ /* Create the PARM_DECL. */
+ tree parm_decl = build_decl (a68_get_node_location (p),
+ PARM_DECL,
+ a68_get_mangled_identifier (NSYMBOL
(identifier)),
+ CTYPE (MOID (identifier)));
+ DECL_CONTEXT (parm_decl) = current_function_decl;
+ DECL_ARG_TYPE (parm_decl) = TREE_TYPE (parm_decl);
+ TAX_TREE_DECL (TAX (identifier)) = parm_decl;
+
+ layout_decl (parm_decl, 0);
+
+ if (prev_parm_decls != NULL)
+ return chainon (prev_parm_decls, parm_decl);
+ else
+ return parm_decl;
+}
+
+/* Lower a list of parameters into a chain of PARAM_DECLs.
+
+ parameter list : parameter;
+ parameter list; comma symbol; parameter.
+*/
+
+tree
+a68_lower_parameter_list (NODE_T *p, LOW_CTX_T ctx)
+{
+ tree parm_decl = NULL_TREE;
+ tree prev_parm_decls = NULL_TREE;
+ if (IS (SUB (p), PARAMETER_LIST))
+ {
+ prev_parm_decls = a68_lower_tree (SUB (p), ctx);
+ parm_decl = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+ }
+ else
+ parm_decl = a68_lower_tree (SUB (p), ctx);
+
+ gcc_assert (parm_decl != NULL_TREE);
+ if (prev_parm_decls != NULL)
+ return chainon (prev_parm_decls, parm_decl);
+ else
+ return parm_decl;
+}
+
+/* Lower a parameter pack into a chain of PARAM_DECLs.
+
+ parameter pack : open symbol, parameter list, close symbol.
+*/
+
+tree
+a68_lower_parameter_pack (NODE_T *p, LOW_CTX_T ctx)
+{
+ /* Lower the contained PARAMETER_LIST. */
+ return a68_lower_tree (NEXT (SUB (p)), ctx);
+}
+
+/* Lower an applied operator.
+
+ Applied operators lower into a function object that gets one argument in
+ case of monadic operators, or two arguments in case of dyadic operators. */
+
+tree
+a68_lower_operator (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+ /* This is an user defined operator. Handle it in a similar way than applied
+ identifiers. */
+ tree func_decl = TAX_TREE_DECL (TAX (p));
+ if (func_decl == NULL_TREE)
+ {
+ if (IN_PROC (TAX (p)))
+ func_decl = a68_make_proc_identity_declaration_decl (p);
+ else
+ func_decl = a68_make_identity_declaration_decl (p);
+ TAX_TREE_DECL (TAX (p)) = func_decl;
+ }
+ return func_decl;
+}
diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc
new file mode 100644
index 00000000000..69376081b03
--- /dev/null
+++ b/gcc/algol68/a68-low.cc
@@ -0,0 +1,1153 @@
+/* Lower the Algol 68 parse tree to GENERIC.
+ Copyright (C) 2025 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/>. */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "cgraph.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "tree-iterator.h"
+#include "stringpool.h"
+#include "print-tree.h"
+#include "gimplify.h"
+#include "dumpfile.h"
+#include "convert.h"
+
+#include "a68.h"
+
+/* Return a tree with an identifier for the mangled version of a given
+ name. */
+
+tree
+a68_get_mangled_identifier (const char *name)
+{
+ char *mangled_name = (char *) alloca (strlen (name) + 1);
+ memcpy (mangled_name, name, strlen (name) + 1);
+
+ /* Avoid MONADS and NOMADS. */
+ for (char *p = mangled_name; *p != '\0'; ++p)
+ {
+ if (strchr (MONADS, *p) != NULL || strchr (NOMADS, *p) != NULL
+ || strchr (":=", *p))
+ *p = '_';
+ }
+
+ return get_identifier (mangled_name);
+}
+
+/* Return a tree with the EMPTY value.
+
+ EMPTY is the only denotation of the VOID mode. It is used in unions to
+ denote "no value". It must have size zero, so it lowers into an empty
+ constructor with zero elements of type void. This is what GNU C uses to
+ implement the empty struct extension. */
+
+tree
+a68_get_empty (void)
+{
+ return build_constructor (a68_void_type, NULL);
+}
+
+/* Return a tree with the yielding of SKIP of a given mode.
+
+ SKIP stands for some value of some given mode. It shall be used only in a
+ context where the compiler can determine the mode.
+
+ The particular value to which it elaborates is non-important, but this
+ compiler always uses the same values. See the a68_get_ref_*_tree functions
+ for details on what values are these. */
+
+tree
+a68_get_skip_tree (MOID_T *m)
+{
+ tree expr = NULL_TREE;
+
+ while (EQUIVALENT (m) != NO_MOID)
+ m = EQUIVALENT (m);
+
+ if (IS_INTEGRAL (m))
+ expr = a68_get_int_skip_tree (m);
+ else if (m == M_CHAR)
+ expr = a68_get_char_skip_tree ();
+ else if (m == M_BOOL)
+ expr = a68_get_bool_skip_tree ();
+ else if (IS_REAL (m))
+ expr = a68_get_real_skip_tree (m);
+ else if (IS_BITS (m))
+ expr = a68_get_bits_skip_tree (m);
+ else if (IS_REF (m))
+ expr = a68_get_ref_skip_tree (m);
+ else if (IS (m, PROC_SYMBOL))
+ expr = a68_get_proc_skip_tree (m);
+ else if (IS_STRUCT (m))
+ expr = a68_get_struct_skip_tree (m);
+ else if (IS_UNION (m))
+ expr = a68_get_union_skip_tree (m);
+ else if (IS_FLEXETY_ROW (m))
+ expr = a68_get_multiple_skip_tree (m);
+ else if (m == M_STRING)
+ expr = a68_get_string_skip_tree ();
+ else if (m == M_ROWS || IS (m, SERIES_MODE))
+ {
+ /* XXX assert that all modes in the series are rows? */
+ tree rows_type = CTYPE (M_ROWS);
+ tree dim_field = TYPE_FIELDS (rows_type);
+ tree triplets_field = TREE_CHAIN (dim_field);
+ tree null_pointer = build_int_cst (TREE_TYPE (triplets_field), 0);
+ expr = build_constructor_va (rows_type, 2,
+ dim_field, size_zero_node,
+ triplets_field, null_pointer);
+ }
+ else if (m == M_VOID || m == M_HIP)
+ expr = a68_get_empty ();
+ else
+ {
+ fatal_error (UNKNOWN_LOCATION,
+ "get skip tree: cannot compute SKIP for mode %s",
+ a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m), true));
+ gcc_unreachable ();
+ }
+
+ return expr;
+}
+
+/* Given a tree node EXP holding a value of mode M:
+
+ *NUM_REFS is set to the number of REFs in M.
+
+ *NUM_POINTERS is set to the number of pointers in the type of EXP that
+ correspond to the REFs in M. */
+
+void
+a68_ref_counts (tree exp, MOID_T *m, int *num_refs, int *num_pointers)
+{
+ /* Count REFs in M and pointers in the type of EXP. Note that VAR_DECLs
+ corresponding to REF PROC are of type pointer, so these should not count
+ for the count! */
+
+ /* Make sure we are accessing the real mode definition. */
+ while (EQUIVALENT (m) != NO_MOID)
+ m = EQUIVALENT (m);
+
+ *num_refs = 0;
+ *num_pointers = 0;
+ for (MOID_T *s = m; s != NO_MOID && IS_REF (s); s = SUB (s))
+ *num_refs += 1;
+ for (tree p = TREE_TYPE (exp);
+ p != NULL_TREE && POINTER_TYPE_P (p) && TREE_CODE (TREE_TYPE (p)) !=
FUNCTION_TYPE;
+ p = TREE_TYPE (p))
+ *num_pointers += 1;
+
+ gcc_assert (*num_refs >= *num_pointers);
+}
+
+/* The Algol 68 variable declaration
+
+ [LOC|HEAP] AMODE foo;
+
+ Is in principle equivalent to the identity declaration
+
+ REF AMODE foo = [LOC|HEAP] AMODE;
+
+ In both cases the object ascribed to the defining identifier `foo' is of
+ mode REF AMODE. The ascribed object is a name which is created by a
+ generator implied in the actual declarer in the first case, and an explicit
+ generator in the initialization expression in the second case.
+
+ However, this front-end implements these two cases differently in order to
+ reduce the amount of both indirect addressing and of storage:
+
+ - The variable declaration `[LOC|HEAP] AMODE foo;' lowers into a VAR_DECL
+ with type ATYPE provided that the generator is LOC and that it contains no
+ rows. Accessing it requires direct addressing. When its address is
+ required, an ADDR_EXPR shall be used.
+
+ - The identity declaration `REF AMODE foo = LOC AMODE;' lowers into a
+ VAR_DECL with type *ATYPE. Accessing it requires indirect addressing. It
+ is effectively a pointer.
+
+ This introduces the complication that an expression (the VAR_DECL) whose
+ type is TYPE can appear in a place where *TYPE is expected. This function,
+ given the required mode and an expression, adds as many ADDR_EXPR to EXPR as
+ necessary so the resulting value is of the required type. Other than this
+ nuisance, the parser guarantees that the entities have the right type at the
+ location they appear, so a call to a68_consolidate_ref is all must be needed
+ at any point in the lowering process to guarantee a valid value for the
+ context.
+
+ This function expects:
+ - That the type of EXPR is zero or more pointers to a base type BTYPE.
+ - That the mode M is zero or more REFs to a base non-ref mode AMODE.
+ - That the number of pointers in the type of EXPR is less or equal than the
+ number of REFs in the mode M.
+ - That BTYPE and AMODE are equivalent. */
+
+tree
+a68_consolidate_ref (MOID_T *m, tree expr)
+{
+ int num_refs, num_pointers;
+ a68_ref_counts (expr, m, &num_refs, &num_pointers);
+
+ /* Address EXPR as many times as necessary to match the number of REFs in the
+ desired mode. */
+ while (num_pointers < num_refs)
+ {
+ if (TREE_CODE (expr) == COMPOUND_EXPR)
+ {
+ /* (..., x) -> (..., &x) */
+ // gcc_assert (TREE_CODE (TREE_OPERAND (expr, 0)) ==
MODIFY_EXPR);
+ // gcc_assert (VAR_P (TREE_OPERAND (expr, 1)));
+ TREE_OPERAND (expr, 1) = a68_consolidate_ref (m, TREE_OPERAND (expr,
1));
+ TREE_TYPE (expr) = TREE_TYPE (TREE_OPERAND (expr, 1));
+ }
+ else
+ {
+ /* x -> &x */
+ if (TREE_CODE (expr) == INDIRECT_REF)
+ /* expr is an indirection. Remove the pointer rather than adding
+ an addr. This avoids &* situations and marking stuff as
+ addressable unnecessarily. */
+ expr = TREE_OPERAND (expr,0);
+ else
+ {
+ TREE_ADDRESSABLE (expr) = true;
+ expr = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE
(expr)), expr);
+ }
+ }
+ num_pointers += 1;
+ }
+
+ return expr;
+}
+
+/* Make a declaration for an anonymous routine of mode MODE. */
+
+tree
+a68_make_anonymous_routine_decl (MOID_T *mode)
+{
+ /* The CTYPE of MODE is a pointer to a function. We need the pointed
+ function type for the FUNCTION_DECL. */
+ tree func_type = TREE_TYPE (CTYPE (mode));
+ tree func_decl = build_decl (UNKNOWN_LOCATION,
+ FUNCTION_DECL,
+ NULL_TREE /* name, set below. */,
+ func_type);
+ char *name = xasprintf ("routine%d", DECL_UID (func_decl));
+ DECL_NAME (func_decl) = a68_get_mangled_identifier (name);
+ free (name);
+ DECL_EXTERNAL (func_decl) = 0;
+ DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range ();
+ /* Nested functions should be addressable.
+ XXX this should be propagated to their containing functions, so for now
+ we mark them all as addressable. */
+ TREE_ADDRESSABLE (func_decl) = 1;
+ /* A nested function is not global. */
+ TREE_PUBLIC (func_decl) = a68_in_global_range ();
+ TREE_STATIC (func_decl) = 1;
+
+ return func_decl;
+}
+
+/* Make a declaration for a constant procedure or operator. */
+
+tree
+a68_make_proc_identity_declaration_decl (NODE_T *identifier)
+{
+ /* The CTYPE of MODE is a pointer to a function. We need the pointed
+ function type for the FUNCTION_DECL. */
+ tree func_type = TREE_TYPE (CTYPE (MOID (identifier)));
+ tree func_decl = build_decl (UNKNOWN_LOCATION,
+ FUNCTION_DECL,
+ a68_get_mangled_identifier (NSYMBOL
(identifier)),
+ func_type);
+ DECL_EXTERNAL (func_decl) = 0;
+ DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range ();
+ /* Nested functions should be addressable.
+ XXX this should be propagated to their containing functions, so for now
+ we mark them all as addressable. */
+ TREE_ADDRESSABLE (func_decl) = 1;
+ /* A nested function is not global. */
+ TREE_PUBLIC (func_decl) = a68_in_global_range ();
+ TREE_STATIC (func_decl) = 1;
+
+ return func_decl;
+}
+
+/* Make a declaration for an identity declaration. */
+
+tree
+a68_make_identity_declaration_decl (NODE_T *identifier)
+{
+ tree type = CTYPE (MOID (identifier));
+
+ tree decl = build_decl (a68_get_node_location (identifier),
+ VAR_DECL,
+ a68_get_mangled_identifier (NSYMBOL (identifier)),
+ type);
+ TREE_PUBLIC (decl) = 0;
+#if 0
+ if (!IS_REF (MOID (identifier)))
+ TREE_CONSTANT (decl) = 1;
+#endif
+ DECL_INITIAL (decl) = a68_get_skip_tree (MOID (identifier));
+ return decl;
+}
+
+/* Make a declaration for a variable declaration.
+ The mode of the given identifier is expected to be a REF AMODE. */
+
+tree
+a68_make_variable_declaration_decl (NODE_T *identifier)
+{
+ gcc_assert (IS_REF (MOID (identifier)));
+
+ MOID_T *mode = MOID (identifier);
+ bool use_pointer = ((HEAP (TAX (identifier)) == HEAP_SYMBOL)
+ || HAS_ROWS (SUB (MOID (identifier))));
+ tree type = use_pointer ? CTYPE (mode) : CTYPE (SUB (mode));
+ tree decl = build_decl (a68_get_node_location (identifier),
+ VAR_DECL,
+ a68_get_mangled_identifier (NSYMBOL (identifier)),
+ type);
+ TREE_PUBLIC (decl) = 0;
+ DECL_INITIAL (decl) = a68_get_skip_tree (use_pointer ? mode : SUB (mode));
+ return decl;
+}
+
+/* Do a checked indirection.
+
+ P is a tree node used for its location information.
+ EXP is an expression that gets indirected.
+ EXP_MODE is the mode of exp. */
+
+tree
+a68_checked_indirect_ref (NODE_T *p, tree exp, MOID_T *exp_mode)
+{
+ tree exp_type = TREE_TYPE (exp);
+ tree nil_check = NULL_TREE;
+
+ if (OPTION_NIL_CHECKING (&A68_JOB))
+ {
+ exp = save_expr (exp);
+ tree consolidated_exp = a68_consolidate_ref (exp_mode, exp);
+
+ /* Check whether we are dereferencing NIL. */
+ unsigned int lineno = NUMBER (LINE (INFO (p)));
+ const char *filename_str = FILENAME (LINE (INFO (p)));
+ tree filename = build_string_literal (strlen (filename_str) + 1,
+ filename_str);
+ tree call = a68_build_libcall (A68_LIBCALL_DEREFNIL,
+ void_type_node, 2,
+ filename,
+ build_int_cst (unsigned_type_node,
lineno));
+ call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call,
boolean_false_node);
+ nil_check = fold_build2 (NE_EXPR, exp_type,
+ consolidated_exp,
+ build_int_cst (exp_type, 0));
+ nil_check = fold_build2 (TRUTH_ORIF_EXPR, exp_type,
+ nil_check, call);
+ }
+
+ tree deref = fold_build1 (INDIRECT_REF, TREE_TYPE (exp_type), exp);
+ if (nil_check == NULL_TREE)
+ return deref;
+ else
+ return fold_build2 (COMPOUND_EXPR, TREE_TYPE (deref),
+ nil_check, deref);
+}
+
+/* Deref a given expression EXP whose mode is MOID (P).
+
+ The value to dereference always corresponds to a name, but it may consist
+ of:
+
+ - Not a pointer, in which case corresponds to a name lowered to a VAR_DECL.
+
+ - A pointer to a function, in which case corresponds to a name of mode REF
+ PROC, lowered to a VAR_DECL.
+
+ - Any other pointer corresponds to a name lowered to a VAR_DECL that is a
+ pointer.
+
+ In the first two cases, in both r-value and l-value situations the expected
+ result is achieved by just returning the value: in r-value the decl denotes
+ the value, in l-value the decl denotes the (direct) address of the
+ value. */
+
+tree
+a68_low_deref (tree exp, NODE_T *p)
+{
+ int num_refs, num_pointers;
+ a68_ref_counts (exp, MOID (p), &num_refs, &num_pointers);
+
+ if (num_refs > num_pointers)
+ return exp;
+ else
+ {
+ gcc_assert (num_refs == num_pointers);
+ return a68_checked_indirect_ref (p, exp, MOID (p));
+ }
+}
+
+/* Get a deep-copy of a given Algol 68 value EXP. */
+
+tree
+a68_low_dup (tree expr, bool use_heap)
+{
+ tree dup = NULL_TREE;
+ tree type = TREE_TYPE (expr);
+
+ /* XXX */
+ use_heap = true;
+
+ /* Determine the mode corresponding to the type of EXPR. */
+ MOID_T *m = a68_type_moid (type);
+ gcc_assert (m != NO_MOID);
+ while (EQUIVALENT (m) != NO_MOID)
+ m = EQUIVALENT (m);
+
+ if (A68_ROW_TYPE_P (type))
+ {
+ /* We need to copy the elements as well as the descriptor. There is no
+ need to check bounds. */
+
+ /* Deflexe the mode as appropriate. */
+ while (IS_FLEX (m))
+ m = SUB (m);
+ gcc_assert (IS_ROW (m) || m == M_STRING);
+
+ a68_push_range (NULL);
+
+ /* First allocate space for the dupped elements. */
+ expr = save_expr (expr);
+ tree elements = a68_multiple_elements (expr);
+ tree element_pointer_type = TREE_TYPE (elements);
+ tree element_type = TREE_TYPE (element_pointer_type);
+ tree new_elements_size = save_expr (a68_multiple_elements_size (expr));
+ tree new_elements = a68_lower_tmpvar ("new_elements%",
+ TREE_TYPE (elements),
+ (use_heap
+ ? a68_lower_malloc (TREE_TYPE
(TREE_TYPE (elements)),
+
new_elements_size)
+ : a68_lower_alloca (TREE_TYPE
(TREE_TYPE (elements)),
+
new_elements_size)));
+
+ /* Then copy the elements.
+
+ If the mode of the elements stored in the multiple dont have rows,
+ then we can just use memcpy. Otherwise, we have to loop and recurse
+ to dup all the elements in the multiple one by one.
+
+ The above applies to multiples of any number of dimensions. */
+ if (m == M_STRING || !HAS_ROWS (SUB (m)))
+ {
+ a68_add_stmt (a68_lower_memcpy (new_elements,
+ elements,
+ new_elements_size));
+ a68_add_stmt (new_elements);
+ }
+ else
+ {
+ /* Note that num_elems includes elements that are not accessible due
+ to trimming. */
+ tree num_elems = a68_lower_tmpvar ("numelems%", size_type_node,
+ fold_build2 (TRUNC_DIV_EXPR,
sizetype,
+ new_elements_size,
+ size_in_bytes
(element_type)));
+ tree orig_elements = a68_lower_tmpvar ("orig_elements%",
+ element_pointer_type,
elements);
+ tree index = a68_lower_tmpvar ("index%", size_type_node,
size_zero_node);
+
+ /* Begin of loop body. */
+ a68_push_range (NULL);
+
+ /* if (index == num_elems) break; */
+ a68_add_stmt (fold_build1 (EXIT_EXPR,
+ void_type_node,
+ fold_build2 (EQ_EXPR,
+ size_type_node,
+ index, num_elems)));
+ /* new_elements[index] = elements[index] */
+ tree offset = fold_build2 (MULT_EXPR, sizetype,
+ index, size_in_bytes (element_type));
+ tree new_elem_lvalue = fold_build2 (MEM_REF, element_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ new_elements,
+ offset),
+ fold_convert
(element_pointer_type,
+ integer_zero_node));
+ tree elem = fold_build2 (MEM_REF, element_type,
+ fold_build2 (POINTER_PLUS_EXPR,
+ element_pointer_type,
+ orig_elements,
+ offset),
+ fold_convert (element_pointer_type,
+ integer_zero_node));
+ a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type,
+ new_elem_lvalue,
+ a68_low_dup (elem, use_heap)));
+ /* index++ */
+ a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR,
+ size_type_node,
+ index, size_one_node));
+ tree loop_body = a68_pop_range ();
+ /* End of loop body. */
+
+ a68_add_stmt (fold_build1 (LOOP_EXPR,
+ void_type_node,
+ loop_body));
+ a68_add_stmt (new_elements);
+ }
+
+ new_elements = a68_pop_range ();
+ TREE_TYPE (new_elements) = element_pointer_type;
+
+ /* Now build a descriptor pointing to the dupped elements and return it.
+ Note that the descriptor is always allocated on the stack. */
+ dup = a68_row_value_raw (type,
+ a68_multiple_triplets (expr),
+ new_elements,
+ new_elements_size);
+ }
+ else if (!HAS_ROWS (m))
+ {
+ /* Non-multiple values that do not contain rows do not need to be dupped,
+ since they can be just moved around using the semantics of
+ MODIFY_EXPR. */
+ dup = expr;
+ }
+ else if (A68_STRUCT_TYPE_P (type))
+ {
+ /* Since struct value can contain multiples and unions and other values
+ that require deep copy, we cannot simply rely on the C semantics of a
+ MODIFY_EXPR. */
+ tree struct_type = type;
+ vec <constructor_elt, va_gc> *ce = NULL;
+
+ expr = save_expr (expr);
+ for (tree field = TYPE_FIELDS (struct_type);
+ field;
+ field = TREE_CHAIN (field))
+ {
+ CONSTRUCTOR_APPEND_ELT (ce, field,
+ a68_low_dup (fold_build3 (COMPONENT_REF,
+ TREE_TYPE (field),
+ expr,
+ field,
+ NULL_TREE),
+ use_heap));
+ }
+ dup = build_constructor (struct_type, ce);
+ }
+ else if (A68_UNION_TYPE_P (type))
+ {
+ /* We need to recurse in whatever type corresponding to the active mode
+ in the united value. This shall be done at run-time by using a series
+ of
+
+ IF overhead IS index of mode blah in union
+ THEN dup = dup_type (CTYPE (mode blah in union))
+ FI
+ */
+
+ MOID_T *union_mode = a68_type_moid (type);
+
+ a68_push_range (union_mode);
+ dup = a68_lower_tmpvar ("dup%", type, expr);
+
+ tree cunion_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+ tree field_decl = TYPE_FIELDS (cunion_type);
+ while (EQUIVALENT (union_mode) != NO_MOID)
+ union_mode = EQUIVALENT (union_mode);
+ for (PACK_T *pack = PACK (union_mode); pack != NO_PACK; FORWARD (pack))
+ {
+ tree continue_label_decl = build_decl (UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL, /* Set below. */
+ void_type_node);
+ char *label_name = xasprintf ("continue%d%%", DECL_UID
(continue_label_decl));
+ DECL_NAME (continue_label_decl) = get_identifier (label_name);
+ free (label_name);
+
+ a68_add_decl (continue_label_decl);
+
+ a68_add_stmt (fold_build2 (TRUTH_ORIF_EXPR,
+ integer_type_node,
+ fold_build2 (EQ_EXPR,
+ integer_type_node,
+ a68_union_overhead (dup),
+ size_int
(a68_united_mode_index (union_mode, MOID (pack)))),
+ fold_build2 (COMPOUND_EXPR,
+ integer_type_node,
+ build1 (GOTO_EXPR,
void_type_node, continue_label_decl),
+ integer_zero_node)));
+ a68_add_stmt (fold_build2 (MODIFY_EXPR, type,
+ fold_build3 (COMPONENT_REF,
+ TREE_TYPE (field_decl),
+ a68_union_cunion (dup),
+ field_decl,
+ NULL_TREE),
+ a68_low_dup (fold_build3 (COMPONENT_REF,
+ TREE_TYPE
(field_decl),
+ a68_union_cunion
(dup),
+ field_decl,
+ NULL_TREE),
+ use_heap)));
+ a68_add_stmt (build1 (LABEL_EXPR, void_type_node,
continue_label_decl));
+ field_decl = TREE_CHAIN (field_decl);
+ }
+
+ a68_add_stmt (dup);
+ dup = a68_pop_range ();
+ }
+ else
+ /* Not an Algol 68 value. */
+ gcc_unreachable ();
+
+ return dup;
+}
+
+/* Lower code to ascribe the value yielded by the expression in RHS to the
+ defining identifier implied by the LHS, which is a VAR_DECL tree. MODE is
+ the mode of the value to be ascribed. */
+
+tree
+a68_low_ascription (MOID_T *mode, tree lhs, tree rhs)
+{
+ gcc_assert (VAR_P (lhs));
+
+ tree type = CTYPE (mode);
+ if (IS (mode, PROC_SYMBOL))
+ {
+ /* A pointer to a function, or a function, is expected at the right hand
+ side. We need a pointer for the left hand side.. */
+ if (TREE_CODE (TREE_TYPE (rhs)) == FUNCTION_TYPE)
+ {
+ type = build_pointer_type (type);
+ rhs = fold_build1 (ADDR_EXPR, type, rhs);
+ }
+ }
+
+ if (HAS_ROWS (mode))
+ rhs = a68_low_dup (rhs);
+ return fold_build2 (MODIFY_EXPR, type, lhs, rhs);
+}
+
+/* Perform an assignation of RHS to LHS.
+
+ MODE_RHS is the mode of the rhs.
+ MODE_LHS is the mode of the lhs.
+
+ MODE_LHS shall be REF [FLEX] MODE_LHS. */
+
+tree
+a68_low_assignation (NODE_T *p,
+ tree lhs, MOID_T *mode_lhs,
+ tree rhs, MOID_T *mode_rhs)
+{
+ NODE_T *lhs_node = SUB (p);
+ tree assignation = NULL_TREE;
+ tree orig_rhs = rhs;
+
+ if (IS_FLEXETY_ROW (mode_rhs))
+ {
+ /* Make a deep copy of the rhs. Note that we have to use the heap
+ because the scope of the lhs may be older than the scope of the rhs.
+ XXX this can be ommitted if a68_multiple_copy_elems below supports
+ overlapping multiples. */
+ if (HAS_ROWS (mode_rhs))
+ rhs = a68_low_dup (rhs, true /* use_heap */);
+ rhs = save_expr (rhs);
+
+ /* Determine whether the REF [FLEX] MODE_LHS is flexible. */
+ if (SUB (mode_lhs) == M_STRING || IS_FLEX (SUB (mode_lhs)))
+ {
+ /* Assigning to a flexible name updates descriptor with new bounds
+ and also sets the elements to the dup of the rhs. No boundscheck
+ is peformed. XXX but bound checking in contained values may be
+ necessary, ghost elements. */
+ if (POINTER_TYPE_P (TREE_TYPE (lhs))
+ && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs))
+ {
+ /* Make sure to not evaluate the expression yielding the pointer
+ more than once. */
+ lhs = save_expr (lhs);
+ tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs,
mode_lhs);
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (lhs),
+ fold_build2 (MODIFY_EXPR, TREE_TYPE
(lhs),
+ deref_lhs, rhs),
+ lhs);
+ }
+ else
+ {
+ /* 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 doing so
inroduces
+ no side-effects. */
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (lhs),
+ fold_build2 (MODIFY_EXPR, TREE_TYPE
(lhs),
+ lhs, rhs),
+ lhs);
+ }
+ }
+ else
+ {
+ /* Dereference the multiple at the left-hand side. This may require
+ indirection. */
+
+ tree effective_lhs;
+ if (POINTER_TYPE_P (TREE_TYPE (lhs)))
+ {
+ /* The name at the lhs is a pointer. */
+ gcc_assert (TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs));
+ lhs = save_expr (lhs);
+ effective_lhs = a68_checked_indirect_ref (lhs_node, lhs,
mode_lhs);
+ }
+ 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
+ doing so introduces no side-effects. */
+ effective_lhs = lhs;
+ }
+
+ /* Copy over the elements in a loop. The space occupied by the
+ previous elements stored in the lhs multiple will be recovered by
+ either stack shrinkage or garbage collected. */
+ tree copy_elements = a68_multiple_copy_elems (mode_rhs,
effective_lhs, rhs);
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (lhs),
+ copy_elements,
+ lhs);
+
+ /* Check the bounds of the multiple at the rhs to make sure they are
+ the same than the bounds of the multiple already referred by the
+ lhs. If the bounds don't match then emit a run-time error. */
+ if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (assignation),
+ a68_multiple_bounds_check_equal (p,
+
effective_lhs,
+ rhs),
+ assignation);
+
+ }
+ }
+ else
+ {
+ /* First make sure we got a pointer in the RHS in case it is a name. */
+ rhs = a68_consolidate_ref (mode_rhs, rhs);
+
+ /* The assignation implies copying the entire value being assigned, so
+ make sure we do a deep copy whenever needed. Note that we have to use
+ the heap because the scope of the lhs may be older than the scope of
+ the rhs. */
+ if (HAS_ROWS (mode_rhs))
+ rhs = a68_low_dup (rhs, true /* use_heap */);
+
+ if (POINTER_TYPE_P (TREE_TYPE (lhs))
+ && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs))
+ {
+ /* If the left hand side is a pointer, deref it, but return the
+ pointer. Make sure to not evaluate the expression yielding the
+ pointer more than once. */
+ lhs = save_expr (lhs);
+ tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs);
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (lhs),
+ fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+ deref_lhs, rhs),
+ lhs);
+ }
+ else
+ {
+ /* Otherwise the lhs is either a variable or a component ref as an
+ l-value. It is ok to evaluate it as an r-value as well as doing
+ so introduces no side-effects. */
+ assignation = fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (lhs),
+ fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+ lhs, rhs),
+ lhs);
+ }
+ }
+
+ /* Since it is been assigned to a name, the rhs is no longer constant. */
+ if (A68_ROW_TYPE_P (TREE_TYPE (orig_rhs)) || A68_STRUCT_TYPE_P (TREE_TYPE
(orig_rhs)))
+ TREE_CONSTANT (orig_rhs) = 0;
+ return assignation;
+}
+
+/* Build a tree that copies SIZE bytes from SRC into DST. */
+
+tree
+a68_lower_memcpy (tree dst, tree src, tree size)
+{
+ return build_call_expr (builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+ dst, src, size);
+}
+
+/* Build a tree that allocates SIZE bytes on the stack and returns a *TYPE
+ pointer to it. */
+
+tree
+a68_lower_alloca (tree type, tree size)
+{
+ tree call = builtin_decl_explicit (BUILT_IN_ALLOCA_WITH_ALIGN);
+ call = build_call_expr_loc (UNKNOWN_LOCATION, call, 2,
+ size,
+ size_int (TYPE_ALIGN (type)));
+ call = fold_convert (build_pointer_type (type), call);
+ return call;
+}
+
+
+/* Build a tree that allocates SIZE bytes on the heap and returns a *TYPE
+ pointer to it. */
+
+tree
+a68_lower_malloc (tree type, tree size)
+{
+ return fold_convert (build_pointer_type (type),
+ a68_build_libcall (A68_LIBCALL_MALLOC, ptr_type_node,
+ 1, size));
+}
+
+/* Build code for a temporary variable named NAME, of type TYPE and initialized
+ to INIT. Returns the decl node for the temporary. */
+
+tree
+a68_lower_tmpvar (const char *name, tree type, tree init)
+{
+ tree tmpvar = build_decl (UNKNOWN_LOCATION,
+ VAR_DECL,
+ get_identifier (name),
+ type);
+ DECL_ARTIFICIAL (tmpvar) = 1;
+ DECL_IGNORED_P (tmpvar) = 1;
+ a68_add_decl (tmpvar);
+ a68_add_decl_expr (fold_build1 (DECL_EXPR, type, tmpvar));
+ a68_add_stmt (fold_build2 (INIT_EXPR, type, tmpvar, init));
+ return tmpvar;
+}
+
+/* Build a FUNC_DECL for a top-level non-public function and return it. */
+
+tree
+a68_low_toplevel_func_decl (const char *name, tree fntype)
+{
+ tree fndecl = build_decl (UNKNOWN_LOCATION,
+ FUNCTION_DECL,
+ NULL /* set below */,
+ fntype);
+ char *_name = xasprintf ("__ga68_%s%d", name, DECL_UID (fndecl));
+ DECL_NAME (fndecl) = get_identifier (_name);
+ free (_name);
+ DECL_EXTERNAL (fndecl) = 0;
+ TREE_PUBLIC (fndecl) = 0;
+ TREE_STATIC (fndecl) = 1;
+
+ return fndecl;
+}
+
+/* Build a PARM_DECL whose context is TYPE with the given NAME. */
+
+tree
+a68_low_func_param (tree fndecl, const char *name, tree type)
+{
+ tree param = build_decl (UNKNOWN_LOCATION, PARM_DECL,
+ get_identifier (name), type);
+ DECL_CONTEXT (param) = fndecl;
+ DECL_ARG_TYPE (param) = TREE_TYPE (param);
+ layout_decl (param, 0);
+ return param;
+}
+
+/* Lower a particular program.
+
+ particular program : label, enclosed clause; enclosed clause.
+
+ This handler always returns NULL_TREE. */
+
+static tree
+lower_particular_program (NODE_T *p,
+ LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+ /* Create the main function that conforms the particular program. */
+ tree main_decl = build_decl (a68_get_node_location (p),
+ FUNCTION_DECL,
+ get_identifier ("__algol68_main"),
+ build_function_type (void_type_node,
+ void_list_node));
+ DECL_EXTERNAL (main_decl) = 0;
+ TREE_PUBLIC (main_decl) = 1;
+ TREE_STATIC (main_decl) = 1;
+
+ a68_push_function_range (main_decl,
+ void_type_node /* result_type */);
+
+ /* Lower the body of the function. */
+ NODE_T *enclosed_clause = (IS (SUB (p), ENCLOSED_CLAUSE)
+ ? SUB (p) : NEXT (SUB (p)));
+ tree body_expr = a68_lower_tree (enclosed_clause, ctx);
+ a68_pop_function_range (body_expr);
+ return NULL_TREE;
+}
+
+/* Lower the given tree P using the given context CTX. */
+
+tree
+a68_lower_tree (NODE_T *p, LOW_CTX_T ctx)
+{
+#if 0
+ for (int i = 0; i < ctx.level; ++i)
+ printf (" ");
+ printf ("LOWER TREE: %d::%s\n",
+ NUMBER (p), a68_attribute_name (ATTRIBUTE (p)));
+#endif
+ ctx.level++;
+
+ tree res = NULL_TREE;
+
+ if (p == NO_NODE)
+ gcc_unreachable ();
+
+ switch (ATTRIBUTE (p))
+ {
+ case PARTICULAR_PROGRAM:
+ res = lower_particular_program (p, ctx);
+ break;
+ /* Clauses */
+ case ENCLOSED_CLAUSE:
+ res = a68_lower_enclosed_clause (p, ctx);
+ break;
+ case CLOSED_CLAUSE:
+ res = a68_lower_closed_clause (p, ctx);
+ break;
+ case PARALLEL_CLAUSE:
+ res = a68_lower_parallel_clause (p, ctx);
+ break;
+ case COLLATERAL_CLAUSE:
+ res = a68_lower_collateral_clause (p, ctx);
+ break;
+ case UNIT_LIST:
+ res = a68_lower_unit_list (p, ctx);
+ break;
+ case CONDITIONAL_CLAUSE:
+ res = a68_lower_conditional_clause (p, ctx);
+ break;
+ case ENQUIRY_CLAUSE:
+ res = a68_lower_enquiry_clause (p, ctx);
+ break;
+ case CASE_CLAUSE:
+ res = a68_lower_case_clause (p, ctx);
+ break;
+ case CONFORMITY_CLAUSE:
+ res = a68_lower_conformity_clause (p, ctx);
+ break;
+ case LOOP_CLAUSE:
+ res = a68_lower_loop_clause (p, ctx);
+ break;
+ case SERIAL_CLAUSE:
+ res = a68_lower_serial_clause (p, ctx);
+ break;
+ case INITIALISER_SERIES:
+ res = a68_lower_initialiser_series (p, ctx);
+ break;
+ case EXIT_SYMBOL:
+ res = a68_lower_completer (p, ctx);
+ break;
+ case LABELED_UNIT:
+ res = a68_lower_labeled_unit (p, ctx);
+ break;
+ case LABEL:
+ res = a68_lower_label (p, ctx);
+ break;
+ /* Declarations. */
+ case DECLARATION_LIST:
+ res = a68_lower_declaration_list (p, ctx);
+ break;
+ case DECLARER:
+ res = a68_lower_declarer (p, ctx);
+ break;
+ case IDENTITY_DECLARATION:
+ res = a68_lower_identity_declaration (p, ctx);
+ break;
+ case VARIABLE_DECLARATION:
+ res = a68_lower_variable_declaration (p, ctx);
+ break;
+ case PROCEDURE_DECLARATION:
+ res = a68_lower_procedure_declaration (p, ctx);
+ break;
+ case PROCEDURE_VARIABLE_DECLARATION:
+ res = a68_lower_procedure_variable_declaration (p, ctx);
+ break;
+ case PRIORITY_DECLARATION:
+ res = a68_lower_priority_declaration (p, ctx);
+ break;
+ case BRIEF_OPERATOR_DECLARATION:
+ res = a68_lower_brief_operator_declaration (p, ctx);
+ break;
+ case OPERATOR_DECLARATION:
+ res = a68_lower_operator_declaration (p, ctx);
+ break;
+ case MODE_DECLARATION:
+ res = a68_lower_mode_declaration (p, ctx);
+ break;
+ /* Units. */
+ case UNIT:
+ res = a68_lower_unit (p, ctx);
+ break;
+ case ROUTINE_TEXT:
+ res = a68_lower_routine_text (p, ctx);
+ break;
+ case ASSIGNATION:
+ res = a68_lower_assignation (p, ctx);
+ break;
+ case TERTIARY:
+ res = a68_lower_tertiary (p, ctx);
+ break;
+ case MONADIC_FORMULA:
+ res = a68_lower_monadic_formula (p, ctx);
+ break;
+ case FORMULA:
+ res = a68_lower_formula (p, ctx);
+ break;
+ case SECONDARY:
+ res = a68_lower_secondary (p, ctx);
+ break;
+ case SLICE:
+ res = a68_lower_slice (p, ctx);
+ break;
+ case SELECTION:
+ res = a68_lower_selection (p, ctx);
+ break;
+ case PRIMARY:
+ res = a68_lower_primary (p, ctx);
+ break;
+ case GENERATOR:
+ res = a68_lower_generator (p, ctx);
+ break;
+ case CALL:
+ res = a68_lower_call (p, ctx);
+ break;
+ case CAST:
+ res = a68_lower_cast (p, ctx);
+ break;
+ case AND_FUNCTION:
+ case OR_FUNCTION:
+ res = a68_lower_logic_function (p, ctx);
+ break;
+ case IDENTITY_RELATION:
+ res = a68_lower_identity_relation (p, ctx);
+ break;
+ case EMPTY_SYMBOL:
+ res = a68_lower_empty (p, ctx);
+ break;
+ case NIHIL:
+ res = a68_lower_nihil (p, ctx);
+ break;
+ case SKIP:
+ res = a68_lower_skip (p, ctx);
+ break;
+ case DENOTATION:
+ res = a68_lower_denotation (p, ctx);
+ break;
+ case IDENTIFIER:
+ res = a68_lower_identifier (p, ctx);
+ break;
+ /* Coercions. */
+ case ROWING:
+ res = a68_lower_rowing (p, ctx);
+ break;
+ case WIDENING:
+ res = a68_lower_widening (p, ctx);
+ break;
+ case DEPROCEDURING:
+ res = a68_lower_deproceduring (p, ctx);
+ break;
+ case PROCEDURING:
+ res = a68_lower_proceduring (p, ctx);
+ break;
+ case VOIDING:
+ res = a68_lower_voiding (p, ctx);
+ break;
+ case DEREFERENCING:
+ res = a68_lower_dereferencing (p, ctx);
+ break;
+ /* Others. */
+ case UNITING:
+ res = a68_lower_uniting (p, ctx);
+ break;
+ case JUMP:
+ res = a68_lower_jump (p, ctx);
+ break;
+ case PARAMETER:
+ res = a68_lower_parameter (p, ctx);
+ break;
+ case PARAMETER_LIST:
+ res = a68_lower_parameter_list (p, ctx);
+ break;
+ case PARAMETER_PACK:
+ res = a68_lower_parameter_pack (p, ctx);
+ break;
+ case OPERATOR:
+ res = a68_lower_operator (p, ctx);
+ break;
+ case ASSERTION:
+ res = a68_lower_assertion (p, ctx);
+ break;
+ case STOP:
+ res = NULL_TREE;
+ break;
+ default:
+ fatal_error (a68_get_node_location (p), "cannot lower node %s",
+ a68_attribute_name (ATTRIBUTE (p)));
+ gcc_unreachable ();
+ break;
+ }
+
+ return res;
+}
+
+/* Lower an Algol 68 complete parse tree to a GENERIC tree. */
+
+tree
+a68_lower_top_tree (NODE_T *p)
+{
+ LOW_CTX_T top_ctx;
+
+ top_ctx.declarer = NULL;
+ top_ctx.proc_decl_identifier = NO_NODE;
+ top_ctx.level = 0;
+ return a68_lower_tree (p, top_ctx);
+}
--
2.30.2
