This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] PR 47569 - fix ICE (regression) and fix diagnostic
- From: Tobias Burnus <burnus at net-b dot de>
- To: Mikael Morin <mikael dot morin at sfr dot fr>
- Cc: fortran at gcc dot gnu dot org, gcc patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 13 Feb 2011 13:30:39 +0100
- Subject: Re: [Patch, Fortran] PR 47569 - fix ICE (regression) and fix diagnostic
- References: <4D55C5C1.3000601@net-b.de> <201102122154.44139.mikael.morin@sfr.fr>
Dear Mikael, dear all,
attached is an updated version of the patch, incorporating the
suggestions of Mikael (thanks!). I think I have indeed misread part of
the standard. (Twice!)
The new patch continues to accepts all default/C_CHAR kind characters.
Other character kinds are still accepted, but now properly diagnosed.
The pointer checking and the handling of (nested) components has been
fixed - which was the original PR.
Build and regtested on x86-64-linux
OK for the trunk? To which of 4.3/4.4/4.5 do we want to backport it?
Tobias
2011-02-13 Tobias Burnus <burnus@net-b.de>
PR fortran/47569
* interface.c (compare_parameter): Avoid ICE with
character components.
2011-02-13 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/argument_checking_13.f90: Update dg-error.
* gfortran.dg/argument_checking_17.f90: New.
--- /dev/null 2011-02-12 08:11:41.879999996 +0100
+++ gcc/gcc/testsuite/gfortran.dg/argument_checking_17.f90 2011-02-01 15:02:42.000000000 +0100
@@ -0,0 +1,26 @@
+! { dg-do compile }
+!
+! PR fortran/47569
+!
+! Contributed by Jos de Kloe
+!
+module teststr
+ implicit none
+ integer, parameter :: GRH_SIZE = 20, NMAX = 41624
+ type strtype
+ integer :: size
+ character :: mdr(NMAX)
+ end type strtype
+contains
+ subroutine sub2(string,str_size)
+ integer,intent(in) :: str_size
+ character,intent(out) :: string(str_size)
+ string(:) = 'a'
+ end subroutine sub2
+ subroutine sub1(a)
+ type(strtype),intent(inout) :: a
+ call sub2(a%mdr(GRH_SIZE+1),a%size-GRH_SIZE)
+ end subroutine sub1
+end module teststr
+
+! { dg-final { cleanup-modules "teststr" } }
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 1e5df61..120f0ce 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1461,7 +1461,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
- bool rank_check;
+ bool rank_check, is_pointer;
/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -1672,23 +1672,56 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return 1;
/* At this point, we are considering a scalar passed to an array. This
- is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+ is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
- if the actual argument is (a substring of) an element of a
- non-assumed-shape/non-pointer array;
- - (F2003) if the actual argument is of type character. */
+ non-assumed-shape/non-pointer/non-polymorphic array;
+ - (F2003) if the actual argument is of type character of default/c_char
+ kind. */
+
+ is_pointer = actual->expr_type == EXPR_VARIABLE
+ ? actual->symtree->n.sym->attr.pointer : false;
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
- && ref->u.ar.dimen > 0)
- break;
+ {
+ if (ref->type == REF_COMPONENT)
+ is_pointer = ref->u.c.component->attr.pointer;
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0
+ && (!ref->next
+ || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+ break;
+ }
+
+ if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
+ {
+ if (where)
+ gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+ "at %L", formal->name, &actual->where);
+ return 0;
+ }
- /* Not an array element. */
- if (formal->ts.type == BT_CHARACTER
- && (ref == NULL
- || (actual->expr_type == EXPR_VARIABLE
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))))
+ if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+ && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
{
+ if (where)
+ gfc_error ("Element of assumed-shaped or pointer "
+ "array passed to array dummy argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+ && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+ {
+ if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+ {
+ if (where)
+ gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+ "CHARACTER actual argument with array dummy argument "
+ "'%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
+
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
{
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
@@ -1701,7 +1734,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
else
return 1;
}
- else if (ref == NULL && actual->expr_type != EXPR_NULL)
+
+ if (ref == NULL && actual->expr_type != EXPR_NULL)
{
if (where)
argument_rank_mismatch (formal->name, &actual->where,
@@ -1709,17 +1743,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return 0;
}
- if (actual->expr_type == EXPR_VARIABLE
- && actual->symtree->n.sym->as
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))
- {
- if (where)
- gfc_error ("Element of assumed-shaped array passed to dummy "
- "argument '%s' at %L", formal->name, &actual->where);
- return 0;
- }
-
return 1;
}
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 b/gcc/testsuite/gfortran.dg/argument_checking_13.f90
index ae3fd22..b94bbc7 100644
--- a/gcc/testsuite/gfortran.dg/argument_checking_13.f90
+++ b/gcc/testsuite/gfortran.dg/argument_checking_13.f90
@@ -26,9 +26,9 @@ real, pointer :: pointer_dummy(:,:,:)
real, allocatable :: deferred(:,:,:)
real, pointer :: ptr(:,:,:)
call rlv1(deferred(1,1,1)) ! valid since contiguous
-call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
-call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
-call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
+call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
end
subroutine test2(assumed_sh_dummy, pointer_dummy)