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

re PR fortran/32616 ("Too short actual argument" for array element storage sequence)

Browse source 
2008-01-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/32616
        * interface.c (get_expr_storage_size): Return storage size
        for array element designators.
        (compare_actual_formal): Reject unequal string sizes for
        assumed-shape dummy arguments. And fix error message for
        array-sections with vector subscripts.

2008-01-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/32616
        * gfortran.dg/argument_checking_15.f90: New.
        * gfortran.dg/argument_checking_5.f90: Change TODO into
        dg-warning.

From-SVN: r131643
This commit is contained in:
Tobias Burnus 2008-01-19 00:46:04 +01:00 • committed by Tobias Burnus
parent 7939be8022
commit a0710c29ea
5 changed files with 146 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View file

@ -1,3 +1,12 @@
2008-01-18 Tobias Burnus <burnus@net-b.de>
PR fortran/32616
* interface.c (get_expr_storage_size): Return storage size
for array element designators.
(compare_actual_formal): Reject unequal string sizes for
assumed-shape dummy arguments. And fix error message for
array-sections with vector subscripts.
2008-01-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/34556

98
gcc/fortran/interface.c
View file

@ -1639,6 +1639,7 @@ get_expr_storage_size (gfc_expr *e)
int i;
long int strlen, elements;
long int substrlen = 0;
bool is_str_storage = false;
gfc_ref *ref;
if (e == NULL)
@ -1676,10 +1677,17 @@ get_expr_storage_size (gfc_expr *e)
if (ref->type == REF_SUBSTRING && ref->u.ss.start
&& ref->u.ss.start->expr_type == EXPR_CONSTANT)
{
int len = strlen;
if (ref->u.ss.end && ref->u.ss.end->expr_type == EXPR_CONSTANT)
len = mpz_get_ui (ref->u.ss.end->value.integer);
substrlen = len - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
if (is_str_storage)
{
/* The string length is the substring length.
Set now to full string length. */
if (ref->u.ss.length == NULL
|| ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
return 0;
strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
}
substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
continue;
}
@ -1741,21 +1749,46 @@ get_expr_storage_size (gfc_expr *e)
return 0;
}
else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
&& e->expr_type == EXPR_VARIABLE
&& (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
|| e->symtree->n.sym->attr.pointer))
elements = 1;
&& e->expr_type == EXPR_VARIABLE)
{
if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
|| e->symtree->n.sym->attr.pointer)
{
elements = 1;
continue;
}
/* Determine the number of remaining elements in the element
sequence for array element designators. */
is_str_storage = true;
for (i = ref->u.ar.dimen - 1; i >= 0; i--)
{
if (ref->u.ar.start[i] == NULL
|| ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
|| ref->u.ar.as->upper[i] == NULL
|| ref->u.ar.as->lower[i] == NULL
|| ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
|| ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
return 0;
elements
= elements
* (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ 1L)
- (mpz_get_si (ref->u.ar.start[i]->value.integer)
- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
}
}
else
/* TODO: Determine the number of remaining elements in the element
sequence for array element designators. See PR 32616.
See also get_array_index in data.c. */
return 0;
}
if (substrlen)
return elements*substrlen;
return elements*strlen;
return (is_str_storage) ? substrlen + (elements-1)*strlen
: elements*strlen;
else
return elements*strlen;
}
@ -1880,23 +1913,34 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
is_elemental, where))
return 0;
/* Special case for character arguments. For allocatable, pointer
and assumed-shape dummies, the string length needs to match
exactly. */
if (a->expr->ts.type == BT_CHARACTER
&& a->expr->ts.cl && a->expr->ts.cl->length
&& a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
&& f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
&& f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
&& f->sym->ts.cl->length->expr_type == EXPR_CONSTANT
&& (f->sym->attr.pointer || f->sym->attr.allocatable
|| (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
&& (mpz_cmp (a->expr->ts.cl->length->value.integer,
f->sym->ts.cl->length->value.integer) != 0))
{
if ((f->sym->attr.pointer || f->sym->attr.allocatable)
&& (mpz_cmp (a->expr->ts.cl->length->value.integer,
f->sym->ts.cl->length->value.integer) != 0))
{
if (where)
gfc_warning ("Character length mismatch between actual "
"argument and pointer or allocatable dummy "
"argument '%s' at %L",
f->sym->name, &a->expr->where);
return 0;
}
if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
"argument and pointer or allocatable dummy argument "
"'%s' at %L",
mpz_get_si (a->expr->ts.cl->length->value.integer),
mpz_get_si (f->sym->ts.cl->length->value.integer),
f->sym->name, &a->expr->where);
else if (where)
gfc_warning ("Character length mismatch (%ld/%ld) between actual "
"argument and assumed-shape dummy argument '%s' "
"at %L",
mpz_get_si (a->expr->ts.cl->length->value.integer),
mpz_get_si (f->sym->ts.cl->length->value.integer),
f->sym->name, &a->expr->where);
return 0;
}
actual_size = get_expr_storage_size (a->expr);
@ -2001,7 +2045,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (where)
gfc_error ("Array-section actual argument with vector subscripts "
"at %L is incompatible with INTENT(IN), INTENT(INOUT) "
"at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
"or VOLATILE attribute of the dummy argument '%s'",
&a->expr->where, f->sym->name);
return 0;

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
2008-01-18 Tobias Burnus <burnus@net-b.de>
PR fortran/32616
* gfortran.dg/argument_checking_15.f90: New.
* gfortran.dg/argument_checking_5.f90: Change TODO into
dg-warning.
2008-01-18 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/enum_4.f90: Replace dg-excess-errors by dg-error.

57
gcc/testsuite/gfortran.dg/argument_checking_15.f90 Normal file
View file

@ -0,0 +1,57 @@
! { dg-do compile }
!
! PR fortran/32616
!
! Check for to few elements of the actual argument
! and reject mismatching string lengths for assumed-shape dummies
!
implicit none
external test
integer :: i(10)
integer :: j(2,2)
character(len=4) :: str(2)
character(len=4) :: str2(2,2)
call test()
call foo(i(8)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
call foo(j(1,1))
call foo(j(2,1)) ! { dg-warning "too few elements for dummy argument 'a' .3/4." }
call foo(j(1,2)) ! { dg-warning "too few elements for dummy argument 'a' .2/4." }
str = 'FORT'
str2 = 'fort'
call bar(str(:)(1:2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
call bar(str(1:2)(1:1)) ! { dg-warning "too few elements for dummy argument 'c' .2/6." }
call bar(str(2)) ! { dg-warning "too few elements for dummy argument 'c' .4/6." }
call bar(str(1)(2:1)) ! OK
call bar(str2(2,1)(4:1)) ! OK
call bar(str2(1,2)(3:4)) ! OK
call bar(str2(1,2)(4:4)) ! { dg-warning "too few elements for dummy argument 'c' .5/6." }
contains
subroutine foo(a)
integer :: a(4)
end subroutine foo
subroutine bar(c)
character(len=2) :: c(3)
! print '(3a)', ':',c(1),':'
! print '(3a)', ':',c(2),':'
! print '(3a)', ':',c(3),':'
end subroutine bar
end
subroutine test()
implicit none
character(len=5), pointer :: c
character(len=5) :: str(5)
call foo(c) ! { dg-error "Character length mismatch" }
call bar(str) ! { dg-error "Character length mismatch" }
contains
subroutine foo(a)
character(len=3), pointer :: a
end subroutine
subroutine bar(a)
character(len=3) :: a(:)
end subroutine bar
end subroutine test

4
gcc/testsuite/gfortran.dg/argument_checking_5.f90
View file

@ -19,7 +19,7 @@ call foobar(b(1:3)) ! { dg-warning "contains too few elements" }
call foobar(b(1:5))
call foobar(b(1:5:2)) ! { dg-warning "contains too few elements" }
call foobar(b(2))
call foobar(b(3)) ! TODO: contains too few elements
call foobar(b(3)) ! { dg-warning "Actual argument contains too few elements" }
call foobar(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
call foobar(reshape(b(2:5),[2,2]))
@ -29,7 +29,7 @@ call arr(b(1:3)) ! { dg-warning "contains too few elements" }
call arr(b(1:5))
call arr(b(1:5:2)) ! { dg-warning "contains too few elements" }
call arr(b(2))
call arr(b(3)) ! TODO: contains too few elements
call arr(b(3)) ! { dg-warning "contains too few elements" }
call arr(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
call arr(reshape(b(2:5),[2,2]))
end program test