Patch Detail
get:
Show a patch.
patch:
Update a patch.
put:
Update a patch.
GET /api/patches/2194112/?format=api
{ "id": 2194112, "url": "http://patchwork.ozlabs.org/api/patches/2194112/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/patch/20260206214402.32671-1-jemarch@gnu.org/", "project": { "id": 17, "url": "http://patchwork.ozlabs.org/api/projects/17/?format=api", "name": "GNU Compiler Collection", "link_name": "gcc", "list_id": "gcc-patches.gcc.gnu.org", "list_email": "gcc-patches@gcc.gnu.org", "web_url": null, "scm_url": null, "webscm_url": null, "list_archive_url": "", "list_archive_url_format": "", "commit_url_format": "" }, "msgid": "<20260206214402.32671-1-jemarch@gnu.org>", "list_archive_url": null, "date": "2026-02-06T21:44:02", "name": "[COMMITTED] a68: more work on formal holes", "commit_ref": null, "pull_url": null, "state": "new", "archived": false, "hash": "9d382f3b7c73106f1149439177155df8e90ff1e2", "submitter": { "id": 53513, "url": "http://patchwork.ozlabs.org/api/people/53513/?format=api", "name": "Jose E. Marchesi", "email": "jemarch@gnu.org" }, "delegate": null, "mbox": "http://patchwork.ozlabs.org/project/gcc/patch/20260206214402.32671-1-jemarch@gnu.org/mbox/", "series": [ { "id": 491338, "url": "http://patchwork.ozlabs.org/api/series/491338/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/list/?series=491338", "date": "2026-02-06T21:44:02", "name": "[COMMITTED] a68: more work on formal holes", "version": 1, "mbox": "http://patchwork.ozlabs.org/series/491338/mbox/" } ], "comments": "http://patchwork.ozlabs.org/api/patches/2194112/comments/", "check": "pending", "checks": "http://patchwork.ozlabs.org/api/patches/2194112/checks/", "tags": {}, "related": [], "headers": { "Return-Path": "<gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org>", "X-Original-To": [ "incoming@patchwork.ozlabs.org", "gcc-patches@gcc.gnu.org" ], "Delivered-To": [ "patchwork-incoming@legolas.ozlabs.org", "gcc-patches@gcc.gnu.org" ], "Authentication-Results": [ "legolas.ozlabs.org;\n\tdkim=pass (2048-bit key;\n unprotected) header.d=gnu.org header.i=@gnu.org header.a=rsa-sha256\n header.s=fencepost-gnu-org header.b=Jt6fZCaz;\n\tdkim-atps=neutral", "legolas.ozlabs.org;\n spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org\n (client-ip=38.145.34.32; helo=vm01.sourceware.org;\n envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org;\n receiver=patchwork.ozlabs.org)", "sourceware.org;\n\tdkim=pass (2048-bit key,\n unprotected) header.d=gnu.org header.i=@gnu.org header.a=rsa-sha256\n header.s=fencepost-gnu-org header.b=Jt6fZCaz", "sourceware.org;\n dmarc=pass (p=none dis=none) header.from=gnu.org", "sourceware.org; spf=pass smtp.mailfrom=gnu.org", "server2.sourceware.org;\n arc=none smtp.remote-ip=209.51.188.92" ], "Received": [ "from vm01.sourceware.org (vm01.sourceware.org [38.145.34.32])\n\t(using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)\n\t key-exchange x25519 server-signature ECDSA (secp384r1) server-digest SHA384)\n\t(No client certificate requested)\n\tby legolas.ozlabs.org (Postfix) with ESMTPS id 4f770r5fQQz1xvh\n\tfor <incoming@patchwork.ozlabs.org>; Sat, 07 Feb 2026 08:45:00 +1100 (AEDT)", "from vm01.sourceware.org (localhost [127.0.0.1])\n\tby sourceware.org (Postfix) with ESMTP id 844324B9DB70\n\tfor <incoming@patchwork.ozlabs.org>; Fri, 6 Feb 2026 21:44:58 +0000 (GMT)", "from eggs.gnu.org (eggs.gnu.org [209.51.188.92])\n by sourceware.org (Postfix) with ESMTPS id 692524B9DB5D;\n Fri, 6 Feb 2026 21:44:07 +0000 (GMT)", "from fencepost.gnu.org ([2001:470:142:3::e])\n by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)\n (Exim 4.90_1) (envelope-from <jemarch@gnu.org>)\n id 1voTcV-0002KI-01; Fri, 06 Feb 2026 16:44:07 -0500" ], "DKIM-Filter": [ "OpenDKIM Filter v2.11.0 sourceware.org 844324B9DB70", "OpenDKIM Filter v2.11.0 sourceware.org 692524B9DB5D" ], "DMARC-Filter": "OpenDMARC Filter v1.4.2 sourceware.org 692524B9DB5D", "ARC-Filter": "OpenARC Filter v1.0.0 sourceware.org 692524B9DB5D", "ARC-Seal": "i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1770414247; cv=none;\n b=HZgPbkpryoRAOLe1byFS9wB/NLFVHJ9qt9qagaaOUoyG0Tv0iKdwhlBpisz0+rTzHljWnMnQ589Ie0DZ4bEsRbfstsaVY6oRYaATYj/NtfuMX6kkAYnlXkHoGlD8MGUAtaNwMdCXpH7Xm8+v/9rA8rLuQG51otFdNJQYnDO1WbA=", "ARC-Message-Signature": "i=1; a=rsa-sha256; d=sourceware.org; s=key;\n t=1770414247; c=relaxed/simple;\n bh=ckz1XePGcoRb9NvG8+nBWcXMbnZMve36xBbNEUL3cyg=;\n h=DKIM-Signature:From:To:Subject:Date:Message-Id:MIME-Version;\n b=q2y09L9SJbzAuVbeqQdFeaEff2Dt0f8igtrWl0DzjusI1Ax6Myh+8uyY0bzBK+liCk0AtWotLSYfDFUARGMONBfemPHHyIqpaPTBgrCJiGKUTHNJ2oC3zk5JZWa8ZQ/LoFmgj+AzUPBk097Yce8zy3GCbFsa3t4Peqzs2QL5o0c=", "ARC-Authentication-Results": "i=1; server2.sourceware.org", "DKIM-Signature": "v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org;\n s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to:\n references; bh=ZwHYlmOpko9v8ac1fVhvpCJlMwVDlGaehGJfjJLH3wE=; b=Jt6fZCazfqsoIs\n VM/IraDDVfqkHbx5Ubd10/+lfDPc72eOu0G3+pR7Lh09z9/ZQ4x7Iq9IsjeW5UTVEvGeIXG9vSfir\n vu3Qv5LYXc1MfZbvQolD6AJ2ANf38HQS17Pta1KGObiAkRcqT9En57vBbFC5Bz7Qswoywf/pjgIeg\n x4zYhQUAuZKOLGlmA0GEosBFkkNpfZ5r4+Z4Ks3oIsH2pow/uXoFdL4V2i818TF4fwRYAkUCBgdhX\n bvHIRPNPq/4vaqfB8pxv/G6RXepVMDaIsbJ2lUL4dcoo++MezPJxVuloQ43QuuPNh1jVJFAoELxs3\n fGZy8t9kwf0cyv/ADobQ==;", "From": "\"Jose E. Marchesi\" <jemarch@gnu.org>", "To": "gcc-patches@gcc.gnu.org", "Cc": "algol68@gcc.gnu.org", "Subject": "[COMMITTED] a68: more work on formal holes", "Date": "Fri, 6 Feb 2026 22:44:02 +0100", "Message-Id": "<20260206214402.32671-1-jemarch@gnu.org>", "X-Mailer": "git-send-email 2.39.5", "MIME-Version": "1.0", "Content-Transfer-Encoding": "8bit", "X-BeenThere": "gcc-patches@gcc.gnu.org", "X-Mailman-Version": "2.1.30", "Precedence": "list", "List-Id": "Gcc-patches mailing list <gcc-patches.gcc.gnu.org>", "List-Unsubscribe": "<https://gcc.gnu.org/mailman/options/gcc-patches>,\n <mailto:gcc-patches-request@gcc.gnu.org?subject=unsubscribe>", "List-Archive": "<https://gcc.gnu.org/pipermail/gcc-patches/>", "List-Post": "<mailto:gcc-patches@gcc.gnu.org>", "List-Help": "<mailto:gcc-patches-request@gcc.gnu.org?subject=help>", "List-Subscribe": "<https://gcc.gnu.org/mailman/listinfo/gcc-patches>,\n <mailto:gcc-patches-request@gcc.gnu.org?subject=subscribe>", "Errors-To": "gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org" }, "content": "This commit implements several improvements:\n\n1. The optimization for avoiding indirect calls while using\n declarations like:\n\n proc(string)int puts = nest C \"_libga68_posixputs\";\n\n has been completed.\n\n2. Algol 68 procedures getting strings as arguments can now\n wrap corresponding C functions. Note this does not include\n procedures yielding strings as for now.\n\n3. Wrappers are now built for all formal holes having proc mode. This\n allows for a more robust implementation.\n\nSigned-off-by: Jose E. Marchesi <jemarch@gnu.org>\n\ngcc/algol68/ChangeLog\n\n\t* Make-lang.in (ALGOL68_OBJS): Add algol68/a68-low-holes.o.\n\t* a68.h: Update prototypes.\n\t* a68-types.h (struct TAG_T): New field nest_proc.\n\t(NEST_PROC): Define.\n\t* a68-parser.cc (a68_new_tag): Initialize NEST_PROC.\n\t* a68-parser-extract.cc (extract_identities): Use NEST_PROC\n\tinstead of IN_PROC for taxes for defining-identifiers in identity\n\tdeclarations of proc modes with formal holes as actual parameters.\n\t* a68-moids-misc.cc (a68_is_c_mode): Modified to allow strings as\n\tdirect parameters.\n\t* a68-low.cc (a68_make_proc_formal_hole_decl): Remove.\n\t* a68-low-units.cc (a68_lower_identifier): Improve commentary.\n\t(a68_lower_formal_hole): Factorize.\n\t* a68-low-holes.cc: New file.\n\t* a68-low-decls.cc (a68_lower_identity_declaration): Optimize\n\tidentity declarations of proc mode with formal holes as actual\n\tparameters.\n\t* a68-exports.cc (a68_add_identifier_to_moif): Honor NEST_PROC.\n\t* ga68.texi (Communicating with C): Strings can now be passed as\n\tparameters in formal holes.\n\ngcc/testsuite/ChangeLog\n\n\t* algol68/compile/error-nest-4.a68: Strings can now be passed as\n\targuments in formal holes.\n---\n gcc/algol68/Make-lang.in | 1 +\n gcc/algol68/a68-exports.cc | 2 +-\n gcc/algol68/a68-low-decls.cc | 75 +++++---\n gcc/algol68/a68-low-holes.cc | 176 ++++++++++++++++++\n gcc/algol68/a68-low-units.cc | 84 +++++++--\n gcc/algol68/a68-low.cc | 31 +--\n gcc/algol68/a68-moids-misc.cc | 13 +-\n gcc/algol68/a68-parser-extract.cc | 2 +-\n gcc/algol68/a68-parser.cc | 1 +\n gcc/algol68/a68-types.h | 8 +-\n gcc/algol68/a68.h | 8 +-\n gcc/algol68/ga68.texi | 11 ++\n .../algol68/compile/error-nest-4.a68 | 2 +-\n 13 files changed, 329 insertions(+), 85 deletions(-)\n create mode 100644 gcc/algol68/a68-low-holes.cc", "diff": "diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in\nindex 027ff0c3baf..54b5381cb81 100644\n--- a/gcc/algol68/Make-lang.in\n+++ b/gcc/algol68/Make-lang.in\n@@ -109,6 +109,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \\\n algol68/a68-low-runtime.o \\\n algol68/a68-low-unions.o \\\n algol68/a68-low-units.o \\\n+ algol68/a68-low-holes.o \\\n $(END)\n \n ALGOL68_ALL_OBJS = $(ALGOL68_OBJS)\ndiff --git a/gcc/algol68/a68-exports.cc b/gcc/algol68/a68-exports.cc\nindex 64f31da4016..4ab6ce53d1a 100644\n--- a/gcc/algol68/a68-exports.cc\n+++ b/gcc/algol68/a68-exports.cc\n@@ -91,7 +91,7 @@ a68_add_identifier_to_moif (MOIF_T *moif, TAG_T *tag)\n EXTRACT_MODE (e) = MOID (tag);\n EXTRACT_PRIO (e) = 0;\n EXTRACT_VARIABLE (e) = VARIABLE (tag);\n- EXTRACT_IN_PROC (e) = IN_PROC (tag);\n+ EXTRACT_IN_PROC (e) = IN_PROC (tag) || NEST_PROC (tag);\n \n if (! IDENTIFIERS (moif)->contains (e))\n {\ndiff --git a/gcc/algol68/a68-low-decls.cc b/gcc/algol68/a68-low-decls.cc\nindex 0b99f9352ad..56edacf5092 100644\n--- a/gcc/algol68/a68-low-decls.cc\n+++ b/gcc/algol68/a68-low-decls.cc\n@@ -351,38 +351,55 @@ a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx)\n \n NODE_T *unit = NEXT (NEXT (defining_identifier));\n \n- /* If not done already by an applied identifier in lower_identifier, create a\n- declaration for the defined entity and chain it in the current block. The\n- declaration has an initial value of SKIP. */\n- tree id_decl = TAX_TREE_DECL (TAX (defining_identifier));\n- if (id_decl == NULL_TREE)\n+ tree expr = NULL_TREE;\n+ if (NEST_PROC (TAX (defining_identifier)))\n {\n- id_decl = a68_make_identity_declaration_decl (defining_identifier,\n-\t\t\t\t\t\t ctx.module_definition_name);\n- TAX_TREE_DECL (TAX (defining_identifier)) = id_decl;\n- }\n+ /* NEST_PROC tells us that the identity declaration is of the form:\n \n- /* If the identity declaration is in a public range then add the declaration\n- to the publicized declarations list. Otherwise chain the declaration in\n- the proper block and bind it. */\n- if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))\n- vec_safe_push (A68_MODULE_DEFINITION_DECLS, id_decl);\n- else\n- a68_add_decl (id_decl);\n+\t PROCMODE defining_identifier = FORMAL_HOLE\n \n- /* Prepare the DECL_EXPR. */\n- a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),\n-\t\t\t\t DECL_EXPR,\n-\t\t\t\t TREE_TYPE (id_decl),\n-\t\t\t\t id_decl));\n-\n- unit_tree = a68_lower_tree (unit, ctx);\n- unit_tree = a68_consolidate_ref (MOID (unit), unit_tree);\n- tree expr = a68_low_ascription (MOID (defining_identifier),\n-\t\t\t\t id_decl, unit_tree);\n+\t Which in effect is very like a procedure declaration. */\n+ gcc_assert (IS (SUB (unit), FORMAL_HOLE));\n+ ctx.proc_decl_identifier = defining_identifier;\n+ ctx.proc_decl_operator = false;\n+ expr = a68_lower_tree (unit, ctx);\n+ }\n+ else\n+ {\n+ /* For regular identity declarations, create a declaration for the\n+\t defined entity and chain it in the current block. The declaration has\n+\t an initial value of SKIP. */\n+ tree id_decl = TAX_TREE_DECL (TAX (defining_identifier));\n+ if (id_decl == NULL_TREE)\n+\t{\n+\t id_decl = a68_make_identity_declaration_decl (defining_identifier,\n+\t\t\t\t\t\t\tctx.module_definition_name);\n+\t TAX_TREE_DECL (TAX (defining_identifier)) = id_decl;\n+\t}\n \n- /* If the ascribed value is constant, mark the declaration as constant. */\n- TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree);\n+ /* Prepare the DECL_EXPR. */\n+ a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),\n+\t\t\t\t\t DECL_EXPR,\n+\t\t\t\t\t TREE_TYPE (id_decl),\n+\t\t\t\t\t id_decl));\n+\n+ unit_tree = a68_lower_tree (unit, ctx);\n+ unit_tree = a68_consolidate_ref (MOID (unit), unit_tree);\n+ expr = a68_low_ascription (MOID (defining_identifier),\n+\t\t\t\t id_decl, unit_tree);\n+\n+ /* If the ascribed value is constant, mark the declaration as\n+\t constant. */\n+ TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree);\n+\n+ /* If the identity declaration is in a public range then add the\n+\t declaration to the module's declarations list. Otherwise chain the\n+\t declaration in the proper block and bind it. */\n+ if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))\n+\tvec_safe_push (A68_MODULE_DEFINITION_DECLS, id_decl);\n+ else\n+\ta68_add_decl (id_decl);\n+ }\n \n /* Tail in a compound expression with sub declarations, if any. */\n if (sub_expr != NULL_TREE)\n@@ -390,7 +407,7 @@ a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx)\n if (expr != NULL_TREE)\n \texpr = fold_build2_loc (a68_get_node_location (p),\n \t\t\t\tCOMPOUND_EXPR,\n-\t\t\t\tTREE_TYPE (id_decl),\n+\t\t\t\tTREE_TYPE (expr),\n \t\t\t\tsub_expr,\n \t\t\t\texpr);\n else\ndiff --git a/gcc/algol68/a68-low-holes.cc b/gcc/algol68/a68-low-holes.cc\nnew file mode 100644\nindex 00000000000..2a6a02a9020\n--- /dev/null\n+++ b/gcc/algol68/a68-low-holes.cc\n@@ -0,0 +1,176 @@\n+/* Lowering routines for formal holes.\n+ Copyright (C) 2026 Jose E. Marchesi.\n+\n+ Written by Jose E. Marchesi.\n+\n+ GCC is free software; you can redistribute it and/or modify it\n+ under the terms of the GNU General Public License as published by\n+ the Free Software Foundation; either version 3, or (at your option)\n+ any later version.\n+\n+ GCC is distributed in the hope that it will be useful, but WITHOUT\n+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY\n+ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public\n+ License for more details.\n+\n+ You should have received a copy of the GNU General Public License\n+ along with GCC; see the file COPYING3. If not see\n+ <http://www.gnu.org/licenses/>. */\n+\n+#define INCLUDE_MEMORY\n+#include \"config.h\"\n+#include \"system.h\"\n+#include \"coretypes.h\"\n+\n+#include \"tree.h\"\n+#include \"fold-const.h\"\n+#include \"diagnostic.h\"\n+#include \"langhooks.h\"\n+#include \"tm.h\"\n+#include \"function.h\"\n+#include \"cgraph.h\"\n+#include \"toplev.h\"\n+#include \"varasm.h\"\n+#include \"predict.h\"\n+#include \"stor-layout.h\"\n+#include \"tree-iterator.h\"\n+#include \"stringpool.h\"\n+#include \"print-tree.h\"\n+#include \"gimplify.h\"\n+#include \"dumpfile.h\"\n+#include \"convert.h\"\n+\n+#include \"a68.h\"\n+\n+/* Get the symbol associated with the formal hole P. *ADDRP is set to `true' if\n+ the string denotation in the formal hole starts with `&'. */\n+\n+static const char *\n+get_hole_symbol (NODE_T *p, bool *addrp)\n+{\n+ NODE_T *str = NEXT_SUB (p);\n+ if (IS (str, LANGUAGE_INDICANT))\n+ FORWARD (str);\n+ gcc_assert (IS (str, TERTIARY));\n+ while (str != NO_NODE && !IS (str, ROW_CHAR_DENOTATION))\n+ str = SUB (str);\n+ gcc_assert (IS (str, ROW_CHAR_DENOTATION));\n+\n+ const char *cstr = NSYMBOL (str);\n+ if (strlen (cstr) > 0 && cstr[0] == '&' && addrp != NULL)\n+ {\n+ *addrp = true;\n+ cstr = cstr + 1;\n+ }\n+\n+ return a68_string_process_breaks (p, cstr);\n+}\n+\n+/* Build and return a var decl providing access to the formal hole P. */\n+\n+tree\n+a68_wrap_formal_var_hole (NODE_T *p)\n+{\n+ gcc_assert (!IS (MOID (p), PROC_SYMBOL));\n+ const char *symbol = get_hole_symbol (p, NULL /* addrp */);\n+ return a68_make_formal_hole_decl (p, symbol);\n+}\n+\n+/* Build the body for a wrapper to the formal hole in P, which is of a proc\n+ mode. The body is installed in the function_decl WRAPPER. */\n+\n+void\n+a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper)\n+{\n+ gcc_assert (IS (MOID (p), PROC_SYMBOL));\n+\n+ bool addrp;\n+ const char *symbol = get_hole_symbol (p, &addrp);\n+ gcc_assert (addrp == false);\n+\n+ /* Create a wrapper function. */\n+\n+ MOID_T *m = MOID (p);\n+\n+ /* Determine how many arguments we need for the wrapped function. */\n+ int wrapped_nargs = 0;\n+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))\n+ {\n+ if (MOID(z) == M_STRING)\n+\twrapped_nargs += 3;\n+ else\n+\twrapped_nargs += 1;\n+ }\n+\n+ /* Now build the type of the wrapped function. */\n+\n+ tree *wrapped_args_types = XALLOCAVEC (tree, wrapped_nargs);\n+ int nwrappedarg = 0;\n+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))\n+ {\n+ if (MOID (z) == M_STRING)\n+\t{\n+\t wrapped_args_types[nwrappedarg++] = build_pointer_type (a68_char_type);\n+\t wrapped_args_types[nwrappedarg++] = size_type_node;\n+\t wrapped_args_types[nwrappedarg++] = size_type_node;\n+\t}\n+ else\n+\t{\n+\t wrapped_args_types[nwrappedarg++] = CTYPE (MOID (z));\n+\t}\n+ }\n+\n+ tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper));\n+ tree wrapped_type = build_function_type_array (wrapper_ret_type,\n+\t\t\t\t\t\t wrapped_nargs,\n+\t\t\t\t\t\t wrapped_args_types);\n+ \n+ /* And a decl for the wrapped function. */\n+ tree wrapped = build_decl (UNKNOWN_LOCATION,\n+\t\t\t FUNCTION_DECL,\n+\t\t\t get_identifier (symbol),\n+\t\t\t wrapped_type);\n+ DECL_EXTERNAL (wrapped) = 1;\n+ TREE_PUBLIC (wrapped) = 1;\n+ DECL_ARTIFICIAL (wrapped) = 1;\n+ DECL_VISIBILITY (wrapped) = VISIBILITY_DEFAULT;\n+ DECL_VISIBILITY_SPECIFIED (wrapped) = 1;\n+\n+ announce_function (wrapper);\n+\n+ vec<tree, va_gc> *wrapped_args;\n+ vec_alloc (wrapped_args, wrapped_nargs);\n+ for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))\n+ {\n+ if (MOID (z) == M_STRING)\n+\t{\n+\t tree str = a68_low_func_param (wrapper, \"str\", CTYPE (M_STRING));\n+\t DECL_ARGUMENTS (wrapper) = chainon (str, DECL_ARGUMENTS (wrapper));\n+\n+\t tree s = a68_multiple_elements (str);\n+\t tree len = a68_multiple_num_elems (str);\n+\t tree stride = a68_multiple_stride (str, size_zero_node /* dim */);\n+\n+\t wrapped_args->quick_push (s);\n+\t wrapped_args->quick_push (len);\n+\t wrapped_args->quick_push (stride);\n+\t}\n+ else\n+\t{\n+\t tree a = a68_low_func_param (wrapper, \"param\", CTYPE (MOID (z)));\n+\t DECL_ARGUMENTS (wrapper) = chainon (a, DECL_ARGUMENTS (wrapper));\n+\t wrapped_args->quick_push (a);\n+\t}\n+ }\n+ DECL_ARGUMENTS (wrapper) = nreverse (DECL_ARGUMENTS (wrapper));\n+\n+ a68_push_function_range (wrapper, wrapper_ret_type, true /* top_level */);\n+\n+ /* We need a pointer to a function type. */\n+ if (!POINTER_TYPE_P (TREE_TYPE (wrapped)))\n+ wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)),\n+\t\t\t wrapped);\n+\n+ tree body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args);\n+ a68_pop_function_range (body);\n+}\ndiff --git a/gcc/algol68/a68-low-units.cc b/gcc/algol68/a68-low-units.cc\nindex 4002a4b608a..5aa0c97dad3 100644\n--- a/gcc/algol68/a68-low-units.cc\n+++ b/gcc/algol68/a68-low-units.cc\n@@ -79,6 +79,7 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)\n \t if (IS (MOID (p), PROC_SYMBOL))\n \t {\n \t bool external = (MOIF (TAX (p)) != NO_MOIF);\n+\n \t const char *extern_symbol = EXTERN_SYMBOL (TAX (p));\n \t if (VARIABLE (TAX (p)))\n \t\t{\n@@ -90,7 +91,7 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)\n \t\t id_decl\n \t\t = a68_make_variable_declaration_decl (p, ctx.module_definition_name);\n \t\t}\n-\t else if (IN_PROC (TAX (p)))\n+\t else if (IN_PROC (TAX (p)) || NEST_PROC (TAX (p)))\n \t\t{\n \t\t if (external)\n \t\t id_decl\n@@ -144,8 +145,9 @@ a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)\n \t TAX_TREE_DECL (TAX (p)) = id_decl;\n \t}\n \n- /* If the identifier refers to a FUNCTION_DECL, this means the declaration\n-\t was made by a procecure-identity-dclaration. The applied identifier in\n+ /* If the identifier refers to a FUNCTION_DECL, this means the\n+\t declaration was made by a procecure-identity-dclaration or a\n+\t proc-identity-declaration of a formal hole. The applied identifier in\n \t that case refers to the address of the corresponding function. */\n if (TREE_CODE (id_decl) == FUNCTION_DECL)\n \treturn fold_build1 (ADDR_EXPR,\n@@ -1247,22 +1249,68 @@ a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx)\n tree\n a68_lower_formal_hole (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)\n {\n- NODE_T *str = NEXT_SUB (p);\n- if (IS (str, LANGUAGE_INDICANT))\n- FORWARD (str);\n- gcc_assert (IS (str, TERTIARY));\n- while (str != NO_NODE && !IS (str, ROW_CHAR_DENOTATION))\n- str = SUB (str);\n- gcc_assert (IS (str, ROW_CHAR_DENOTATION));\n-\n- char *symbol = a68_string_process_breaks (p, NSYMBOL (str));\n-\n- tree decl;\n- if (IS (MOID (p), PROC_SYMBOL))\n- decl = a68_make_proc_formal_hole_decl (p, symbol);\n+ NODE_T *defining_identifier = ctx.proc_decl_identifier;\n+ bool defining_operator = ctx.proc_decl_operator;\n+\n+ if (defining_identifier != NO_NODE)\n+ {\n+ /* The formal-hole is part of an identity declaration and yields a proc\n+\t mode. */\n+ gcc_assert (IS (MOID (p), PROC_SYMBOL));\n+\n+ tree func_decl = TAX_TREE_DECL (TAX (defining_identifier));\n+ if (func_decl == NULL_TREE)\n+\t{\n+\t /* Note that for PROC modes (which are non-REF) the function below\n+\t always returns a func_decl, never an address. */\n+\t func_decl\n+\t = a68_make_proc_identity_declaration_decl (defining_identifier,\n+\t\t\t\t\t\t ctx.module_definition_name,\n+\t\t\t\t\t\t defining_operator /* indicant */);\n+\t TAX_TREE_DECL (TAX (defining_identifier)) = func_decl;\n+\t}\n+\n+ /* Create the body for the wrapper from the formal hole. */\n+ a68_wrap_formal_proc_hole (p, func_decl);\n+\n+ /* If the identity-declaration is in a public range then add the\n+\t declaration to the module's declarations list. Otherwise chain the\n+\t declaration in the proper block and bind it. */\n+ if (PUBLIC_RANGE (TABLE (TAX (defining_identifier))))\n+\tvec_safe_push (A68_MODULE_DEFINITION_DECLS, func_decl);\n+ else\n+\ta68_add_decl (func_decl);\n+\n+ a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),\n+\t\t\t\t\t DECL_EXPR,\n+\t\t\t\t\t TREE_TYPE (func_decl),\n+\t\t\t\t\t func_decl));\n+ return func_decl;\n+ }\n else\n- decl = a68_make_formal_hole_decl (p, symbol);\n- return decl;\n+ {\n+ /* The formal-hole is free standing. */\n+ tree decl;\n+ if (IS (MOID (p), PROC_SYMBOL))\n+\t{\n+\t decl = a68_make_anonymous_routine_decl (MOID (p));\n+\t a68_add_decl (decl);\n+\t a68_wrap_formal_proc_hole (p, decl);\n+\n+\t /* XXX necessary */\n+\t a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),\n+\t\t\t\t\t DECL_EXPR,\n+\t\t\t\t\t TREE_TYPE (decl),\n+\t\t\t\t\t decl));\n+\t decl = fold_build1 (ADDR_EXPR,\n+\t\t\t build_pointer_type (TREE_TYPE (decl)),\n+\t\t\t decl);\n+\t}\n+ else\n+\tdecl = a68_wrap_formal_var_hole (p);\n+\n+ return decl;\n+ }\n }\n \n /* Lower an unit.\ndiff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc\nindex 1f341aaa977..dcc974ad67d 100644\n--- a/gcc/algol68/a68-low.cc\n+++ b/gcc/algol68/a68-low.cc\n@@ -660,33 +660,6 @@ a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol)\n return decl;\n }\n \n-/* Make an extern declaration for a formal hole that is a function. */\n-\n-tree\n-a68_make_proc_formal_hole_decl (NODE_T *p, const char *extern_symbol)\n-{\n- /* The CTYPE of MODE is a pointer to a function. We need the pointed\n- function type for the FUNCTION_DECL. */\n- tree type = TREE_TYPE (CTYPE (MOID (p)));\n-\n- gcc_assert (strlen (extern_symbol) > 0);\n- const char *sym = (extern_symbol[0] == '&'\n-\t\t ? extern_symbol + 1\n-\t\t : extern_symbol);\n-\n- tree decl = build_decl (a68_get_node_location (p),\n-\t\t\t FUNCTION_DECL,\n-\t\t\t get_identifier (sym),\n-\t\t\t type);\n- DECL_EXTERNAL (decl) = 1;\n- TREE_PUBLIC (decl) = 1;\n- DECL_INITIAL (decl) = a68_get_skip_tree (MOID (p));\n-\n- if (extern_symbol[0] == '&')\n- decl = fold_build1 (ADDR_EXPR, type, decl);\n- return decl;\n-}\n-\n /* Do a checked indirection.\n \n P is a tree node used for its location information.\n@@ -1448,7 +1421,9 @@ lower_module_declaration (NODE_T *p, LOW_CTX_T ctx)\n \t for (tree d : A68_MODULE_DEFINITION_DECLS)\n \t {\n \t if (TREE_CODE (d) == FUNCTION_DECL)\n-\t\tcgraph_node::finalize_function (d, true);\n+\t\t{\n+\t\t cgraph_node::finalize_function (d, true);\n+\t\t}\n \t else\n \t\t{\n \t\t rest_of_decl_compilation (d, 1, 0);\ndiff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc\nindex a8817926b88..585a4aa691d 100644\n--- a/gcc/algol68/a68-moids-misc.cc\n+++ b/gcc/algol68/a68-moids-misc.cc\n@@ -1193,7 +1193,7 @@ a68_determine_unique_mode (SOID_T *z, int deflex)\n metaproduction rule 561B in ga68.vw. */\n \n bool\n-a68_is_c_mode (MOID_T *m)\n+a68_is_c_mode (MOID_T *m, int level)\n {\n if (m == M_VOID || m == M_BOOL || m == M_CHAR)\n return true;\n@@ -1204,14 +1204,19 @@ a68_is_c_mode (MOID_T *m)\n else if (IS_REAL (m))\n return true;\n else if (IS_REF (m))\n- return a68_is_c_mode (SUB (m));\n+ return a68_is_c_mode (SUB (m), level + 1);\n else if (IS (m, PROC_SYMBOL))\n {\n bool yielded_mode_valid = a68_is_c_mode (SUB (m));\n bool params_valid = true;\n \n for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))\n-\tparams_valid &= a68_is_c_mode (MOID (z));\n+\t{\n+\t if (level == 0 && MOID (z) == M_STRING)\n+\t ;\n+\t else\n+\t params_valid &= a68_is_c_mode (MOID (z), level + 1);\n+\t}\n \n return yielded_mode_valid && params_valid;\n }\n@@ -1220,7 +1225,7 @@ a68_is_c_mode (MOID_T *m)\n bool fields_valid = true;\n \n for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))\n-\tfields_valid &= a68_is_c_mode (MOID (z));\n+\tfields_valid &= a68_is_c_mode (MOID (z), level + 1);\n return fields_valid;\n }\n \ndiff --git a/gcc/algol68/a68-parser-extract.cc b/gcc/algol68/a68-parser-extract.cc\nindex 34199595856..611ef12d2eb 100644\n--- a/gcc/algol68/a68-parser-extract.cc\n+++ b/gcc/algol68/a68-parser-extract.cc\n@@ -775,7 +775,7 @@ extract_identities (NODE_T *p)\n \t\t {\n \t\t NODE_T *actual_param = NEXT (NEXT (q));\n \t\t if (actual_param != NO_NODE && IS (actual_param, FORMAL_NEST_SYMBOL))\n-\t\t\tIN_PROC (tag) = true;\n+\t\t\tNEST_PROC (tag) = true;\n \t\t }\n \t\t FORWARD (q);\n \t\t ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;\ndiff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc\nindex 939dbdde2ec..885b5f524d9 100644\n--- a/gcc/algol68/a68-parser.cc\n+++ b/gcc/algol68/a68-parser.cc\n@@ -778,6 +778,7 @@ a68_new_tag (void)\n PRIO (z) = 0;\n USE (z) = false;\n IN_PROC (z) = false;\n+ NEST_PROC (z) = false;\n HEAP (z) = false;\n YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;\n LOC_ASSIGNED (z) = false;\ndiff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h\nindex f18d3501799..eaf8e1900f6 100644\n--- a/gcc/algol68/a68-types.h\n+++ b/gcc/algol68/a68-types.h\n@@ -596,6 +596,11 @@ struct GTY(()) TABLE_T\n are optimized in a similar way than variable declarations in order to avoid\n indirect addressing.\n \n+ NEST_PROC is set when the defining identifier has been set in an\n+ identity-declaration of a proc mode with a formal hole as actual parameter.\n+ These declarations are optimized in a similar way than variable declarations\n+ in order to avoid indirect addressing.\n+\n YOUNGEST_ENVIRON is used when NODE is either a ROUTINE_TEXT or a\n FORMAT_TEXT, and contains the youngest (higher) lexical level of any object\n directly declared in the routine or format body. This is filled in and used\n@@ -620,7 +625,7 @@ struct GTY((chain_next (\"%h.next\"))) TAG_T\n MOID_T *type;\n NODE_T *node, *unit;\n const char *value;\n- bool scope_assigned, use, in_proc, loc_assigned, portable, variable;\n+ bool scope_assigned, use, in_proc, nest_proc, loc_assigned, portable, variable;\n bool ascribed_routine_text, is_recursive, publicized;\n int priority, heap, scope, youngest_environ, number;\n STATUS_MASK_T status;\n@@ -1013,6 +1018,7 @@ struct GTY(()) A68_T\n #define MULTIPLE_MODE(p) ((p)->multiple_mode)\n #define NAME(p) ((p)->name)\n #define NEST(p) ((p)->nest)\n+#define NEST_PROC(p) ((p)->nest_proc)\n #define NEXT(p) ((p)->next)\n #define NEXT_NEXT(p) (NEXT (NEXT (p)))\n #define NEXT_NEXT_NEXT(p) (NEXT (NEXT_NEXT (p)))\ndiff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h\nindex 9dcb14600a2..2492aea6e2a 100644\n--- a/gcc/algol68/a68.h\n+++ b/gcc/algol68/a68.h\n@@ -476,7 +476,7 @@ void a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute);\n void a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q);\n void a68_make_uniting_coercion (NODE_T *n, MOID_T *q);\n void a68_make_void (NODE_T *p, MOID_T *q);\n-bool a68_is_c_mode (MOID_T *m);\n+bool a68_is_c_mode (MOID_T *m, int level = 0);\n \n #define A68_DEPREF true\n #define A68_NO_DEPREF false\n@@ -815,7 +815,6 @@ tree a68_make_proc_identity_declaration_decl (NODE_T *identifier, const char *mo\n \t\t\t\t\t bool indicant = false, bool external = false,\n \t\t\t\t\t const char *extern_symbol = NULL);\n tree a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol);\n-tree a68_make_proc_formal_hole_decl (NODE_T *p, const char *extern_symbol);\n tree a68_make_anonymous_routine_decl (MOID_T *mode);\n tree a68_get_skip_tree (MOID_T *m);\n tree a68_get_empty (void);\n@@ -857,6 +856,11 @@ tree a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode);\n tree a68_union_translate_overhead (MOID_T *from, tree from_overhead, MOID_T *to);\n bool a68_union_contains_mode (MOID_T *p, MOID_T *q);\n \n+/* a68-low-holes.cc */\n+\n+tree a68_wrap_formal_var_hole (NODE_T *p);\n+void a68_wrap_formal_proc_hole (NODE_T *p, tree fndecl);\n+\n /* a68-low-units.cc */\n \n tree a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx);\ndiff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi\nindex b0945bf8535..bbf2387b61e 100644\n--- a/gcc/algol68/ga68.texi\n+++ b/gcc/algol68/ga68.texi\n@@ -1305,6 +1305,17 @@ As C @code{unsigned long long} or as C @code{unsigned long} or as C @code{unsign\n As C @code{float}\n @item @code{@B{long} @B{real}}\n As C @code{double}\n+@item @code{string} but only as formal parameters of procedures\n+Each Algol 68 string formal parameter turns into three parameters in C:\n+\n+@table @code\n+@item uint32_t *s\n+A pointer to the UCS-4 characters composing the string.\n+@item size_t len\n+The length of @code{s} in number of characters.\n+@item size_t stride\n+The distance in bytes between each character in @code{s}.\n+@end table\n @item @B{proc} with accepted formal parameter modes and yielded mode\n As the corresponding C functions.\n @item Structs with fields of accepted modes\ndiff --git a/gcc/testsuite/algol68/compile/error-nest-4.a68 b/gcc/testsuite/algol68/compile/error-nest-4.a68\nindex ef40c385766..312b96878a5 100644\n--- a/gcc/testsuite/algol68/compile/error-nest-4.a68\n+++ b/gcc/testsuite/algol68/compile/error-nest-4.a68\n@@ -2,7 +2,7 @@ begin string s =\n nest C \"lala\"; { dg-error \"\" }\n union(int,real) x =\n nest C \"x\"; { dg-error \"\" }\n- proc(string)bool y =\n+ proc(union(void,string))bool y =\n nest C \"y\"; { dg-error \"\" }\n skip\n end\n", "prefixes": [ "COMMITTED" ] }