This commit implements several improvements:
1. The optimization for avoiding indirect calls while using
declarations like:
proc(string)int puts = nest C "_libga68_posixputs";
has been completed.
2. Algol 68 procedures getting strings as arguments can now
wrap corresponding C functions. Note this does not include
procedures yielding strings as for now.
3. Wrappers are now built for all formal holes having proc mode. This
allows for a more robust implementation.
Signed-off-by: Jose E. Marchesi <[email protected]>
gcc/algol68/ChangeLog
* Make-lang.in (ALGOL68_OBJS): Add algol68/a68-low-holes.o.
* a68.h: Update prototypes.
* a68-types.h (struct TAG_T): New field nest_proc.
(NEST_PROC): Define.
* a68-parser.cc (a68_new_tag): Initialize NEST_PROC.
* a68-parser-extract.cc (extract_identities): Use NEST_PROC
instead of IN_PROC for taxes for defining-identifiers in identity
declarations of proc modes with formal holes as actual parameters.
* a68-moids-misc.cc (a68_is_c_mode): Modified to allow strings as
direct parameters.
* a68-low.cc (a68_make_proc_formal_hole_decl): Remove.
* a68-low-units.cc (a68_lower_identifier): Improve commentary.
(a68_lower_formal_hole): Factorize.
* a68-low-holes.cc: New file.
* a68-low-decls.cc (a68_lower_identity_declaration): Optimize
identity declarations of proc mode with formal holes as actual
parameters.
* a68-exports.cc (a68_add_identifier_to_moif): Honor NEST_PROC.
* ga68.texi (Communicating with C): Strings can now be passed as
parameters in formal holes.
gcc/testsuite/ChangeLog
* algol68/compile/error-nest-4.a68: Strings can now be passed as
arguments in formal holes.
---
gcc/algol68/Make-lang.in | 1 +
gcc/algol68/a68-exports.cc | 2 +-
gcc/algol68/a68-low-decls.cc | 75 +++++---
gcc/algol68/a68-low-holes.cc | 176 ++++++++++++++++++
gcc/algol68/a68-low-units.cc | 84 +++++++--
gcc/algol68/a68-low.cc | 31 +--
gcc/algol68/a68-moids-misc.cc | 13 +-
gcc/algol68/a68-parser-extract.cc | 2 +-
gcc/algol68/a68-parser.cc | 1 +
gcc/algol68/a68-types.h | 8 +-
gcc/algol68/a68.h | 8 +-
gcc/algol68/ga68.texi | 11 ++
.../algol68/compile/error-nest-4.a68 | 2 +-
13 files changed, 329 insertions(+), 85 deletions(-)
create mode 100644 gcc/algol68/a68-low-holes.cc
diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in
index 027ff0c3baf..54b5381cb81 100644
--- a/gcc/algol68/Make-lang.in
+++ b/gcc/algol68/Make-lang.in
@@ -109,6 +109,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \
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)
diff --git a/gcc/algol68/a68-exports.cc b/gcc/algol68/a68-exports.cc
index 64f31da4016..4ab6ce53d1a 100644
--- a/gcc/algol68/a68-exports.cc
+++ b/gcc/algol68/a68-exports.cc
@@ -91,7 +91,7 @@ a68_add_identifier_to_moif (MOIF_T *moif, TAG_T *tag)
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))
{
diff --git a/gcc/algol68/a68-low-decls.cc b/gcc/algol68/a68-low-decls.cc
index 0b99f9352ad..56edacf5092 100644
--- a/gcc/algol68/a68-low-decls.cc
+++ b/gcc/algol68/a68-low-decls.cc
@@ -351,38 +351,55 @@ a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx)
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)
@@ -390,7 +407,7 @@ a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx)
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
diff --git a/gcc/algol68/a68-low-holes.cc b/gcc/algol68/a68-low-holes.cc
new file mode 100644
index 00000000000..2a6a02a9020
--- /dev/null
+++ b/gcc/algol68/a68-low-holes.cc
@@ -0,0 +1,176 @@
+/* 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);
+}
diff --git a/gcc/algol68/a68-low-units.cc b/gcc/algol68/a68-low-units.cc
index 4002a4b608a..5aa0c97dad3 100644
--- a/gcc/algol68/a68-low-units.cc
+++ b/gcc/algol68/a68-low-units.cc
@@ -79,6 +79,7 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)
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)))
{
@@ -90,7 +91,7 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)
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
@@ -144,8 +145,9 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)
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,
@@ -1247,22 +1249,68 @@ a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx)
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.
diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc
index 1f341aaa977..dcc974ad67d 100644
--- a/gcc/algol68/a68-low.cc
+++ b/gcc/algol68/a68-low.cc
@@ -660,33 +660,6 @@ a68_make_formal_hole_decl (NODE_T *p, const char
*extern_symbol)
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.
@@ -1448,7 +1421,9 @@ lower_module_declaration (NODE_T *p, LOW_CTX_T ctx)
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);
diff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc
index a8817926b88..585a4aa691d 100644
--- a/gcc/algol68/a68-moids-misc.cc
+++ b/gcc/algol68/a68-moids-misc.cc
@@ -1193,7 +1193,7 @@ a68_determine_unique_mode (SOID_T *z, int deflex)
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;
@@ -1204,14 +1204,19 @@ a68_is_c_mode (MOID_T *m)
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;
}
@@ -1220,7 +1225,7 @@ a68_is_c_mode (MOID_T *m)
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;
}
diff --git a/gcc/algol68/a68-parser-extract.cc
b/gcc/algol68/a68-parser-extract.cc
index 34199595856..611ef12d2eb 100644
--- a/gcc/algol68/a68-parser-extract.cc
+++ b/gcc/algol68/a68-parser-extract.cc
@@ -775,7 +775,7 @@ extract_identities (NODE_T *p)
{
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;
diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc
index 939dbdde2ec..885b5f524d9 100644
--- a/gcc/algol68/a68-parser.cc
+++ b/gcc/algol68/a68-parser.cc
@@ -778,6 +778,7 @@ a68_new_tag (void)
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;
diff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h
index f18d3501799..eaf8e1900f6 100644
--- a/gcc/algol68/a68-types.h
+++ b/gcc/algol68/a68-types.h
@@ -596,6 +596,11 @@ struct GTY(()) TABLE_T
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
@@ -620,7 +625,7 @@ struct GTY((chain_next ("%h.next"))) TAG_T
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;
@@ -1013,6 +1018,7 @@ struct GTY(()) A68_T
#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)))
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 9dcb14600a2..2492aea6e2a 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -476,7 +476,7 @@ void a68_make_soid (SOID_T *s, int sort, MOID_T *type, int
attribute);
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
@@ -815,7 +815,6 @@ tree a68_make_proc_identity_declaration_decl (NODE_T
*identifier, const char *mo
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);
@@ -857,6 +856,11 @@ tree a68_union_value (MOID_T *mode, tree exp, MOID_T
*exp_mode);
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);
diff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi
index b0945bf8535..bbf2387b61e 100644
--- a/gcc/algol68/ga68.texi
+++ b/gcc/algol68/ga68.texi
@@ -1305,6 +1305,17 @@ As C @code{unsigned long long} or as C @code{unsigned
long} or as C @code{unsign
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
diff --git a/gcc/testsuite/algol68/compile/error-nest-4.a68
b/gcc/testsuite/algol68/compile/error-nest-4.a68
index ef40c385766..312b96878a5 100644
--- a/gcc/testsuite/algol68/compile/error-nest-4.a68
+++ b/gcc/testsuite/algol68/compile/error-nest-4.a68
@@ -2,7 +2,7 @@ begin string s =
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
--
2.39.5
