From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1431) id 47E9F3858D1E; Mon, 6 May 2024 10:01:17 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 47E9F3858D1E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1714989677; bh=503aUvI/t/9Z3ZzcbJ00/Lnz6GDGTIVf1+7CN32NrhE=; h=From:To:Subject:Date:From; b=NM9qUk+RsVi7FNgwhj3nDtzf9aRf3GjYN/+KxpLoO8tCep5yU2V4HwWP9INR//3IY GqP//dmThpqk5zvNI/ten+VVNfW1PJDA7gtXsmRr8aXE8y/1CmSE53hvUeBegRwj8n u3Azco7ApvKM+JFDy57Mmgnujst4DyfDhfYaZ6rM= 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 r12-10416] 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-12 X-Git-Oldrev: 3a5acd2583056e8cd0e5fda83e7c34be65415c62 X-Git-Newrev: d72e9f90e370538b057690b16c1e65350dbbb75c Message-Id: <20240506100117.47E9F3858D1E@sourceware.org> Date: Mon, 6 May 2024 10:01:17 +0000 (GMT) List-Id: https://gcc.gnu.org/g:d72e9f90e370538b057690b16c1e65350dbbb75c commit r12-10416-gd72e9f90e370538b057690b16c1e65350dbbb75c 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 874acb914f3..0c4cd385d56 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -1746,6 +1746,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) @@ -2381,12 +2389,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