From a5baf71b0a5bd79923c095cf81218b8194008f60 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 2 Aug 2020 10:57:59 +0100 Subject: [PATCH] This patch fixes PR96320. See the explanatory comment in the testcase. 2020-08-01 Paul Thomas gcc/fortran PR target/96320 * interface.c (gfc_check_dummy_characteristics): If a module procedure arrives with assumed shape in the interface and deferred shape in the procedure itself, update the latter and copy the lower bounds. gcc/testsuite/ PR target/96320 * gfortran.dg/module_procedure_4.f90 : New test. --- gcc/fortran/interface.c | 19 +++++-- gcc/testsuite/gfortran.dg/module_procedure_4.f90 | 63 ++++++++++++++++++++++++ 2 files changed, 79 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/module_procedure_4.f90 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index e518209..7985fc7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1466,6 +1466,19 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, int i, compval; gfc_expr *shape1, *shape2; + /* Sometimes the ambiguity between deferred shape and assumed shape + does not get resolved in module procedures, where the only explicit + declaration of the dummy is in the interface. */ + if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure + && s1->as->type == AS_ASSUMED_SHAPE + && s2->as->type == AS_DEFERRED) + { + s2->as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < s2->as->rank; i++) + if (s1->as->lower[i] != NULL) + s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]); + } + if (s1->as->type != s2->as->type) { snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", @@ -2617,7 +2630,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) { - if (where + if (where && (!formal->attr.artificial || (!formal->maybe_array && !maybe_dummy_array_arg (actual)))) { @@ -2708,7 +2721,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (ref == NULL && actual->expr_type != EXPR_NULL) { - if (where + if (where && (!formal->attr.artificial || (!formal->maybe_array && !maybe_dummy_array_arg (actual)))) { @@ -3965,7 +3978,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, sym->attr.proc == PROC_ST_FUNCTION, where)) return false; - + if (!check_intents (dummy_args, *ap)) return false; diff --git a/gcc/testsuite/gfortran.dg/module_procedure_4.f90 b/gcc/testsuite/gfortran.dg/module_procedure_4.f90 new file mode 100644 index 0000000..c30bbfe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_procedure_4.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! Test the fix for PR96320 in which the assumed shape of 'arg' in the +! interface for 'bar' was mirrored by the 'arg' in the module procedure +! incorrectly have deferred shape. +! +! Contributed by Damian Rouson +! +module foobar + type foo + contains + procedure, nopass :: bar1 + procedure, nopass :: bar2 + procedure, nopass :: bar3 + end type + + interface + + module subroutine bar1(arg) + character(len=*) arg(:) + end subroutine + + module subroutine bar2(arg) + character(len=*) arg(3:) + end subroutine + + module subroutine bar3(arg) + character(len=*) arg(2) + end subroutine + + end interface +contains + + module procedure bar1 + if (lbound(arg, 1) .ne. 1) stop 1 + if (arg(3) .ne. 'hijk') stop 2 + end procedure + +! Make sure that the lower bound of an assumed shape array dummy, +! if defined, is passed to the module procedure. + + module procedure bar2 + if (lbound(arg, 1) .ne. 3) stop 3 + if (arg(3) .ne. 'abcd') stop 4 + end procedure + +! This makes sure that an dummy with explicit shape has the upper +! bound correctly set in the module procedure. + + module procedure bar3 + if (lbound(arg, 1) .ne. 1) stop 5 + if (arg(3) .ne. 'hijk') stop 6 ! { dg-warning "is out of bounds" } + end procedure + +end module + + use foobar + character(4) :: list(3) = ['abcd', 'efgh' , 'hijk'] + type(foo) :: f + call f%bar1(list) + call f%bar2(list) + call f%bar3(list) +end -- 2.7.4