procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/47569 (gfortran does not detect that the parameters for passing a partial string to a subroutine are incorrect)

Browse source 
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.

From-SVN: r170110
This commit is contained in:
Tobias Burnus 2011-02-13 20:26:24 +01:00 • committed by Tobias Burnus
parent 4b79050f02
commit 975b975b29
5 changed files with 89 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View file

@ -1,3 +1,9 @@
2011-02-13 Tobias Burnus <burnus@net-b.de>
PR fortran/47569
* interface.c (compare_parameter): Avoid ICE with
character components.
2011-02-12 Janus Weil <janus@gcc.gnu.org>
* class.c (gfc_build_class_symbol): Reject polymorphic arrays.

75
gcc/fortran/interface.c
View file

@ -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; or
- (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;
/* 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 (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;
}
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;
}

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
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.
2011-02-12 Janus Weil <janus@gcc.gnu.org>
* gfortran.dg/allocate_derived_1.f90: Modified as polymorphic arrays

6
gcc/testsuite/gfortran.dg/argument_checking_13.f90
View file

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

26
gcc/testsuite/gfortran.dg/argument_checking_17.f90 Normal file
View file

@ -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" } }