Patch Detail
get:
Show a patch.
patch:
Update a patch.
put:
Update a patch.
GET /api/1.1/patches/2237932/?format=api
{ "id": 2237932, "url": "http://patchwork.ozlabs.org/api/1.1/patches/2237932/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/patch/214d0315-8f0c-45ea-8022-038dd191ee79@netcologne.de/", "project": { "id": 17, "url": "http://patchwork.ozlabs.org/api/1.1/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 }, "msgid": "<214d0315-8f0c-45ea-8022-038dd191ee79@netcologne.de>", "date": "2026-05-13T16:29:26", "name": "PR fortran/125092 -checks for binding label argument mismatch", "commit_ref": null, "pull_url": null, "state": "new", "archived": false, "hash": "0cba6446b4e48a24b1cb95ba5066ab19888c572e", "submitter": { "id": 4465, "url": "http://patchwork.ozlabs.org/api/1.1/people/4465/?format=api", "name": "Thomas Koenig", "email": "tkoenig@netcologne.de" }, "delegate": null, "mbox": "http://patchwork.ozlabs.org/project/gcc/patch/214d0315-8f0c-45ea-8022-038dd191ee79@netcologne.de/mbox/", "series": [ { "id": 504185, "url": "http://patchwork.ozlabs.org/api/1.1/series/504185/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/list/?series=504185", "date": "2026-05-13T16:29:26", "name": "PR fortran/125092 -checks for binding label argument mismatch", "version": 1, "mbox": "http://patchwork.ozlabs.org/series/504185/mbox/" } ], "comments": "http://patchwork.ozlabs.org/api/patches/2237932/comments/", "check": "pending", "checks": "http://patchwork.ozlabs.org/api/patches/2237932/checks/", "tags": {}, "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=netcologne.de header.i=@netcologne.de\n header.a=rsa-sha256 header.s=nc1116a header.b=L3JE7DF9;\n\tdkim-atps=neutral", "legolas.ozlabs.org;\n spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org\n (client-ip=2620:52:6:3111::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=netcologne.de header.i=@netcologne.de\n header.a=rsa-sha256 header.s=nc1116a header.b=L3JE7DF9", "sourceware.org;\n dmarc=pass (p=none dis=none) header.from=netcologne.de", "sourceware.org; spf=pass smtp.mailfrom=netcologne.de", "sourceware.org; arc=none smtp.remote-ip=89.1.8.211" ], "Received": [ "from vm01.sourceware.org (vm01.sourceware.org\n [IPv6:2620:52:6:3111::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 4gFzV10PwYz1yHW\n\tfor <incoming@patchwork.ozlabs.org>; Thu, 14 May 2026 02:30:47 +1000 (AEST)", "from vm01.sourceware.org (localhost [IPv6:::1])\n\tby sourceware.org (Postfix) with ESMTP id C02314BB8F45\n\tfor <incoming@patchwork.ozlabs.org>; Wed, 13 May 2026 16:30:45 +0000 (GMT)", "from cc-smtpout1.netcologne.de (cc-smtpout1.netcologne.de\n [89.1.8.211])\n by sourceware.org (Postfix) with ESMTPS id 2768E4BAD15B;\n Wed, 13 May 2026 16:29:30 +0000 (GMT)", "from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de\n [89.1.8.203])\n by cc-smtpout1.netcologne.de (Postfix) with ESMTP id A9E2E12482;\n Wed, 13 May 2026 18:29:28 +0200 (CEST)", "from [IPV6:2a0a:a548:589d:0:f35d:4325:3109:faea]\n (2a0a-a548-589d-0-f35d-4325-3109-faea.ipv6dyn.netcologne.de\n [IPv6:2a0a:a548:589d:0:f35d:4325:3109:faea])\n (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)\n key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest\n SHA256)\n (No client certificate requested)\n by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA id 379BB11D9F;\n Wed, 13 May 2026 18:29:27 +0200 (CEST)" ], "DKIM-Filter": [ "OpenDKIM Filter v2.11.0 sourceware.org C02314BB8F45", "OpenDKIM Filter v2.11.0 sourceware.org 2768E4BAD15B" ], "DMARC-Filter": "OpenDMARC Filter v1.4.2 sourceware.org 2768E4BAD15B", "ARC-Filter": "OpenARC Filter v1.0.0 sourceware.org 2768E4BAD15B", "ARC-Seal": "i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1778689770; cv=none;\n b=tP+30zFKwX3Qc26sCkCOB9J0AUvm34wwHyiZqy1Ka6Myc8a2uqLaPiUkibauP0vG6w4Lpefrk9tTS37B/ihsd5txX90zqQdYKAcpw9PU2QLYTDS6Y6J/EygRNU1UWiftKhJ9vqwItQteUO6850QbueYFyaU5Y7/w9lKHEfW2lZs=", "ARC-Message-Signature": "i=1; a=rsa-sha256; d=sourceware.org; s=key;\n t=1778689770; c=relaxed/simple;\n bh=CUUA++pN+7Sc8RSAgRzAsa9+3YbhZuF+8YSB6qZfFEQ=;\n h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject;\n b=PL8yMUZJeXOQxC7Ny8bLb5rjqlnX92Fccs8elBwKG1Lk13OBruCv3Vc6MixE2IXuoafeq4unl8VjxjD6la6SrwXjusktNwzM/4lT+tr1B4ukkqoGWNzSRbFSPrs3ZN9QLt035u202F520kj9PYrTAhD6WflVXmisqRUeQu+yh4Q=", "ARC-Authentication-Results": "i=1; sourceware.org;\n dkim=pass (2048-bit key, unprotected)\n header.d=netcologne.de header.i=@netcologne.de header.a=rsa-sha256\n header.s=nc1116a header.b=L3JE7DF9", "DKIM-Signature": "v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de;\n s=nc1116a; t=1778689768;\n bh=CUUA++pN+7Sc8RSAgRzAsa9+3YbhZuF+8YSB6qZfFEQ=;\n h=Message-ID:Date:To:From:Subject:From;\n b=L3JE7DF9s/cJ1OFnSngJRTVeJVQl97rvrVxSEP8r6mtaJBlZFv5Y/c+hHl25ELP/w\n c4Tu5B2AZjmV5W5oJEyUEfd2gf7Zs6ZmI53Llm06sMiATVZ0MpENhmehQtH2cQyKn1\n Ksxp7aGTekFEbmXvXATxlEB22gyp5wzadlni4ua8NCNCDl8I8wTlfJVXqHUoBN9++N\n JMx0Ki5RjqEFiBwzWk6R1n7lxN+RbI3khOyURRyxjEViBKJh+l9RLzFLRDsZ3P7zj1\n o8PGDZJkZsU0iNVP0NiEghDhSGioADxKkaEK26fwL0rWEcobP6nNubUoloByCtpiTy\n k1D+f8ZhV40bw==", "Content-Type": "multipart/mixed; boundary=\"------------q3nSrf6iBR4C8TF2M48zsVFq\"", "Message-ID": "<214d0315-8f0c-45ea-8022-038dd191ee79@netcologne.de>", "Date": "Wed, 13 May 2026 18:29:26 +0200", "MIME-Version": "1.0", "User-Agent": "Mozilla Thunderbird", "Content-Language": "en-US", "To": "\"fortran@gcc.gnu.org\" <fortran@gcc.gnu.org>,\n gcc-patches <gcc-patches@gcc.gnu.org>", "From": "Thomas Koenig <tkoenig@netcologne.de>", "Subject": "PR fortran/125092 -checks for binding label argument mismatch", "X-NetCologne-Spam": "L", "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": "Hello world,\n\nthe patch below is regression-tested. OK for trunk?\n\nBest regards\n\n\tThomas\n\nPR fortran/125092 - checks for binding label argument mismatch.\n\nThis patch implements some checks on different interfaces to the same\nC binding functions. It contains a few policy changes, and is somewhat\nmore permissive than the standard, but there are no constraint\nviolations (to my knowledge) that it misses.\n\nApart from checking for standards conformance, this should also\nhelp proof code against (now or future) type-based aliasing mishaps.\n\nChecks for global identifiers are performed on a case-insensitive\nbasis by default, and only sensitive when -pedantic is in force.\nThis makes sense if Fortran code wants to interface to \"FOO\" and\n\"foo\". The restriction to case-insensitive labels comes from a time\nwhen relevant systems had linkers which were case-insensitive, and\nit is not possible to implement C (especially the C versions referenced\nin the standard) with such a linker.\n\nReturn types of functions, ranks, number, type and rank of arguments\nare checked. In non-pedantic mode, arguments which have the same\nprototype on the C side are permitted, for example passing a scalar\nor an array by reference, or arrays of different rank (both for pass\nby reference and pass by descriptors). Assumed types are also\nassumed to bee OK. This functionality was checked in a few test\ncases, so it would make little sense to remove it.\n\nC_PTR is *not* compatible with a random argument passed by reference.\nFor example, a TYPE(C_PTR), VALUE argument is not compatible\nwith an INTEGER argument (without VALUE); C_LOC has to be used.\n\nThe one-liner in decl.cc may fix some ENTRY problems, I didn't check.\n\ngcc/fortran/ChangeLog:\n\n\t* decl.cc (add_global_entry): Use string from the heap instead\n\tof a pointer to stack-allocated memory.\n\t* frontend-passes.cc (check_against_globals): If there is an error\n\talready, return early.\n\t* gfortran.h (gfc_symbol_rank): New prototype.\n\t* interface.cc (symbol_rank): Rename to\n\t(gfc_symbol_rank): this.\n\t(gfc_check_dummy_characteristics): Use new function name.\n\t(gfc_check_result_characteristics): Likewise.\n\t(gfc_compare_interfaces): Likewise.\n\t(compare_parameter): Likewise.\n\t(get_sym_storage_size): Likewise.\n\t(gfc_procedure_use): Likewise.\n\t* resolve.cc (decays_to_pointer): New function.\n\t(c_types_conform): New function.\n\t(compare_c_binding_arglists): New function.\n\t(gfc_verify_binding_labels): Check return types and rank\n\tplus argument lists if there is a pre-exisiting global\n\tsymbol.\n\ngcc/testsuite/ChangeLog:\n\n\t* gfortran.dg/PR100906.f90: Add -Wno-pedantic to options.\n\t* gfortran.dg/PR100911.f90: Likewise.\n\t* gfortran.dg/PR100915.f90: Likewise.\n\t* gfortran.dg/PR94327.f90: Likewise.\n\t* gfortran.dg/PR94331.f90: Likewise.\n\t* gfortran.dg/bind_c_procs_4.f90: Add error messages, remove\n\twarning.\n\t* gfortran.dg/binding_label_tests_25.f90: Add error messages.\n\t* gfortran.dg/binding_label_tests_3.f03: Add error messages.\n\t* gfortran.dg/binding_label_tests_34.f90: Add -Wno-pedantic to\n\toptions.\n\t* gfortran.dg/c_char_tests_4.f90: Likewise.\n\t* gfortran.dg/c_char_tests_5.f90: Likewise.\n\t* gfortran.dg/binding_label_tests_36.f90: New test.\n\t* gfortran.dg/binding_label_tests_37.f90: New test.", "diff": "diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc\nindex 5d194635ad6..166b10d4cd4 100644\n--- a/gcc/fortran/decl.cc\n+++ b/gcc/fortran/decl.cc\n@@ -8409,7 +8409,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,\n else\n \t{\n \t s->type = type;\n-\t s->sym_name = name;\n+\t s->sym_name = gfc_get_string (\"%s\", name);\n \t s->binding_label = binding_label;\n \t s->where = *where;\n \t s->defined = 1;\ndiff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc\nindex fa508794e20..1ea84198d62 100644\n--- a/gcc/fortran/frontend-passes.cc\n+++ b/gcc/fortran/frontend-passes.cc\n@@ -5884,6 +5884,9 @@ check_against_globals (gfc_symbol *sym)\n || sym->attr.dummy)\n return;\n \n+ if (sym->error)\n+ return;\n+\n if (sym->binding_label)\n sym_name = sym->binding_label;\n else if (sym->attr.use_rename\ndiff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h\nindex b0ce54e1c21..a41ee627e67 100644\n--- a/gcc/fortran/gfortran.h\n+++ b/gcc/fortran/gfortran.h\n@@ -4132,6 +4132,7 @@ void gfc_free_interface (gfc_interface *);\n void gfc_drop_interface_elements_before (gfc_interface **, gfc_interface *);\n bool gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);\n bool gfc_compare_types (gfc_typespec *, gfc_typespec *);\n+int gfc_symbol_rank (gfc_symbol *);\n bool gfc_check_dummy_characteristics (gfc_symbol *, gfc_symbol *,\n \t\t\t\t bool, char *, int);\n bool gfc_check_result_characteristics (gfc_symbol *, gfc_symbol *,\ndiff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc\nindex d25cf0591b7..8ab2fade283 100644\n--- a/gcc/fortran/interface.cc\n+++ b/gcc/fortran/interface.cc\n@@ -1375,8 +1375,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,\n }\n \n \n-static int\n-symbol_rank (gfc_symbol *sym)\n+int\n+gfc_symbol_rank (gfc_symbol *sym)\n {\n gfc_array_spec *as = NULL;\n \n@@ -1420,7 +1420,7 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,\n if (!compare_rank (s1, s2))\n \t{\n \t snprintf (errmsg, err_len, \"Rank mismatch in argument '%s' (%i/%i)\",\n-\t\t s1->name, symbol_rank (s1), symbol_rank (s2));\n+\t\t s1->name, gfc_symbol_rank (s1), gfc_symbol_rank (s2));\n \t return false;\n \t}\n }\n@@ -1667,7 +1667,7 @@ gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,\n if (!compare_rank (r1, r2))\n {\n snprintf (errmsg, err_len, \"Rank mismatch in function result (%i/%i)\",\n-\t\tsymbol_rank (r1), symbol_rank (r2));\n+\t\tgfc_symbol_rank (r1), gfc_symbol_rank (r2));\n return false;\n }\n \n@@ -1958,7 +1958,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,\n \t\tif (errmsg != NULL)\n \t\t snprintf (errmsg, err_len, \"Rank mismatch in argument \"\n \t\t\t \"'%s' (%i/%i)\", f1->sym->name,\n-\t\t\t symbol_rank (f1->sym), symbol_rank (f2->sym));\n+\t\t\t gfc_symbol_rank (f1->sym), gfc_symbol_rank (f2->sym));\n \t\treturn false;\n \t }\n \t if ((gfc_option.allow_std & GFC_STD_F2008)\n@@ -2477,12 +2477,12 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,\n \treturn false;\n \n if (ranks_must_agree\n-\t && symbol_rank (formal) != actual->rank\n-\t && symbol_rank (formal) != -1)\n+\t && gfc_symbol_rank (formal) != actual->rank\n+\t && gfc_symbol_rank (formal) != -1)\n \t{\n \t if (where)\n \t argument_rank_mismatch (formal->name, &actual->where,\n-\t\t\t\t symbol_rank (formal), actual->rank,\n+\t\t\t\t gfc_symbol_rank (formal), actual->rank,\n \t\t\t\t NULL);\n \t return false;\n \t}\n@@ -2692,7 +2692,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,\n \n /* TS29113 C407c; F2018 C711. */\n if (actual->ts.type == BT_ASSUMED\n- && symbol_rank (formal) == -1\n+ && gfc_symbol_rank (formal) == -1\n && actual->rank != -1\n && !(actual->symtree->n.sym->as\n \t && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))\n@@ -2871,7 +2871,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,\n }\n \n /* If the rank is the same or the formal argument has assumed-rank. */\n- if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)\n+ if (gfc_symbol_rank (formal) == actual->rank || gfc_symbol_rank (formal) == -1)\n return true;\n \n rank_check = where != NULL && !is_elemental && formal_as\n@@ -2916,7 +2916,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,\n \t where_formal = NULL;\n \n \t argument_rank_mismatch (formal->name, &actual->where,\n-\t\t\t\t symbol_rank (formal), actual->rank,\n+\t\t\t\t gfc_symbol_rank (formal), actual->rank,\n \t\t\t\t where_formal);\n \t}\n return false;\n@@ -3019,7 +3019,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,\n \t where_formal = NULL;\n \n \t argument_rank_mismatch (formal->name, &actual->where,\n-\t\t\t\t symbol_rank (formal), actual->rank,\n+\t\t\t\t gfc_symbol_rank (formal), actual->rank,\n \t\t\t\t where_formal);\n \t}\n return false;\n@@ -3052,7 +3052,7 @@ get_sym_storage_size (gfc_symbol *sym, bool *size_known)\n else\n strlen = 1;\n \n- if (symbol_rank (sym) == 0)\n+ if (gfc_symbol_rank (sym) == 0)\n {\n *size_known = true;\n return strlen;\n@@ -4639,7 +4639,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)\n \n \t /* TS 29113, C407b. */\n \t if (a->expr && a->expr->expr_type == EXPR_VARIABLE\n-\t && symbol_rank (a->expr->symtree->n.sym) == -1)\n+\t && gfc_symbol_rank (a->expr->symtree->n.sym) == -1)\n \t {\n \t gfc_error (\"Assumed-rank argument requires an explicit interface \"\n \t\t\t \"at %L\", &a->expr->where);\ndiff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc\nindex a5d9add9d2f..f0417b4b7e9 100644\n--- a/gcc/fortran/resolve.cc\n+++ b/gcc/fortran/resolve.cc\n@@ -14877,6 +14877,134 @@ gfc_verify_DTIO_procedures (gfc_symbol *sym)\n return;\n }\n \n+/* Auxiliary function, checks if an argument decays to a pointer. */\n+\n+static bool\n+decays_to_pointer (gfc_symbol *sym)\n+{\n+ if (!sym->as)\n+ return true;\n+\n+ if (sym->as->type == AS_ASSUMED_SHAPE)\n+ return false;\n+\n+ if (sym->as->type == AS_ASSUMED_RANK)\n+ return false;\n+\n+ if (sym->as->type == AS_DEFERRED && sym->attr.dummy)\n+ return false;\n+\n+ return true;\n+}\n+\n+/* Helper function, returns true if the types conform according to the C\n+ standard, when they are not equal on the Fortran side. If we decide to\n+ include or exclude any types from this, this is the place to change. */\n+\n+static bool\n+c_types_conform (gfc_typespec *ts1, gfc_typespec *ts2)\n+{\n+ if (ts1->type == BT_ASSUMED || ts2->type == BT_ASSUMED)\n+ return true;\n+\n+ if (ts1->kind == ts2->kind\n+ && (ts1->type == BT_CHARACTER || ts1->type == BT_INTEGER\n+\t || ts1->type == BT_UNSIGNED)\n+ && (ts2->type == BT_CHARACTER || ts2->type == BT_INTEGER\n+\t || ts2->type == BT_UNSIGNED))\n+ return true;\n+\n+ return false;\n+\n+}\n+\n+/* Check argument lists of BIND(C) procedures against each other, return\n+ false if they do not. */\n+\n+static bool\n+compare_c_binding_arglists (gfc_symbol *osym, gfc_symbol *nsym)\n+{\n+ gfc_formal_arglist *oarg, *narg;\n+ bool ret = true;\n+ locus *oloc, *nloc;\n+\n+ oarg = osym->formal;\n+ narg = nsym->formal;\n+ oloc = &osym->declared_at;\n+ nloc = &nsym->declared_at;\n+ for ( ; oarg && narg ; oarg = oarg->next, narg = narg->next)\n+ {\n+ oloc = &oarg->sym->declared_at;\n+ nloc = &narg->sym->declared_at;\n+\n+ if (!gfc_compare_types (&oarg->sym->ts, &narg->sym->ts)\n+\t && (pedantic || !c_types_conform (&oarg->sym->ts, &narg->sym->ts)))\n+\t{\n+\t gfc_error (\"Type mismatch in argument %qs at %L (%s/%s) \"\n+\t\t \"originally declared at %L\", narg->sym->name,\n+\t\t nloc, gfc_typename (&narg->sym->ts),\n+\t\t gfc_typename (&oarg->sym->ts), oloc);\n+\t\t ret = false;\n+\t\t continue;\n+\t}\n+ if (oarg->sym->attr.value != narg->sym->attr.value)\n+\t{\n+\t gfc_error (\"VALUE attribute mismatch in argument %qs at %L \"\n+\t\t \"originally declared at %L\",narg->sym->name,\n+\t\t nloc, oloc);\n+\t ret = false;\n+\t continue;\n+\t}\n+\n+ /* According to the Fortran standard, ranks have to match for arguments.\n+\t In this case, this makes little sense because both decay to C\n+\t pointers. Only issue an error if -pedantic or if the argument does\n+\t not decay to a pointer. Same thing for CFI_desc arrays, which include\n+\t assumed rank. */\n+\n+ int orank = gfc_symbol_rank (oarg->sym);\n+ int nrank = gfc_symbol_rank (narg->sym);\n+ if (orank != nrank && pedantic)\n+\t{\n+\t gfc_error (\"Rank mismatch in argument %qs (%d/%d) at %L originally \"\n+\t\t \"declared at %L\", narg->sym->name, nrank, orank, nloc,\n+\t\t oloc);\n+\t ret = false;\n+\t continue;\n+\t}\n+\n+ /* Confusion between CFI_desc and \"normal\" arrays. */\n+\n+ if (decays_to_pointer (oarg->sym) != decays_to_pointer (narg->sym))\n+\t{\n+\t gfc_error (\"Array specification mismatch in argument %qs at %L \"\n+\t\t \"originally declared at %L\", narg->sym->name,\n+\t\t nloc, oloc);\n+\t ret = false;\n+\t continue;\n+\t}\n+ }\n+\n+ if (oarg && !narg)\n+ {\n+ gfc_error (\"Not enough arguments for procedure %qs with binding label \"\n+\t\t \"%qs after %L, originally declared at %L\", nsym->name,\n+\t\t nsym->binding_label, nloc, &oarg->sym->declared_at);\n+ ret = false;\n+ }\n+\n+ if (!oarg && narg)\n+ {\n+ gfc_error (\"Too many arguments for procedure %qs with binding label \"\n+\t\t \"%qs at %L, originally declared at %L\", nsym->name,\n+\t\t nsym->binding_label, &narg->sym->declared_at, oloc);\n+ ret = false;\n+ }\n+\n+ return ret;\n+}\n+\n+\n /* Verify that any binding labels used in a given namespace do not collide\n with the names or binding labels of any global symbols. Multiple INTERFACE\n for the same procedure are permitted. Abstract interfaces and dummy\n@@ -14893,7 +15021,24 @@ gfc_verify_binding_labels (gfc_symbol *sym)\n || sym->attr.abstract || sym->attr.dummy)\n return;\n \n- gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);\n+ /* Avoid double error reporting. */\n+ if (sym->error)\n+ return;\n+\n+ /* TODO: Check the names of reserved external C identifiers here, see\n+ PR 125251. */\n+\n+ /* According to the Fortran standard, global identifiers are case\n+ insensitive, which also holds for C identifiers. This was probably done\n+ for systems which had case-insensitive linkers. Such systems could not\n+ accomodate the C standards referenced, so this restriction makes little\n+ sense for modern systems. Therefore, check case-sensitive labels unless\n+ -pedantic is in force. */\n+\n+ if (pedantic)\n+ gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label);\n+ else\n+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);\n \n if (sym->module)\n module = sym->module;\n@@ -14907,6 +15052,48 @@ gfc_verify_binding_labels (gfc_symbol *sym)\n else\n module = NULL;\n \n+ if (gsym)\n+ {\n+ if (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)\n+\t{\n+\t gfc_symbol *global_sym;\n+\t gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &global_sym);\n+\t gcc_assert (global_sym);\n+\n+\t /* If subroutines and functions are conflated, there is little point\n+\t in continuing checks. */\n+\t if ((sym->attr.function && gsym->type == GSYM_SUBROUTINE)\n+\t || (sym->attr.subroutine && gsym->type == GSYM_FUNCTION))\n+\t {\n+\t gfc_global_used (gsym, &sym->declared_at);\n+\t sym->binding_label = NULL;\n+\t sym->error = 1;\n+\t return;\n+\t }\n+\n+\t if (gsym->type == GSYM_FUNCTION && sym->attr.function\n+\t && !gfc_compare_types (&sym->ts, &global_sym->ts))\n+\t {\n+\t gfc_error (\"Return type mismatch of function %qs with binding \"\n+\t\t\t \"label %qs at %L (%s/%s), originally declared at %L\",\n+\t\t\t sym->name, sym->binding_label,\n+\t\t\t &sym->declared_at,\n+\t\t\t gfc_typename (&sym->ts),\n+\t\t\t gfc_typename (&global_sym->ts),\n+\t\t\t &gsym->where);\n+\t sym->binding_label = NULL;\n+\t sym->error = 1;\n+\t return;\n+\t }\n+\t if (!compare_c_binding_arglists (global_sym, sym))\n+\t {\n+\t sym->binding_label = NULL;\n+\t sym->error = 1;\n+\t return;\n+\t }\n+\t}\n+ }\n+\n if (!gsym\n || (!gsym->defined\n \t && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE)))\n@@ -14966,6 +15153,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)\n \t\t \"global identifier as entity at %L\", sym->name,\n \t\t sym->binding_label, &sym->declared_at, &gsym->where);\n sym->binding_label = NULL;\n+ return;\n }\n }\n \ndiff --git a/gcc/testsuite/gfortran.dg/PR100906.f90 b/gcc/testsuite/gfortran.dg/PR100906.f90\nindex f6cb3af6d8a..d848b904069 100644\n--- a/gcc/testsuite/gfortran.dg/PR100906.f90\n+++ b/gcc/testsuite/gfortran.dg/PR100906.f90\n@@ -1,4 +1,5 @@\n ! { dg-do run }\n+! { dg-additional-options \"-Wno-pedantic\" }\n ! { dg-additional-sources PR100906.c }\n !\n ! Test the fix for PR100906\ndiff --git a/gcc/testsuite/gfortran.dg/PR100911.f90 b/gcc/testsuite/gfortran.dg/PR100911.f90\nindex 69f485b59de..c9b4ff590b9 100644\n--- a/gcc/testsuite/gfortran.dg/PR100911.f90\n+++ b/gcc/testsuite/gfortran.dg/PR100911.f90\n@@ -1,5 +1,6 @@\n ! { dg-do run }\n ! { dg-additional-sources PR100911.c }\n+! { dg-additional-options -Wno-pedantic }\n !\n ! Test the fix for PR100911\n ! \ndiff --git a/gcc/testsuite/gfortran.dg/PR100915.f90 b/gcc/testsuite/gfortran.dg/PR100915.f90\nindex 64a2a88fe2d..03f21807815 100644\n--- a/gcc/testsuite/gfortran.dg/PR100915.f90\n+++ b/gcc/testsuite/gfortran.dg/PR100915.f90\n@@ -1,5 +1,6 @@\n ! { dg-do run }\n ! { dg-additional-sources PR100915.c }\n+! { dg-additional-options \"-Wno-pedantic\" }\n !\n ! Test the fix for PR100915\n ! \ndiff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90\nindex 3cb3ac3dda1..d6bb7f61710 100644\n--- a/gcc/testsuite/gfortran.dg/PR94327.f90\n+++ b/gcc/testsuite/gfortran.dg/PR94327.f90\n@@ -1,5 +1,6 @@\n ! { dg-do run }\n ! { dg-additional-sources PR94327.c }\n+! { dg-additional-options -Wno-pedantic }\n !\n ! Test the fix for PR94327\n !\ndiff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90\nindex 6185031afc5..89976e7b0ef 100644\n--- a/gcc/testsuite/gfortran.dg/PR94331.f90\n+++ b/gcc/testsuite/gfortran.dg/PR94331.f90\n@@ -1,5 +1,6 @@\n ! { dg-do run }\n ! { dg-additional-sources PR94331.c }\n+! { dg-additional-options \"-Wno-pedantic\" }\n !\n ! Test the fix for PR94331\n !\ndiff --git a/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90 b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90\nindex 407d8bb9afc..5f38706ab15 100644\n--- a/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90\n+++ b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90\n@@ -3,15 +3,15 @@\n ! Contributed by G.Steinmetz\n \n function f() result(n) bind(c) ! { dg-error \"not C interoperable\" }\n+ ! { dg-error \"Return type mismatch\" \"\" { target \"*-*-*\" } .-1 }\n class(*), allocatable :: n\n end\n program p\n interface\n- function f() result(n) bind(c)\n+ function f() result(n) bind(c) ! { dg-error \"Return type mismatch\" }\n integer :: n\n end\n end interface\n if ( f() /= 0 ) stop\n end\n \n-! { dg-prune-output \"Type mismatch\" }\ndiff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90\nindex 0769eb05de1..65ec55af8f9 100644\n--- a/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90\n+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_25.f90\n@@ -11,7 +11,7 @@ module m_odbc_if\n implicit none\n \n interface sql_set_env_attr\n- function sql_set_env_attr_int( input_handle,attribute,value,length ) &\n+ function sql_set_env_attr_int( input_handle,attribute,value,length ) & ! { dg-error \"Type mismatch\" }\n result(res) bind(C,name=\"SQLSetEnvAttr\")\n use, intrinsic :: iso_c_binding\n implicit none\n@@ -21,7 +21,7 @@ module m_odbc_if\n integer(c_int), value :: length \n integer(c_short) :: res\n end function\n- function sql_set_env_attr_ptr( input_handle,attribute,value,length ) &\n+ function sql_set_env_attr_ptr( input_handle,attribute,value,length ) & ! { dg-error \"Type mismatch\" }\n result(res) bind(C,name=\"SQLSetEnvAttr\")\n use, intrinsic :: iso_c_binding\n implicit none\n@@ -38,24 +38,16 @@ module graph_partitions\n use,intrinsic :: iso_c_binding\n \n interface Cfun\n- subroutine cfunc1 (num, array) bind(c, name=\"Cfun\")\n+ subroutine cfunc1 (num, array) bind(c, name=\"Cfun\") ! { dg-error \"Type mismatch\" }\n import :: c_int\n integer(c_int),value :: num\n integer(c_int) :: array(*) ! <<< HERE: int[]\n end subroutine cfunc1\n \n- subroutine cfunf2 (num, array) bind(c, name=\"Cfun\")\n+ subroutine cfunf2 (num, array) bind(c, name=\"Cfun\") ! { dg-error \"Type mismatch\" }\n import :: c_int, c_ptr\n integer(c_int),value :: num\n type(c_ptr),value :: array ! <<< HERE: void*\n end subroutine cfunf2\n end interface\n end module graph_partitions\n-\n-program test\n- use graph_partitions\n- integer(c_int) :: a(100)\n-\n- call Cfun (1, a)\n- call Cfun (2, C_NULL_PTR)\n-end program test\ndiff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03 b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03\nindex 429fa0b0e84..7ef0612ecd2 100644\n--- a/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03\n+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_3.f03\n@@ -2,14 +2,14 @@\n program main\n use iso_c_binding\n interface\n- subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! Doubtful use ...\n+ subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error \"Type mismatch\" }\n import :: c_ptr, c_int, c_double\n type(c_ptr), value :: f\n integer(c_int), value :: a1, a3\n real(c_double), value :: a2, a4\n end subroutine p1\n \n- subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! ... with incompatible interfaces\n+ subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error \"Type mismatch\" }\n import :: c_ptr, c_int, c_double\n type(c_ptr), value :: f\n real(c_double), value :: a1, a3\ndiff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90\nindex f4f18626ed8..9f24388544a 100644\n--- a/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90\n+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_34.f90\n@@ -1,13 +1,15 @@\n ! { dg-do compile }\n+! { dg-options \"-pedantic\" }\n ! PR 94737 - global symbols are case-insensitive; an error should be\n ! reported if they match (see F2018, 9.2, paragraph 2). Original\n ! test case by Lee Busby.\n \n+! Modified because this catches \n module foo\n \n interface\n-function func1(ii) result (k) bind(c, name=\"c_func\")\n- integer :: ii\n+ function func1(ii) result (k) bind(c, name=\"c_func\") ! { dg-error \"Global binding name\" }\n+ integer :: ii\n integer :: k\n end function func1\n subroutine sub1(ii,jj) bind(c, name=\"c_Func\") ! { dg-error \"Global binding name\" }\n@@ -20,6 +22,6 @@ contains\n function func2(ii) result (k) \n integer :: ii\n integer :: k\n- k = func1(ii) ! { dg-error \"Global binding name\" }\n+ k = func1(ii)\n end function func2\n end module foo\ndiff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90\nnew file mode 100644\nindex 00000000000..03a15146965\n--- /dev/null\n+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_36.f90\n@@ -0,0 +1,46 @@\n+! { dg-do compile }\n+! { dg-options -Wno-pedantic }\n+! Special checks which are disabled without -pedantic.\n+\n+module api\n+ implicit none\n+\n+ ! Case insensitivity with different names.\n+\n+ interface\n+ subroutine s9(a) bind(c, name=\"Quuux\")\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int) :: a\n+ end subroutine s9\n+ end interface\n+\n+ interface\n+ subroutine s10() bind(c, name=\"quuux\")\n+ end subroutine s10\n+ end interface\n+\n+ interface\n+ subroutine s11(a, n) bind(c, name=\"bla\")\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int), value :: n\n+ integer(c_int) :: a\n+ end subroutine s11\n+ end interface\n+\n+ interface\n+ subroutine s12(a, n) bind(c, name=\"bla\")\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int), value :: n\n+ integer(c_int), dimension(*) :: a\n+ end subroutine s12\n+ end interface\n+\n+ interface\n+ subroutine s13(a, n) bind(c, name=\"bla\")\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int), value :: n\n+ integer(c_int), dimension(n) :: a\n+ end subroutine s13\n+ end interface\n+\n+end module\ndiff --git a/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90 b/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90\nnew file mode 100644\nindex 00000000000..64873d54832\n--- /dev/null\n+++ b/gcc/testsuite/gfortran.dg/binding_label_tests_37.f90\n@@ -0,0 +1,127 @@\n+! { dg-do compile }\n+module api\n+ implicit none\n+\n+ interface\n+ function f1(a) result(istat) & ! { dg-error \"Type mismatch in argument\" }\n+ bind(c, name=\"foo\")\n+ use, intrinsic :: iso_c_binding, only :c_int\n+ implicit none\n+ integer(kind=c_int) :: a\n+ integer(kind=c_int) :: istat\n+ end function\n+ end interface\n+\n+ interface\n+ function f2(a) result(istat) & ! { dg-error \"Type mismatch in argument\" }\n+ bind(c, name=\"foo\")\n+ use, intrinsic :: iso_c_binding, only : c_int, c_float\n+ implicit none\n+ real(kind=c_float) :: a ! integer\n+ integer(kind=c_int) :: istat\n+ end function\n+ end interface\n+\n+ interface\n+ subroutine s3(a) bind(C, name=\"bar\") ! { dg-error \"VALUE attribute\" }\n+ use, intrinsic :: iso_c_binding, only :c_int\n+ integer, value :: a\n+ end subroutine s3\n+ end interface\n+\n+ interface\n+ subroutine s4(a) bind(C, name=\"bar\") ! { dg-error \"VALUE attribute\" }\n+ use, intrinsic :: iso_c_binding, only :c_int\n+ integer :: a\n+ end subroutine s4\n+ end interface\n+\n+ interface\n+ function f5 (a) result(istat) bind(c, name=\"qux\") ! { dg-error \"Return type mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_intptr_t, c_int\n+ implicit none\n+ integer(kind=c_intptr_t) :: a ! integer\n+ integer(kind=c_int) :: istat\n+ end function f5\n+ end interface\n+\n+ interface\n+ function f6(a) result(istat) bind(c, name=\"qux\") ! { dg-error \"Return type mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_intptr_t, c_float\n+ implicit none\n+ integer(kind=c_intptr_t) :: a ! integer\n+ real(kind=c_float) :: istat\n+ end function f6\n+ end interface\n+\n+ interface\n+ subroutine s7() bind(c, name=\"quux\") ! { dg-error \"Too many arguments\" }\n+ end subroutine s7\n+ end interface\n+\n+ interface\n+ subroutine s8(a) bind(c, name=\"quux\") ! { dg-error \"Too many arguments\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int) :: a\n+ end subroutine s8\n+ end interface\n+\n+ interface\n+ subroutine s9(a) bind(c, name=\"quuux\") ! { dg-error \"Too many arguments\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int) :: a\n+ end subroutine s9\n+ end interface\n+\n+ interface\n+ subroutine s10() bind(c, name=\"quuux\") ! { dg-error \"Too many arguments\" }\n+ end subroutine s10\n+ end interface\n+\n+ ! \"bla\" check with -pedantic only.\n+\n+ interface\n+ subroutine s11(a, n) bind(c, name=\"bla\") ! { dg-error \"Rank mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int), value :: n\n+ integer(c_int) :: a\n+ end subroutine s11\n+ end interface\n+\n+ interface\n+ subroutine s12(a, n) bind(c, name=\"bla\") ! { dg-error \"Rank mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int), value :: n\n+ integer(c_int), dimension(*) :: a\n+ end subroutine s12\n+ end interface\n+\n+ interface\n+ subroutine s14(a) bind(c, name=\"blubb\") ! { dg-error \"Type mismatch in argument\" }\n+ use, intrinsic :: iso_c_binding, only: c_ptr\n+ type(c_ptr), value :: a\n+ end subroutine s14\n+ end interface\n+\n+ interface\n+ subroutine s15(a) bind(c, name=\"blubb\") ! { dg-error \"Type mismatch in argument\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer(c_int) :: a\n+ end subroutine s15\n+ end interface\n+\n+ interface\n+ subroutine s16(a) bind(c, name=\"blabla\") ! { dg-error \"Array specification mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer, dimension(:) :: a\n+ end subroutine s16\n+ end interface\n+\n+ interface\n+ subroutine s17(a) bind(c, name=\"blabla\") ! { dg-error \"Array specification mismatch\" }\n+ use, intrinsic :: iso_c_binding, only : c_int\n+ integer, dimension(*) :: a\n+ end subroutine s17\n+ end interface\n+\n+end module\ndiff --git a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90\nindex 512948a2a3f..b745c2309ac 100644\n--- a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90\n+++ b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90\n@@ -1,4 +1,5 @@\n ! { dg-do run }\n+! { dg-additional-options \"-Wno-pedantic\" }\n !\n ! PR fortran/103828\n ! Check that we can pass many function args as C char, which are interoperable\ndiff --git a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90\nindex c7a1c6e8c2b..8a8368c43be 100644\n--- a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90\n+++ b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90\n@@ -1,5 +1,5 @@\n ! { dg-do run }\n-! { dg-options \"-fbackslash\" }\n+! { dg-options \"-fbackslash -Wno-pedantic\" }\n !\n ! PR fortran/103828\n ! Check that we can C char with non-ASCII values, which are interoperable\n", "prefixes": [] }