From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1431) id 899EC3858415; Mon, 6 May 2024 09:57:46 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 899EC3858415 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1714989466; bh=EuBBNMay8oMQ5MyaDWJ3YIyKcZjVZGaiG3wXx8XHJbk=; h=From:To:Subject:Date:From; b=Q2FJGVF1oqvrKo3KP9ZNixPp014IhOj5wtIOgps7aUWG1qM5tkNjIU9NiZdBvaD6T L5kIi3IxS0YUEyfI/wznTqcOlRhFXK9JFP3g6m46HfyFcuZdyc4PSwEe5SQL6hwW6K BB9wgs9Sie6HLEdfY5g47atXf3AOJ/Ay8un2+w1g= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Paul Thomas To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-8692] Fortran: Add error for subroutine passed to a variable dummy [PR106999] X-Act-Checkin: gcc X-Git-Author: Paul Thomas X-Git-Refname: refs/heads/releases/gcc-13 X-Git-Oldrev: f598a1c8a77e678ca009b433fd849b4834594926 X-Git-Newrev: 429935510202c4efee933bf907fd9dff816193f2 Message-Id: <20240506095746.899EC3858415@sourceware.org> Date: Mon, 6 May 2024 09:57:46 +0000 (GMT) List-Id: https://gcc.gnu.org/g:429935510202c4efee933bf907fd9dff816193f2 commit r13-8692-g429935510202c4efee933bf907fd9dff816193f2 Author: Paul Thomas Date: Tue Apr 2 15:53:29 2024 +0100 Fortran: Add error for subroutine passed to a variable dummy [PR106999] 2024-04-02 Paul Thomas gcc/fortran PR fortran/106999 * interface.cc (gfc_compare_interfaces): Add error for a subroutine proc pointer passed to a variable formal. (compare_parameter): If a procedure pointer is being passed to a non-procedure formal arg, and there is an an interface, use gfc_compare_interfaces to check and provide a more useful error message. gcc/testsuite/ PR fortran/106999 * gfortran.dg/pr106999.f90: New test. (cherry picked from commit a7aa9455a8b9cb080649a7357b7360f2d99bcbf1) Diff: --- gcc/fortran/interface.cc | 20 +++++++++++++++++++- gcc/testsuite/gfortran.dg/pr106999.f90 | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index dc384ad9323..05c92ab8f67 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -1752,6 +1752,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, return false; } + if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed " + "to dummy variable '%s'", name2, s1->name); + return false; + } + /* Do strict checks on all characteristics (for dummy procedures and procedure pointer assignments). */ if (!generic_flag && strict_flag) @@ -2388,12 +2396,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { gfc_symbol *act_sym = actual->symtree->n.sym; - if (formal->attr.flavor != FL_PROCEDURE) + if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface) { if (where) gfc_error ("Invalid procedure argument at %L", &actual->where); return false; } + else if (act_sym->ts.interface + && !gfc_compare_interfaces (formal, act_sym->ts.interface, + act_sym->name, 0, 1, err, + sizeof(err),NULL, NULL)) + { + if (where) + gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" + " %s", formal->name, &actual->where, err); + return false; + } if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, sizeof(err), NULL, NULL)) diff --git a/gcc/testsuite/gfortran.dg/pr106999.f90 b/gcc/testsuite/gfortran.dg/pr106999.f90 new file mode 100644 index 00000000000..f05a27006f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr106999.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Test the fix for PR106999 +! Contributed by Gerhard Steinmetz +program p + type t + integer :: i + procedure(g), pointer :: f + end type + class(t), allocatable :: y, z + procedure(g), pointer :: ff + allocate (z) + z%i = 42 + z%f => g + ff => g + call r(z%f) + call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" } + call s(ff) ! { dg-error "Interface mismatch in dummy procedure" } +contains + subroutine g(x) + class(t) :: x + x%i = 84 + end + subroutine r(x) + procedure(g) :: x + print *, "in r" + allocate (y) + call x(y) + print *, y%i + end + subroutine s(x) + class(*) :: x + end subroutine +end