algol68/a68-low-runtime.o \
algol68/a68-low-unions.o \
algol68/a68-low-units.o \
+ algol68/a68-low-holes.o \
$(END)
ALGOL68_ALL_OBJS = $(ALGOL68_OBJS)
EXTRACT_MODE (e) = MOID (tag);
EXTRACT_PRIO (e) = 0;
EXTRACT_VARIABLE (e) = VARIABLE (tag);
- EXTRACT_IN_PROC (e) = IN_PROC (tag);
+ EXTRACT_IN_PROC (e) = IN_PROC (tag) || NEST_PROC (tag);
if (! IDENTIFIERS (moif)->contains (e))
{
NODE_T *unit = NEXT (NEXT (defining_identifier));
- /* If not done already by an applied identifier in lower_identifier, create a
- declaration for the defined entity and chain it in the current block. The
- declaration has an initial value of SKIP. */
- tree id_decl = TAX_TREE_DECL (TAX (defining_identifier));
- if (id_decl == NULL_TREE)
+ tree expr = NULL_TREE;
+ if (NEST_PROC (TAX (defining_identifier)))
{
- id_decl = a68_make_identity_declaration_decl (defining_identifier,
- ctx.module_definition_name);
- TAX_TREE_DECL (TAX (defining_identifier)) = id_decl;
- }
+ /* NEST_PROC tells us that the identity declaration is of the form:
- /* If the identity declaration is in a public range then add the declaration
- to the publicized declarations list. Otherwise chain the declaration in
- the proper block and bind it. */
- if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))
- vec_safe_push (A68_MODULE_DEFINITION_DECLS, id_decl);
- else
- a68_add_decl (id_decl);
+ PROCMODE defining_identifier = FORMAL_HOLE
- /* Prepare the DECL_EXPR. */
- a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
- DECL_EXPR,
- TREE_TYPE (id_decl),
- id_decl));
-
- unit_tree = a68_lower_tree (unit, ctx);
- unit_tree = a68_consolidate_ref (MOID (unit), unit_tree);
- tree expr = a68_low_ascription (MOID (defining_identifier),
- id_decl, unit_tree);
+ Which in effect is very like a procedure declaration. */
+ gcc_assert (IS (SUB (unit), FORMAL_HOLE));
+ ctx.proc_decl_identifier = defining_identifier;
+ ctx.proc_decl_operator = false;
+ expr = a68_lower_tree (unit, ctx);
+ }
+ else
+ {
+ /* For regular identity declarations, create a declaration for the
+ defined entity and chain it in the current block. The declaration has
+ an initial value of SKIP. */
+ tree id_decl = TAX_TREE_DECL (TAX (defining_identifier));
+ if (id_decl == NULL_TREE)
+ {
+ id_decl = a68_make_identity_declaration_decl (defining_identifier,
+ ctx.module_definition_name);
+ TAX_TREE_DECL (TAX (defining_identifier)) = id_decl;
+ }
- /* If the ascribed value is constant, mark the declaration as constant. */
- TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree);
+ /* Prepare the DECL_EXPR. */
+ a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+ DECL_EXPR,
+ TREE_TYPE (id_decl),
+ id_decl));
+
+ unit_tree = a68_lower_tree (unit, ctx);
+ unit_tree = a68_consolidate_ref (MOID (unit), unit_tree);
+ expr = a68_low_ascription (MOID (defining_identifier),
+ id_decl, unit_tree);
+
+ /* If the ascribed value is constant, mark the declaration as
+ constant. */
+ TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree);
+
+ /* If the identity declaration is in a public range then add the
+ declaration to the module's declarations list. Otherwise chain the
+ declaration in the proper block and bind it. */
+ if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))
+ vec_safe_push (A68_MODULE_DEFINITION_DECLS, id_decl);
+ else
+ a68_add_decl (id_decl);
+ }
/* Tail in a compound expression with sub declarations, if any. */
if (sub_expr != NULL_TREE)
if (expr != NULL_TREE)
expr = fold_build2_loc (a68_get_node_location (p),
COMPOUND_EXPR,
- TREE_TYPE (id_decl),
+ TREE_TYPE (expr),
sub_expr,
expr);
else
--- /dev/null
+/* Lowering routines for formal holes.
+ 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/>. */
+
+#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"
+
+/* Get the symbol associated with the formal hole P. *ADDRP is set to `true' if
+ the string denotation in the formal hole starts with `&'. */
+
+static const char *
+get_hole_symbol (NODE_T *p, bool *addrp)
+{
+ NODE_T *str = NEXT_SUB (p);
+ if (IS (str, LANGUAGE_INDICANT))
+ FORWARD (str);
+ gcc_assert (IS (str, TERTIARY));
+ while (str != NO_NODE && !IS (str, ROW_CHAR_DENOTATION))
+ str = SUB (str);
+ gcc_assert (IS (str, ROW_CHAR_DENOTATION));
+
+ const char *cstr = NSYMBOL (str);
+ if (strlen (cstr) > 0 && cstr[0] == '&' && addrp != NULL)
+ {
+ *addrp = true;
+ cstr = cstr + 1;
+ }
+
+ return a68_string_process_breaks (p, cstr);
+}
+
+/* Build and return a var decl providing access to the formal hole P. */
+
+tree
+a68_wrap_formal_var_hole (NODE_T *p)
+{
+ gcc_assert (!IS (MOID (p), PROC_SYMBOL));
+ const char *symbol = get_hole_symbol (p, NULL /* addrp */);
+ return a68_make_formal_hole_decl (p, symbol);
+}
+
+/* Build the body for a wrapper to the formal hole in P, which is of a proc
+ mode. The body is installed in the function_decl WRAPPER. */
+
+void
+a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper)
+{
+ gcc_assert (IS (MOID (p), PROC_SYMBOL));
+
+ bool addrp;
+ const char *symbol = get_hole_symbol (p, &addrp);
+ gcc_assert (addrp == false);
+
+ /* Create a wrapper function. */
+
+ MOID_T *m = MOID (p);
+
+ /* Determine how many arguments we need for the wrapped function. */
+ int wrapped_nargs = 0;
+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
+ {
+ if (MOID(z) == M_STRING)
+ wrapped_nargs += 3;
+ else
+ wrapped_nargs += 1;
+ }
+
+ /* Now build the type of the wrapped function. */
+
+ tree *wrapped_args_types = XALLOCAVEC (tree, wrapped_nargs);
+ int nwrappedarg = 0;
+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
+ {
+ if (MOID (z) == M_STRING)
+ {
+ wrapped_args_types[nwrappedarg++] = build_pointer_type (a68_char_type);
+ wrapped_args_types[nwrappedarg++] = size_type_node;
+ wrapped_args_types[nwrappedarg++] = size_type_node;
+ }
+ else
+ {
+ wrapped_args_types[nwrappedarg++] = CTYPE (MOID (z));
+ }
+ }
+
+ tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper));
+ tree wrapped_type = build_function_type_array (wrapper_ret_type,
+ wrapped_nargs,
+ wrapped_args_types);
+
+ /* And a decl for the wrapped function. */
+ tree wrapped = build_decl (UNKNOWN_LOCATION,
+ FUNCTION_DECL,
+ get_identifier (symbol),
+ wrapped_type);
+ DECL_EXTERNAL (wrapped) = 1;
+ TREE_PUBLIC (wrapped) = 1;
+ DECL_ARTIFICIAL (wrapped) = 1;
+ DECL_VISIBILITY (wrapped) = VISIBILITY_DEFAULT;
+ DECL_VISIBILITY_SPECIFIED (wrapped) = 1;
+
+ announce_function (wrapper);
+
+ vec<tree, va_gc> *wrapped_args;
+ vec_alloc (wrapped_args, wrapped_nargs);
+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
+ {
+ if (MOID (z) == M_STRING)
+ {
+ tree str = a68_low_func_param (wrapper, "str", CTYPE (M_STRING));
+ DECL_ARGUMENTS (wrapper) = chainon (str, DECL_ARGUMENTS (wrapper));
+
+ tree s = a68_multiple_elements (str);
+ tree len = a68_multiple_num_elems (str);
+ tree stride = a68_multiple_stride (str, size_zero_node /* dim */);
+
+ wrapped_args->quick_push (s);
+ wrapped_args->quick_push (len);
+ wrapped_args->quick_push (stride);
+ }
+ else
+ {
+ tree a = a68_low_func_param (wrapper, "param", CTYPE (MOID (z)));
+ DECL_ARGUMENTS (wrapper) = chainon (a, DECL_ARGUMENTS (wrapper));
+ wrapped_args->quick_push (a);
+ }
+ }
+ DECL_ARGUMENTS (wrapper) = nreverse (DECL_ARGUMENTS (wrapper));
+
+ a68_push_function_range (wrapper, wrapper_ret_type, true /* top_level */);
+
+ /* We need a pointer to a function type. */
+ if (!POINTER_TYPE_P (TREE_TYPE (wrapped)))
+ wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)),
+ wrapped);
+
+ tree body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args);
+ a68_pop_function_range (body);
+}
if (IS (MOID (p), PROC_SYMBOL))
{
bool external = (MOIF (TAX (p)) != NO_MOIF);
+
const char *extern_symbol = EXTERN_SYMBOL (TAX (p));
if (VARIABLE (TAX (p)))
{
id_decl
= a68_make_variable_declaration_decl (p, ctx.module_definition_name);
}
- else if (IN_PROC (TAX (p)))
+ else if (IN_PROC (TAX (p)) || NEST_PROC (TAX (p)))
{
if (external)
id_decl
TAX_TREE_DECL (TAX (p)) = id_decl;
}
- /* If the identifier refers to a FUNCTION_DECL, this means the declaration
- was made by a procecure-identity-dclaration. The applied identifier in
+ /* If the identifier refers to a FUNCTION_DECL, this means the
+ declaration was made by a procecure-identity-dclaration or a
+ proc-identity-declaration of a formal hole. The applied identifier in
that case refers to the address of the corresponding function. */
if (TREE_CODE (id_decl) == FUNCTION_DECL)
return fold_build1 (ADDR_EXPR,
tree
a68_lower_formal_hole (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
{
- NODE_T *str = NEXT_SUB (p);
- if (IS (str, LANGUAGE_INDICANT))
- FORWARD (str);
- gcc_assert (IS (str, TERTIARY));
- while (str != NO_NODE && !IS (str, ROW_CHAR_DENOTATION))
- str = SUB (str);
- gcc_assert (IS (str, ROW_CHAR_DENOTATION));
-
- char *symbol = a68_string_process_breaks (p, NSYMBOL (str));
-
- tree decl;
- if (IS (MOID (p), PROC_SYMBOL))
- decl = a68_make_proc_formal_hole_decl (p, symbol);
+ NODE_T *defining_identifier = ctx.proc_decl_identifier;
+ bool defining_operator = ctx.proc_decl_operator;
+
+ if (defining_identifier != NO_NODE)
+ {
+ /* The formal-hole is part of an identity declaration and yields a proc
+ mode. */
+ gcc_assert (IS (MOID (p), PROC_SYMBOL));
+
+ tree func_decl = TAX_TREE_DECL (TAX (defining_identifier));
+ if (func_decl == NULL_TREE)
+ {
+ /* Note that for PROC modes (which are non-REF) the function below
+ always returns a func_decl, never an address. */
+ func_decl
+ = a68_make_proc_identity_declaration_decl (defining_identifier,
+ ctx.module_definition_name,
+ defining_operator /* indicant */);
+ TAX_TREE_DECL (TAX (defining_identifier)) = func_decl;
+ }
+
+ /* Create the body for the wrapper from the formal hole. */
+ a68_wrap_formal_proc_hole (p, func_decl);
+
+ /* If the identity-declaration is in a public range then add the
+ declaration to the module's declarations list. Otherwise chain the
+ declaration in the proper block and bind it. */
+ if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))
+ vec_safe_push (A68_MODULE_DEFINITION_DECLS, func_decl);
+ else
+ a68_add_decl (func_decl);
+
+ a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+ DECL_EXPR,
+ TREE_TYPE (func_decl),
+ func_decl));
+ return func_decl;
+ }
else
- decl = a68_make_formal_hole_decl (p, symbol);
- return decl;
+ {
+ /* The formal-hole is free standing. */
+ tree decl;
+ if (IS (MOID (p), PROC_SYMBOL))
+ {
+ decl = a68_make_anonymous_routine_decl (MOID (p));
+ a68_add_decl (decl);
+ a68_wrap_formal_proc_hole (p, decl);
+
+ /* XXX necessary */
+ a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+ DECL_EXPR,
+ TREE_TYPE (decl),
+ decl));
+ decl = fold_build1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (decl)),
+ decl);
+ }
+ else
+ decl = a68_wrap_formal_var_hole (p);
+
+ return decl;
+ }
}
/* Lower an unit.
return decl;
}
-/* Make an extern declaration for a formal hole that is a function. */
-
-tree
-a68_make_proc_formal_hole_decl (NODE_T *p, const char *extern_symbol)
-{
- /* The CTYPE of MODE is a pointer to a function. We need the pointed
- function type for the FUNCTION_DECL. */
- tree type = TREE_TYPE (CTYPE (MOID (p)));
-
- gcc_assert (strlen (extern_symbol) > 0);
- const char *sym = (extern_symbol[0] == '&'
- ? extern_symbol + 1
- : extern_symbol);
-
- tree decl = build_decl (a68_get_node_location (p),
- FUNCTION_DECL,
- get_identifier (sym),
- type);
- DECL_EXTERNAL (decl) = 1;
- TREE_PUBLIC (decl) = 1;
- DECL_INITIAL (decl) = a68_get_skip_tree (MOID (p));
-
- if (extern_symbol[0] == '&')
- decl = fold_build1 (ADDR_EXPR, type, decl);
- return decl;
-}
-
/* Do a checked indirection.
P is a tree node used for its location information.
for (tree d : A68_MODULE_DEFINITION_DECLS)
{
if (TREE_CODE (d) == FUNCTION_DECL)
- cgraph_node::finalize_function (d, true);
+ {
+ cgraph_node::finalize_function (d, true);
+ }
else
{
rest_of_decl_compilation (d, 1, 0);
metaproduction rule 561B in ga68.vw. */
bool
-a68_is_c_mode (MOID_T *m)
+a68_is_c_mode (MOID_T *m, int level)
{
if (m == M_VOID || m == M_BOOL || m == M_CHAR)
return true;
else if (IS_REAL (m))
return true;
else if (IS_REF (m))
- return a68_is_c_mode (SUB (m));
+ return a68_is_c_mode (SUB (m), level + 1);
else if (IS (m, PROC_SYMBOL))
{
bool yielded_mode_valid = a68_is_c_mode (SUB (m));
bool params_valid = true;
for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
- params_valid &= a68_is_c_mode (MOID (z));
+ {
+ if (level == 0 && MOID (z) == M_STRING)
+ ;
+ else
+ params_valid &= a68_is_c_mode (MOID (z), level + 1);
+ }
return yielded_mode_valid && params_valid;
}
bool fields_valid = true;
for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
- fields_valid &= a68_is_c_mode (MOID (z));
+ fields_valid &= a68_is_c_mode (MOID (z), level + 1);
return fields_valid;
}
{
NODE_T *actual_param = NEXT (NEXT (q));
if (actual_param != NO_NODE && IS (actual_param, FORMAL_NEST_SYMBOL))
- IN_PROC (tag) = true;
+ NEST_PROC (tag) = true;
}
FORWARD (q);
ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
PRIO (z) = 0;
USE (z) = false;
IN_PROC (z) = false;
+ NEST_PROC (z) = false;
HEAP (z) = false;
YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;
LOC_ASSIGNED (z) = false;
are optimized in a similar way than variable declarations in order to avoid
indirect addressing.
+ NEST_PROC is set when the defining identifier has been set in an
+ identity-declaration of a proc mode with a formal hole as actual parameter.
+ These declarations are optimized in a similar way than variable declarations
+ in order to avoid indirect addressing.
+
YOUNGEST_ENVIRON is used when NODE is either a ROUTINE_TEXT or a
FORMAT_TEXT, and contains the youngest (higher) lexical level of any object
directly declared in the routine or format body. This is filled in and used
MOID_T *type;
NODE_T *node, *unit;
const char *value;
- bool scope_assigned, use, in_proc, loc_assigned, portable, variable;
+ bool scope_assigned, use, in_proc, nest_proc, loc_assigned, portable, variable;
bool ascribed_routine_text, is_recursive, publicized;
int priority, heap, scope, youngest_environ, number;
STATUS_MASK_T status;
#define MULTIPLE_MODE(p) ((p)->multiple_mode)
#define NAME(p) ((p)->name)
#define NEST(p) ((p)->nest)
+#define NEST_PROC(p) ((p)->nest_proc)
#define NEXT(p) ((p)->next)
#define NEXT_NEXT(p) (NEXT (NEXT (p)))
#define NEXT_NEXT_NEXT(p) (NEXT (NEXT_NEXT (p)))
void a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q);
void a68_make_uniting_coercion (NODE_T *n, MOID_T *q);
void a68_make_void (NODE_T *p, MOID_T *q);
-bool a68_is_c_mode (MOID_T *m);
+bool a68_is_c_mode (MOID_T *m, int level = 0);
#define A68_DEPREF true
#define A68_NO_DEPREF false
bool indicant = false, bool external = false,
const char *extern_symbol = NULL);
tree a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol);
-tree a68_make_proc_formal_hole_decl (NODE_T *p, const char *extern_symbol);
tree a68_make_anonymous_routine_decl (MOID_T *mode);
tree a68_get_skip_tree (MOID_T *m);
tree a68_get_empty (void);
tree a68_union_translate_overhead (MOID_T *from, tree from_overhead, MOID_T *to);
bool a68_union_contains_mode (MOID_T *p, MOID_T *q);
+/* a68-low-holes.cc */
+
+tree a68_wrap_formal_var_hole (NODE_T *p);
+void a68_wrap_formal_proc_hole (NODE_T *p, tree fndecl);
+
/* a68-low-units.cc */
tree a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx);
As C @code{float}
@item @code{@B{long} @B{real}}
As C @code{double}
+@item @code{string} but only as formal parameters of procedures
+Each Algol 68 string formal parameter turns into three parameters in C:
+
+@table @code
+@item uint32_t *s
+A pointer to the UCS-4 characters composing the string.
+@item size_t len
+The length of @code{s} in number of characters.
+@item size_t stride
+The distance in bytes between each character in @code{s}.
+@end table
@item @B{proc} with accepted formal parameter modes and yielded mode
As the corresponding C functions.
@item Structs with fields of accepted modes
nest C "lala"; { dg-error "" }
union(int,real) x =
nest C "x"; { dg-error "" }
- proc(string)bool y =
+ proc(union(void,string))bool y =
nest C "y"; { dg-error "" }
skip
end
projects / thirdparty / gcc.git / commitdiff
