diff options
-rw-r--r-- | gcc/fortran/ChangeLog | 8 | ||||
-rw-r--r-- | gcc/fortran/interface.c | 203 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 11 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/argument_checking_1.f90 | 35 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/argument_checking_2.f90 | 31 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/argument_checking_3.f90 | 36 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/argument_checking_4.f90 | 21 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/argument_checking_5.f90 | 35 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/char_length_3.f90 | 14 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 | 2 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 | 2 |
11 files changed, 373 insertions, 25 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1ee1862..1bd7a50 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2007-07-03 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-07-03 Janne Blomqvist <jb@gcc.gnu.org> * trans-decl.c (gfc_build_builtin_function_decls): Mark diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 69ab326..5586494 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1283,6 +1283,153 @@ compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual) } +/* 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. */ @@ -1321,6 +1468,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_formal_arglist *f; int i, n, na; bool rank_check; + unsigned long actual_size, formal_size; actual = *ap; @@ -1404,8 +1552,23 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && (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", @@ -1413,34 +1576,42 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, 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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 92a17bc..934a38b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2007-07-03 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. + 2007-07-03 Uros Bizjak <ubizjak@gmail.com> * gcc.dg/pr32176.c: Add -w to default dg-options. diff --git a/gcc/testsuite/gfortran.dg/argument_checking_1.f90 b/gcc/testsuite/gfortran.dg/argument_checking_1.f90 new file mode 100644 index 0000000..b42047a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_2.f90 b/gcc/testsuite/gfortran.dg/argument_checking_2.f90 new file mode 100644 index 0000000..ba1dd63 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_3.f90 b/gcc/testsuite/gfortran.dg/argument_checking_3.f90 new file mode 100644 index 0000000..e59a039 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_4.f90 b/gcc/testsuite/gfortran.dg/argument_checking_4.f90 new file mode 100644 index 0000000..a2a56e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_5.f90 b/gcc/testsuite/gfortran.dg/argument_checking_5.f90 new file mode 100644 index 0000000..35a80a0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90 index cee55f6..97f7fb4 100644 --- a/gcc/testsuite/gfortran.dg/char_length_3.f90 +++ b/gcc/testsuite/gfortran.dg/char_length_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 index 8bde9b2..e878802 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 index 0387a5f..b851a94 100644 --- a/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 +++ b/gcc/testsuite/gfortran.fortran-torture/execute/st_function_1.f90 @@ -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 |