This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR30940 - Sequence association and actual/formal argument element sequence compile time checks
- From: Tobias Burnus <burnus at net-b dot de>
- To: "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 30 Jun 2007 00:25:25 +0200
- Subject: [Patch, Fortran] PR30940 - Sequence association and actual/formal argument element sequence compile time checks
:ADDPATCH fortran:
This patch addresses two related but separate problems:
* gfortran did not support the Fortran 2003 sequence association of
character strings and character arrays. As ISO C Bindings may only be
used for character(len=1) arrays, this feature is used by many Fortran
2003 programs.
* Additionally, gfortran did only very few checks whether the length of
the actual argument was at least as long as the dummy argument. I added
a couple more checks. These checkings spit out only a warning; I also
downgraded some of the previous error to a warning. Comments, suggestions?
In the Fortran 2003 standard one finds this in Section "12.4.1 Actual
arguments, dummy arguments, and argument association"
and especially in Subsection "12.4.1.5 Sequence association".
I do not test for neither array substrings nor for array element
designators; I leave this as exercise to someone else ...
I'm almost positive that this patch will reject a real-world application
which works - and might even be valid. But lacking imagination I cannot
image why a valid program would be rejected.
As collateral damage it kind of fixes PR 24886. (It does not fix the
problem due to missing whole-file checking; but if one puts the file
into a "contains", it works; I think it worked even before my patch.)
Build and regression tested on x86_64-unknown-linux-gnu.
Ok for the trunk?
Tobias
2007-06-30 Tobias Burnus <burnus@net-b.de>
PR fortran/30940
* interface.c (get_sym_storage_size): New function.
(get_sym_storage_size): New function.
(compare_actual_formal): Enhance sequence association
support and improve checking.
2007-06-30 Tobias Burnus <burnus@net-b.de>
PR fortran/30940
* gfortran.dg/argument_checking_1.f90: New.
* gfortran.dg/argument_checking_2.f90: New.
* gfortran.dg/argument_checking_3.f90: New.
* gfortran.dg/argument_checking_4.f90: New.
* gfortran.dg/argument_checking_5.f90: New.
* gfortran.fortran-torture/execute/st_function_1.f90: Add dg-warning.
* gfortran.fortran-torture/execute/st_function.f90: Add dg-warning.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 126114)
+++ gcc/fortran/interface.c (working copy)
@@ -1264,6 +1264,153 @@ compare_parameter_protected (gfc_symbol
}
+/* Returns the storage size of a symbol (formal argument) or
+ zero if it cannot be determined. */
+
+static unsigned long
+get_sym_storage_size (gfc_symbol *sym)
+{
+ int i;
+ unsigned long strlen, elements;
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ if (sym->ts.cl && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+ else
+ return 0;
+ }
+ else
+ strlen = 1;
+
+ if (symbol_rank (sym) == 0)
+ return strlen;
+
+ elements = 1;
+ if (sym->as->type != AS_EXPLICIT)
+ return 0;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
+ || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
+ - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+ }
+
+ return strlen*elements;
+}
+
+
+/* Returns the storage size of an expression (actual argument) or
+ zero if it cannot be determined. For an array element, it returns
+ the remaing size as the element sequence consists of all storage
+ units of the actual argument up to the end of the array. */
+
+static unsigned long
+get_expr_storage_size (gfc_expr *e)
+{
+ int i;
+ long int strlen, elements;
+ gfc_ref *ref;
+
+ if (e == NULL)
+ return 0;
+
+ if (e->ts.type == BT_CHARACTER)
+ {
+ if (e->ts.cl && e->ts.cl->length
+ && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_si (e->ts.cl->length->value.integer);
+ else if (e->expr_type == EXPR_CONSTANT
+ && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ strlen = e->value.character.length;
+ else
+ return 0;
+ }
+ else
+ strlen = 1; /* Length per element. */
+
+ if (e->rank == 0 && !e->ref)
+ return strlen;
+
+ elements = 1;
+ if (!e->ref)
+ {
+ if (!e->shape)
+ return 0;
+ for (i = 0; i < e->rank; i++)
+ elements *= mpz_get_si (e->shape[i]);
+ return elements*strlen;
+ }
+
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
+ && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
+ && ref->u.ar.as->upper)
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ long int start, end, stride;
+ stride = 1;
+ start = 1;
+ if (ref->u.ar.stride[i])
+ {
+ if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
+ stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
+ else
+ return 0;
+ }
+
+ if (ref->u.ar.start[i])
+ {
+ if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
+ start = mpz_get_si (ref->u.ar.start[i]->value.integer);
+ else
+ return 0;
+ }
+
+ if (ref->u.ar.end[i])
+ {
+ if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
+ end = mpz_get_si (ref->u.ar.end[i]->value.integer);
+ else
+ return 0;
+ }
+ else if (ref->u.ar.as->upper[i]
+ && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+ end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
+ else
+ return 0;
+
+ elements *= (end - start)/stride + 1L;
+ }
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
+ && ref->u.ar.as->lower && ref->u.ar.as->upper)
+ for (i = 0; i < ref->u.ar.as->rank; i++)
+ {
+ if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
+ && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
+ && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+ elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
+ + 1L;
+ else
+ return 0;
+ }
+ else
+ /* TODO: Determine the number of remaining elements in the element
+ sequence for array element designators.
+ See also get_array_index in data.c. */
+ return 0;
+ }
+
+ return elements*strlen;
+}
+
+
/* Given an expression, check whether it is an array section
which has a vector subscript. If it has, one is returned,
otherwise zero. */
@@ -1302,6 +1449,7 @@ compare_actual_formal (gfc_actual_arglis
gfc_formal_arglist *f;
int i, n, na;
bool rank_check;
+ unsigned long actual_size, formal_size;
actual = *ap;
@@ -1385,8 +1533,23 @@ compare_actual_formal (gfc_actual_arglis
&& (f->sym->as->type == AS_ASSUMED_SHAPE
|| f->sym->as->type == AS_DEFERRED);
- if (!compare_parameter (f->sym, a->expr,
- ranks_must_agree || rank_check, is_elemental))
+ if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
+ && a->expr->rank == 0
+ && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
+ {
+ if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+ {
+ gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
+ "with array dummy argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+ else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+ return 0;
+
+ }
+ else if (!compare_parameter (f->sym, a->expr,
+ ranks_must_agree || rank_check, is_elemental))
{
if (where)
gfc_error ("Type/rank mismatch in argument '%s' at %L",
@@ -1394,34 +1557,42 @@ compare_actual_formal (gfc_actual_arglis
return 0;
}
- if (a->expr->ts.type == BT_CHARACTER
+ 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)
{
- if (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) < 0)
- {
- if (where)
- gfc_error ("Character length of actual argument shorter "
- "than of dummy argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 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_error ("Character length mismatch between actual argument "
- "and pointer or allocatable dummy argument "
- "'%s' at %L", f->sym->name, &a->expr->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;
}
}
+ actual_size = get_expr_storage_size(a->expr);
+ formal_size = get_sym_storage_size(f->sym);
+ if (actual_size != 0 && actual_size < formal_size)
+ {
+ if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
+ gfc_warning ("Character length of actual argument shorter "
+ "than of dummy argument '%s' (%d/%d) at %L",
+ f->sym->name, (int) actual_size,
+ (int) formal_size, &a->expr->where);
+ else if (where)
+ gfc_warning ("Actual argument contains too few "
+ "elements for dummy argument '%s' (%d/%d) at %L",
+ f->sym->name, (int) actual_size,
+ (int) formal_size, &a->expr->where);
+ return 0;
+ }
+
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE
Index: gcc/testsuite/gfortran.dg/argument_checking_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_1.f90 (revision 0)
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! PR fortran/30940
+program main
+ implicit none
+ character(len=10) :: digit_string = '123456789', str
+ character :: digit_arr(10)
+ call copy(digit_string, digit_arr)
+ call copy(digit_arr,str)
+ if(str /= '123456789') call abort()
+ digit_string = 'qwertasdf'
+ call copy2(digit_string, digit_arr)
+ call copy2(digit_arr,str)
+ if(str /= 'qwertasdf') call abort()
+ digit_string = '1qayxsw23e'
+ call copy3("1qayxsw23e", digit_arr)
+ call copy3(digit_arr,str)
+ if(str /= '1qayxsw23e') call abort()
+contains
+ subroutine copy(in, out)
+ character, dimension(*) :: in
+ character, dimension(10) :: out
+ out = in(:10)
+ end subroutine copy
+ subroutine copy2(in, out)
+ character, dimension(2,*) :: in
+ character, dimension(2,5) :: out
+ out(1:2,1:5) = in(1:2,1:5)
+ end subroutine copy2
+ subroutine copy3(in, out)
+ character(len=2), dimension(5) :: in
+ character(len=2), dimension(5) :: out
+ out = in
+ end subroutine copy3
+end program main
Index: gcc/testsuite/gfortran.dg/argument_checking_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_2.f90 (revision 0)
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/30940
+program main
+ implicit none
+ character(len=10) :: digit_string = '123456789', str
+ character :: digit_arr(10)
+ call copy(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+ call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+ if(str /= '123456789') call abort()
+ digit_string = 'qwertasdf'
+ call copy2(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+ call copy2(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+ if(str /= 'qwertasdf') call abort()
+ digit_string = '1qayxsw23e'
+ call copy('1qayxsw23e', digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" }
+ call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" }
+ if(str /= '1qayxsw23e') call abort()
+contains
+ subroutine copy(in, out)
+ character, dimension(*) :: in
+ character, dimension(10) :: out
+ out = in(:10)
+ end subroutine copy
+ subroutine copy2(in, out)
+ character, dimension(2,*) :: in
+ character, dimension(2,5) :: out
+ out(1:2,1:5) = in(1:2,1:5)
+ end subroutine copy2
+end program main
Index: gcc/testsuite/gfortran.dg/argument_checking_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_3.f90 (revision 0)
@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+ subroutine foo(a)
+ character(len=1),dimension(:) :: a
+ end subroutine foo
+ subroutine bar(a)
+ character(len=1),dimension(:,:) :: a
+ end subroutine bar
+ subroutine foobar(a)
+ character(len=1),dimension(4) :: a
+ end subroutine foobar
+ subroutine arr(a)
+ character(len=1),dimension(1,2,1,2) :: a
+ end subroutine arr
+end interface
+ character(len=2) :: len2
+ character(len=4) :: len4
+ len2 = '12'
+ len4 = '1234'
+
+ call foo(len2) ! { dg-warning "Type/rank mismatch in argument" }
+ call foo("ca") ! { dg-warning "Type/rank mismatch in argument" }
+ call bar("ca") ! { dg-warning "Type/rank mismatch in argument" }
+ call foobar(len2) ! { dg-warning "contains too few elements" }
+ call foobar(len4)
+ call foobar("bar") ! { dg-warning "contains too few elements" }
+ call foobar("bar33")
+ call arr(len2) ! { dg-warning "contains too few elements" }
+ call arr(len4)
+ call arr("bar") ! { dg-warning "contains too few elements" }
+ call arr("bar33")
+end program test
Index: gcc/testsuite/gfortran.dg/argument_checking_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_4.f90 (revision 0)
@@ -0,0 +1,21 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+ subroutine foobar(a)
+ character(len=1),dimension(4) :: a
+ end subroutine foobar
+ subroutine arr(a)
+ character(len=1),dimension(1,2,1,2) :: a
+ end subroutine arr
+end interface
+
+ call foobar( [ "bar" ]) ! { dg-warning "contains too few elements" }
+ call foobar( ["ba ","r33"])
+ call arr( [ "bar" ]) ! { dg-warning "contains too few elements" }
+ call arr( reshape(["b","a","r","3"], [2,2]))
+ call arr( reshape(["b","a"], [1,2])) ! { dg-warning "contains too few elements" }
+ call arr( reshape(["b","a"], [2,1])) ! { dg-warning "contains too few elements" }
+end program test
Index: gcc/testsuite/gfortran.dg/argument_checking_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/argument_checking_5.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/argument_checking_5.f90 (revision 0)
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! PR fortran/30940
+program test
+implicit none
+interface
+ subroutine foobar(x)
+ integer,dimension(4) :: x
+ end subroutine foobar
+ subroutine arr(y)
+ integer,dimension(1,2,1,2) :: y
+ end subroutine arr
+end interface
+
+integer a(3), b(5)
+call foobar(a) ! { dg-warning "contains too few elements" }
+call foobar(b)
+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(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call foobar(reshape(b(2:5),[2,2]))
+
+call arr(a) ! { dg-warning "contains too few elements" }
+call arr(b)
+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(reshape(a(1:3),[2,1])) ! { dg-warning "contains too few elements" }
+call arr(reshape(b(2:5),[2,2]))
+end program test
Index: gcc/testsuite/gfortran.dg/char_length_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/char_length_3.f90 (revision 126114)
+++ gcc/testsuite/gfortran.dg/char_length_3.f90 (working copy)
@@ -14,25 +14,25 @@
character(len=10), allocatable :: alloc1(:)
character(len=20), allocatable :: alloc2(:)
character(len=30), allocatable :: alloc3(:)
- call foo(v) ! { dg-error "actual argument shorter than of dummy" }
- call foo(x) ! { dg-error "actual argument shorter than of dummy" }
+ call foo(v) ! { dg-warning "actual argument shorter than of dummy" }
+ call foo(x) ! { dg-warning "actual argument shorter than of dummy" }
call foo(y)
call foo(z)
ptr1 => x
- call foo(ptr1) ! { dg-error "actual argument shorter than of dummy" }
- call bar(ptr1) ! { dg-error "actual argument shorter than of dummy" }
+ call foo(ptr1) ! { dg-warning "actual argument shorter than of dummy" }
+ call bar(ptr1) ! { dg-warning "Character length mismatch" }
ptr2 => y
call foo(ptr2)
call bar(ptr2)
ptr3 => z
call foo(ptr3)
- call bar(ptr3) ! { dg-error "Character length mismatch" }
+ call bar(ptr3) ! { dg-warning "Character length mismatch" }
allocate(alloc1(1))
allocate(alloc2(1))
allocate(alloc3(1))
- call arr(alloc1) ! { dg-error "actual argument shorter than of dummy" }
+ call arr(alloc1) ! { dg-warning "Character length mismatch" }
call arr(alloc2)
- call arr(alloc3) ! { dg-error "Character length mismatch" }
+ call arr(alloc3) ! { dg-warning "Character length mismatch" }
contains
subroutine foo(y)
character(len=20) :: y
Index: gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90
===================================================================
--- gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 (revision 126114)
+++ gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 (working copy)
@@ -8,7 +8,7 @@ program st_function_1
bar(p) = p // "World"
! Expression longer than function, actual arg shorter than dummy.
- call check (foo("Hello"), "Hello Wo")
+ call check (foo("Hello"), "Hello Wo") ! { dg-warning "Character length of actual argument shorter" }
! Expression shorter than function, actual arg longer than dummy.
! Result shorter than type
Index: gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90
===================================================================
--- gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 (revision 126114)
+++ gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 (working copy)
@@ -33,7 +33,7 @@ contains
st5 (s1, s2) = s1 // s2
if (st4 (1, 4) .ne. "0123" ) call abort
- if (st5 ("01", "02") .ne. "01 02 ") call abort
+ if (st5 ("01", "02") .ne. "01 02 ") call abort ! { dg-warning "Character length of actual argument shorter" }
end subroutine
subroutine with_derived_type_dummy