Signed-off-by: Jose E. Marchesi <[email protected]>
gcc/ChangeLog
* algol68/a68-low-ranges.cc: New file.
---
gcc/algol68/a68-low-ranges.cc | 697 ++++++++++++++++++++++++++++++++++
1 file changed, 697 insertions(+)
create mode 100644 gcc/algol68/a68-low-ranges.cc
diff --git a/gcc/algol68/a68-low-ranges.cc b/gcc/algol68/a68-low-ranges.cc
new file mode 100644
index 00000000000..8b9a802b249
--- /dev/null
+++ b/gcc/algol68/a68-low-ranges.cc
@@ -0,0 +1,697 @@
+/* Management of ranges in the Algol 68 front-end.
+ 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/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.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 "tree-nested.h"
+
+#include "a68.h"
+
+/* Many Algol 68 constructions introduce a new range of definitions. This is
+ the case of clauses and of routine definitions. The stack of ranges at any
+ point in the program determines the "nest" of the constructions declared in
+ the program. This nest carries a record of all the declarations forming the
+ environment in which that construct is to be interpreted.
+
+ This file contains a manager of ranges of which we allocate one for each
+ range inducing construct. The top-level range corresponds to the primal
+ environment.
+
+ The ranges are used by the lowering code in order to create GCC tree BLOCK
+ nodes, and also to keep track of the set of declarations and of statements
+ being added by the current serial clause. */
+
+struct GTY (()) range
+{
+ /* Whether this range entry doesn't introduce a lexical frame. Declarations
+ and decl_exprs get added to the nearst enclosing range that is not
+ frameless. */
+ bool frameless;
+
+ /* A chain of _DECL nodes for all variables, constants, functions,
+ and typedef types. These are in the reverse of the order supplied. */
+ tree names;
+
+ /* A statements list of DECL_EXPR nodes for all the declarations in the
+ range. These are prepended to the statements list when the range is
+ closed. */
+ tree decl_exprs;
+
+ /* The context of the range, either a function declaration or a translation
+ unit. */
+ tree context;
+
+ /* The range below this one. */
+ struct range *next;
+
+ /* Statement list. */
+ tree stmt_list;
+
+ /* List of blocks to which the block created for this range is the
+ superblock. */
+ tree blocks;
+
+ /* Mode associated with the range. For serial clauses, this is the mode of
+ the value yielded by the clause. */
+ MOID_T *mode;
+
+ /* If not TREE_NULL, then the range corresponds to a function, which can be
+ either nested or defined at top-level. */
+ tree fndecl;
+ bool top_level_function;
+
+ /* The following fields are used by ranges introduced by serial
+ clauses. */
+ bool save_restore_stack;
+ bool has_completers;
+ tree clause_result_decl;
+ tree clause_exit_label_decl;
+ tree clause_stack_save_decl;
+};
+
+/* Global and current ranges. */
+
+static GTY (()) struct range *global_range;
+static GTY (()) struct range *current_range;
+
+/* Create a new range and push it in the list. */
+
+static struct range *
+new_range (void)
+{
+ struct range *range = ggc_alloc<struct range> ();
+
+ range->frameless = false;
+ range->names = NULL;
+ range->decl_exprs = alloc_stmt_list ();
+ range->context = NULL;
+ range->next = NULL;
+ range->blocks = NULL_TREE;
+ range->stmt_list = alloc_stmt_list ();
+ range->fndecl = NULL_TREE;
+ range->top_level_function = false;
+ range->save_restore_stack = false;
+ range->has_completers = false;
+ range->clause_result_decl = NULL_TREE;
+ range->clause_exit_label_decl = NULL_TREE;
+ range->clause_stack_save_decl = NULL_TREE;
+ range->mode = NO_MOID;
+ return range;
+}
+
+/* Push a new frameless range. */
+
+void
+a68_push_stmt_list (MOID_T *mode)
+{
+ a68_push_range (mode);
+ current_range->frameless = true;
+}
+
+/* Pop a frameless range. */
+
+tree
+a68_pop_stmt_list (void)
+{
+ /* This will result into a stmt list. */
+ tree res = a68_pop_range ();
+ gcc_assert (TREE_CODE (res) == STATEMENT_LIST);
+ return res;
+}
+
+/* Push a new range. */
+
+void
+a68_push_range (MOID_T *mode)
+{
+ struct range *range = new_range ();
+ if (current_range)
+ range->context = current_range->context;
+ range->next = current_range;
+ range->mode = mode;
+ current_range = range;
+}
+
+/* Pop a range, with a finalizer.
+
+ Return a BIND_EXPR, a statement list or a TRY_FINALLY_EXPR. */
+
+tree
+a68_pop_range_with_finalizer (tree finalizer)
+{
+ tree range = a68_pop_range ();
+ return fold_build2 (TRY_FINALLY_EXPR, TREE_TYPE (range),
+ range, finalizer);
+}
+
+/* Pop a range. Return either a BIND_EXPR or a statements list. */
+
+tree
+a68_pop_range (void)
+{
+ struct range *range = current_range;
+ current_range = range->next;
+ tree type = (range->mode == NULL ? void_type_node : CTYPE (range->mode));
+
+ /* If TYPE is a pointer type and the last expression in the statement list is
+ a variable of the type pointed by TYPE then take its address. */
+ tree_stmt_iterator i = tsi_last (range->stmt_list);
+ if (POINTER_TYPE_P (type) && TREE_TYPE (type) == TREE_TYPE (tsi_stmt (i)))
+ {
+ append_to_statement_list_force (a68_consolidate_ref (range->mode,
tsi_stmt (i)),
+ &range->stmt_list);
+ tsi_delink (&i);
+ }
+
+ tree clause = NULL_TREE;
+ if (range->frameless)
+ clause = range->stmt_list;
+ else
+ {
+ /* Create a block and set its declarations and supercontext. */
+ tree block = make_node (BLOCK);
+ BLOCK_VARS (block) = range->names;
+ BLOCK_SUBBLOCKS (block) = range->blocks;
+
+ /* In each subblock, record that this is its superior. */
+ for (tree t = range->blocks; t; t = BLOCK_CHAIN (t))
+ BLOCK_SUPERCONTEXT (t) = block;
+
+ if (range->fndecl)
+ {
+ BLOCK_SUPERCONTEXT (block) = range->fndecl;
+ DECL_INITIAL (range->fndecl) = block;
+ }
+ else
+ {
+ current_range->blocks
+ = block_chainon (current_range->blocks, block);
+ }
+
+ TREE_USED (block) = true;
+
+ /* Create a BIND if the range contains declarations. Otherwise just
+ use the statements list. */
+ clause = range->stmt_list;
+ if (range->names != NULL_TREE)
+ {
+ clause = build3 (BIND_EXPR,
+ type,
+ range->names,
+ range->stmt_list,
+ block);
+ TREE_SIDE_EFFECTS (clause) = 1;
+ BIND_EXPR_VARS (clause) = BLOCK_VARS (block);
+ }
+
+ /* Prepend the decl_exprs to the range's statements list. */
+ tree_stmt_iterator q = tsi_start (range->stmt_list);
+ tsi_link_before (&q, range->decl_exprs, TSI_SAME_STMT);
+ }
+
+ /* Set the type of the stmt_list. */
+ TREE_TYPE (range->stmt_list) = type;
+ TREE_SIDE_EFFECTS (range->stmt_list) = 1;
+
+ return clause;
+}
+
+/* Add a new expression to the current range. */
+
+void
+a68_add_stmt (tree exp)
+{
+ if (exp == void_node)
+ /* This may result from a mode declaration. */
+ return;
+ gcc_assert (current_range != NULL);
+ append_to_statement_list_force (exp,
+ ¤t_range->stmt_list);
+}
+
+/* Add a new declaration to the current range. */
+
+void
+a68_add_decl (tree decl)
+{
+ gcc_assert (current_range != NULL);
+ struct range *range = current_range;
+
+ /* Search for the right frame where to add the declaration. */
+ while (range->frameless)
+ {
+ gcc_assert (range->next != NULL);
+ range = range->next;
+ }
+
+ tree n = range->names;
+ while (n != decl && n != NULL)
+ n = TREE_CHAIN (n);
+ if (n != decl)
+ {
+ if (decl != current_function_decl)
+ DECL_CONTEXT (decl) = range->context;
+ /* Note this list needs to be in reverse order for compatibility with
+ GCC. */
+ TREE_CHAIN (decl) = range->names;
+ range->names = decl;
+ }
+}
+
+/* Add a new declaration expr to the current range. */
+
+void
+a68_add_decl_expr (tree decl_expr)
+{
+ gcc_assert (current_range != NULL);
+ struct range *range = current_range;
+
+ /* Search for the right frame where to add the declaration expr. */
+ while (range->frameless)
+ {
+ gcc_assert (range->next != NULL);
+ range = range->next;
+ }
+
+ append_to_statement_list_force (decl_expr, &range->decl_exprs);
+}
+
+/* Add a completer in the current range. */
+
+void
+a68_add_completer (void)
+{
+ struct range *range = current_range;
+
+ /* The last statement in the statements list is either a single unit or a
+ labeled unit, i.e a COMPOUND_EXPR whose first expression is a label and
+ second expression is the unit. Consolidate the unit within the labeled
+ unit to a ref. */
+ tree_stmt_iterator i = tsi_last (range->stmt_list);
+ tree last_expr = tsi_stmt (i);
+
+ if (TREE_CODE (last_expr) == COMPOUND_EXPR
+ && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR)
+ {
+ TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode,
+ TREE_OPERAND
(last_expr, 1));
+ TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1));
+ }
+ else
+ last_expr = a68_consolidate_ref (range->mode, last_expr);
+
+ /* Now assign the labeled unit to the clause result decl then jump to the end
+ of the serial clause. */
+ append_to_statement_list_force (fold_build2 (MODIFY_EXPR,
+ void_type_node,
+ range->clause_result_decl,
+ last_expr),
+ &range->stmt_list);
+ tsi_delink (&i);
+ append_to_statement_list_force (fold_build1 (GOTO_EXPR, void_type_node,
+ range->clause_exit_label_decl),
+ &range->stmt_list);
+ range->has_completers = true;
+}
+
+/* Get the context of the current range. */
+
+tree
+a68_range_context (void)
+{
+ gcc_assert (current_range != NULL);
+ return current_range->context;
+}
+
+/* Get the list of declarations in the current range. */
+
+tree
+a68_range_names (void)
+{
+ struct range *range = current_range;
+
+ while (range->frameless && range->next != NULL)
+ range = range->next;
+
+ if (range != NULL)
+ return range->names;
+ else
+ return NULL_TREE;
+}
+
+/* Get the statements list of the current range. */
+
+tree
+a68_range_stmt_list (void)
+{
+ gcc_assert (current_range != NULL);
+ return current_range->stmt_list;
+}
+
+/* Push a range for a function. */
+
+void
+a68_push_function_range (tree fndecl, tree result_type,
+ bool top_level)
+{
+ a68_push_range (NULL /* VOID */);
+ current_range->fndecl = fndecl;
+ current_range->top_level_function = top_level;
+ current_range->context = fndecl;
+
+ /* Setup the result declaration. */
+ tree resdecl = build_decl (UNKNOWN_LOCATION,
+ RESULT_DECL,
+ get_identifier ("resdecl%"),
+ result_type);
+ DECL_ARTIFICIAL (resdecl) = 1;
+ DECL_IGNORED_P (resdecl) = 1;
+ DECL_CONTEXT (resdecl) = fndecl;
+ DECL_RESULT (fndecl) = resdecl;
+ rest_of_decl_compilation (fndecl, 1, 0);
+ make_decl_rtl (fndecl);
+ allocate_struct_function (fndecl, false);
+
+ /* Let GCC know the current scope is this function. */
+ current_function_decl = fndecl;
+}
+
+/* Pop a range for a function. */
+
+void
+a68_pop_function_range (tree body)
+{
+ tree fndecl = current_range->fndecl;
+ bool top_level = current_range->top_level_function;
+
+ if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
+ {
+ a68_add_stmt (body);
+ }
+ else
+ {
+ /* Append the return statement.
+ Note that this does the copy of the returned value. */
+ tree return_stmt = fold_build1 (RETURN_EXPR,
+ void_type_node,
+ fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (DECL_RESULT
(fndecl)),
+ DECL_RESULT (fndecl),
+ a68_low_dup (body, true /*
use_heap */)));
+ a68_add_stmt (return_stmt);
+ }
+
+ /* Set the body of the function. */
+ DECL_SAVED_TREE (fndecl) = a68_pop_range ();
+
+ /* Output the GENERIC tree for the function.. */
+ dump_function (TDI_original, fndecl);
+ /* This compiles the function all the way to assembler language output.
+ Nested functions are finalized when the containing top-level function is
+ finalized. */
+ if (top_level || a68_in_global_range ())
+ cgraph_node::finalize_function (fndecl, true);
+ else
+ /* Register this function with cgraph just far enough to get it added to
+ our parent's nested function list. */
+ (void) cgraph_node::get_create (fndecl);
+
+ /* Let GCC know the current scope has changed. */
+ current_function_decl = NULL_TREE;
+ for (struct range *r = current_range; r; r = r->next)
+ {
+ if (r->fndecl != NULL_TREE)
+ current_function_decl = r->fndecl;
+ }
+}
+
+/* Push a range for a serial clause.
+
+ label1: BIND_EXPR_BODY (STATEMENT_LIST (
+ expr1; label1,
+ expr2 expr1,
+ exit label2: clause_result = expr2,
+ expr3; goto exit_label,
+ expr4 label2,
+ exit label3: expr3,
+ expr5 clause_result = expr4,
+ goto exit_label,
+ label3,
+ clause_result = expr5,
+ exit_label,
+ clause_result)) */
+
+void
+a68_push_serial_clause_range (MOID_T *clause_mode,
+ bool save_restore_stack)
+{
+ /* Get the type of the enclosing clause. */
+ tree clause_type = CTYPE (clause_mode);
+
+ /* If the serial clause has declarations that involve dynamic allocation, and
+ the environ it establishes is local, then save the stack pointer. */
+ if (save_restore_stack)
+ {
+ a68_push_range (clause_mode);
+ current_range->save_restore_stack = true;
+
+ tree outer_clause_result_decl = build_decl (UNKNOWN_LOCATION,
+ VAR_DECL,
+ NULL, /* Set below. */
+ clause_type);
+ char *outer_clause_result_name = xasprintf ("outer_clause_result%d%%",
+ DECL_UID
(outer_clause_result_decl));
+ DECL_NAME (outer_clause_result_decl) = get_identifier
(outer_clause_result_name);
+ free (outer_clause_result_name);
+ current_range->clause_result_decl = outer_clause_result_decl;
+ a68_add_decl (outer_clause_result_decl);
+
+ /* Variable used to save the stack pointer. */
+ tree stack_save_decl = build_decl (UNKNOWN_LOCATION,
+ VAR_DECL,
+ get_identifier ("stack_save%"),
+ build_pointer_type (char_type_node));
+ current_range->clause_stack_save_decl = stack_save_decl;
+ a68_add_decl (stack_save_decl);
+ a68_add_stmt (fold_build1 (DECL_EXPR,
+ TREE_TYPE (stack_save_decl),
+ stack_save_decl));
+
+ /* Save stack pointer. */
+ tree call = builtin_decl_implicit (BUILT_IN_STACK_SAVE);
+ call = build_call_expr_loc (UNKNOWN_LOCATION, call, 0);
+ a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+ stack_save_decl, call));
+ }
+
+ /* Push a new range. */
+ a68_push_range (clause_mode);
+ current_range->save_restore_stack = save_restore_stack;
+
+ /* Create a decl for clause_result with the right type and add it to the
+ block's declaration list. */
+ tree clause_result_decl = build_decl (UNKNOWN_LOCATION,
+ VAR_DECL,
+ NULL, /* Set below. */
+ clause_type);
+ char *clause_result_name = xasprintf ("clause_result%d%%", DECL_UID
(clause_result_decl));
+ DECL_NAME (clause_result_decl) = get_identifier (clause_result_name);
+ free (clause_result_name);
+ DECL_INITIAL (clause_result_decl) = a68_get_skip_tree (clause_mode);
+ DECL_CONTEXT (clause_result_decl) = current_range->context;
+ current_range->clause_result_decl = clause_result_decl;
+
+ /* Create a decl for the clause's exit label. */
+ tree clause_exit_label_decl = build_decl (UNKNOWN_LOCATION,
+ LABEL_DECL,
+ NULL, /* Set below. */
+ void_type_node);
+ char *exit_label_name = xasprintf ("clause_exit_label%d%%", DECL_UID
(clause_exit_label_decl));
+ DECL_NAME (clause_exit_label_decl) = get_identifier (exit_label_name);
+ free (exit_label_name);
+ DECL_CONTEXT (clause_exit_label_decl) = current_range->context;
+ current_range->clause_exit_label_decl = clause_exit_label_decl;
+}
+
+/* Pop a range for a serial clause and return the resulting bind
+ expression. */
+
+tree
+a68_pop_serial_clause_range (void)
+{
+ struct range *range = current_range;
+ MOID_T *clause_mode = range->mode;
+ tree clause_type = CTYPE (clause_mode);
+
+ /* The last expression in the statements list is either a single unit or a
+ labeled unit. Consolidate it to a ref if required by the mode of the
+ serial clause. */
+ {
+ tree_stmt_iterator si = tsi_last (range->stmt_list);
+ tree last_expr = tsi_stmt (si);
+ if (TREE_CODE (last_expr) == COMPOUND_EXPR
+ && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR)
+ {
+ TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode,
+ TREE_OPERAND
(last_expr, 1));
+ TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1));
+ }
+ else
+ last_expr = a68_consolidate_ref (range->mode, last_expr);
+ a68_add_stmt (last_expr);
+ tsi_delink (&si);
+ }
+
+ /* If the serial clause has completers, we have to make use of the
+ clause_result% and clause_exit_label% mechanism to assure the statements
+ list has a single exit at the end. */
+ if (range->has_completers)
+ {
+ /* First prepend EXPR_DECL expressions for clause_result% and
+ clause_exit_label% */
+ {
+ tree_stmt_iterator si = tsi_start (range->stmt_list);
+ tsi_link_before (&si,
+ fold_build1 (DECL_EXPR,
+ TREE_TYPE (range->clause_result_decl),
+ range->clause_result_decl),
+ TSI_CONTINUE_LINKING);
+ tsi_link_before (&si,
+ fold_build1 (DECL_EXPR,
+ TREE_TYPE (range->clause_exit_label_decl),
+ range->clause_exit_label_decl),
+ TSI_CONTINUE_LINKING);
+ }
+
+ /* Then turn the last expression in stmt_list to an assignment to
+ clause_result_decl%, but don't bother if it has been voided. */
+ if (clause_type != a68_void_type)
+ {
+ tree_stmt_iterator si = tsi_last (range->stmt_list);
+ tree last_expr = tsi_stmt (si);
+
+ a68_add_stmt (build2 (MODIFY_EXPR,
+ clause_type,
+ range->clause_result_decl,
+ last_expr));
+ tsi_delink (&si);
+ }
+
+ a68_add_decl (range->clause_result_decl);
+ a68_add_decl (range->clause_exit_label_decl);
+
+ /* Finally append the exit label and last expression with
+ result_decl. */
+ a68_add_stmt (build1 (LABEL_EXPR, void_type_node,
range->clause_exit_label_decl));
+ a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type,
range->clause_result_decl));
+ }
+
+ /* Check that the type of the last statement in the statements list is the
+ same than the type corresponding to the clause mode. */
+ {
+ tree_stmt_iterator si = tsi_last (range->stmt_list);
+ if (TREE_TYPE (tsi_stmt (si)) != clause_type
+ /* But NIL can appear in a context expecting VOID with no widening. */
+ && !(clause_type == a68_void_type
+ && POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si)))
+ && TREE_CODE (tsi_stmt (si)) == INTEGER_CST
+ && tree_to_shwi (tsi_stmt (si)) == 0)
+ /* And any row type is valid when M_ROWS is expected. */
+ && !(A68_ROWS_TYPE_P (clause_type)
+ && A68_ROWS_TYPE_P (TREE_TYPE (tsi_stmt (si))))
+ /* Do not rely on comparing pointer types, as the equality fails in
+ that case. We need a better way of comparing types, either using
+ TYPE_CANONICAL or caching. */
+ && !(POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) && POINTER_TYPE_P
(clause_type)))
+ {
+ printf ("last statement:\n");
+ debug_tree (tsi_stmt (si));
+ printf ("expected type:\n");
+ debug_tree (clause_type);
+ gcc_unreachable ();
+ }
+ }
+
+ /* If the serial clause has declarations that involve dynamic allocation, and
+ the environ it establishes is local, then restore the stack pointer. */
+ if (range->save_restore_stack)
+ {
+ /* Turn last expression of inner clause into a modify statement. This
+ may involve a copy. This can be omitted if the serial clause yields
+ void. */
+ if (clause_type != a68_void_type)
+ {
+ tree_stmt_iterator si = tsi_last (range->stmt_list);
+ tree last_expr = tsi_stmt (si);
+
+ a68_add_stmt (build2 (MODIFY_EXPR,
+ clause_type,
+ range->next->clause_result_decl,
+ a68_low_dup (last_expr)));
+ tsi_delink (&si);
+ }
+
+ /* Finish inner clause, restoring stack pointer on finalizing. */
+ tree restore_sp = builtin_decl_implicit (BUILT_IN_STACK_RESTORE);
+ restore_sp = build_call_expr_loc (UNKNOWN_LOCATION, restore_sp, 1,
+
current_range->next->clause_stack_save_decl);
+ a68_add_stmt (a68_pop_range_with_finalizer (restore_sp));
+ /* The result value is now in clause_result_decl. */
+ a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type,
+ current_range->clause_result_decl));
+ }
+
+ return a68_pop_range ();
+}
+
+/* Whether the current range is the global range. */
+
+bool
+a68_in_global_range (void)
+{
+ return current_range == global_range;
+}
+
+/* Initialize ranges. */
+
+void
+a68_init_ranges (void)
+{
+ global_range = new_range ();
+ global_range->context = build_translation_unit_decl (NULL);
+ current_range = global_range;
+}
--
2.30.2
