diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2024-04-02 15:53:29 +0100 |
|---|---|---|
| committer | Paul Thomas <pault@gcc.gnu.org> | 2024-05-06 10:57:34 +0100 |
| commit | 429935510202c4efee933bf907fd9dff816193f2 (patch) | |
| tree | 5444a0d4bdac869a73c3bb92a2901b9d068144f8 /gcc | |
| parent | f598a1c8a77e678ca009b433fd849b4834594926 (diff) | |
| download | gcc-429935510202c4efee933bf907fd9dff816193f2.zip gcc-429935510202c4efee933bf907fd9dff816193f2.tar.gz gcc-429935510202c4efee933bf907fd9dff816193f2.tar.bz2 | |
Fortran: Add error for subroutine passed to a variable dummy [PR106999]
2024-04-02 Paul Thomas <pault@gcc.gnu.org>
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)
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/interface.cc | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pr106999.f90 | 33 |
2 files changed, 52 insertions, 1 deletions
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index dc384ad..05c92ab 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 0000000..f05a270 --- /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 <gscfq@t-online.de> +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 |