OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

This patch fixes PR96320. See the explanatory comment in the testcase.

Browse Source 
2020-08-01  Paul Thomas  <pault@gcc.gnu.org>

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.
This commit is contained in:
Paul Thomas 2020-08-02 10:57:59 +01:00
parent 6912619fce
commit a5baf71b0a
2 changed files with 79 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/fortran/interface.c
View File

@ -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;

63
gcc/testsuite/gfortran.dg/module_procedure_4.f90 Normal file
View File

@ -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 <damian@sourceryinstitute.org>
!
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