From: Jose E. Marchesi Date: Fri, 6 Feb 2026 10:20:31 +0000 (+0100) Subject: a68: more work on formal holes X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=a8df3d91a9ce8aae936d9486b9806149bf57a0a0;p=thirdparty%2Fgcc.git a68: more work on formal holes 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 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. --- 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 + . */ + +#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 *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