From: Tobias Burnus Date: Wed, 16 Jan 2008 07:12:00 +0000 (+0100) Subject: re PR fortran/34796 (Too strict error checking for assumed-shaped array) X-Git-Tag: releases/gcc-4.3.0~596 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=6da0839af39d0d319e12dec89c1668549220799b;p=thirdparty%2Fgcc.git re PR fortran/34796 (Too strict error checking for assumed-shaped array) 2008-01-16 Tobias Burnus PR fortran/34796 * interface.c (compare_parameter): Allow AS_DEFERRED array elements and reject attr.pointer array elemenents. (get_expr_storage_size): Return storage size of elements of assumed-shape and pointer arrays. 2008-01-16 Tobias Burnus PR fortran/34796 * gfortran.dg/argument_checking_13.f90: New. * gfortran.dg/argument_checking_14.f90: New. From-SVN: r131566 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ad5d2c8f225d..35944a27b332 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2008-01-16 Tobias Burnus + + PR fortran/34796 + * interface.c (compare_parameter): Allow AS_DEFERRED array + elements and reject attr.pointer array elemenents. + (get_expr_storage_size): Return storage size of elements of + assumed-shape and pointer arrays. + 2008-01-15 Sebastian Pop * f95-lang.c (gfc_init_builtin_functions): Initialize GOMP builtins diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9057ef932855..e0e3ff61f341 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1520,7 +1520,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && (ref == NULL || (actual->expr_type == EXPR_VARIABLE && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE - || actual->symtree->n.sym->as->type == AS_DEFERRED)))) + || actual->symtree->n.sym->attr.pointer)))) { if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) { @@ -1546,7 +1546,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (actual->expr_type == EXPR_VARIABLE && actual->symtree->n.sym->as && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE - || actual->symtree->n.sym->as->type == AS_DEFERRED)) + || actual->symtree->n.sym->attr.pointer)) { if (where) gfc_error ("Element of assumed-shaped array passed to dummy " @@ -1638,6 +1638,7 @@ get_expr_storage_size (gfc_expr *e) { int i; long int strlen, elements; + long int substrlen = 0; gfc_ref *ref; if (e == NULL) @@ -1672,6 +1673,16 @@ get_expr_storage_size (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) { + 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; + continue; + } + 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) @@ -1729,13 +1740,21 @@ get_expr_storage_size (gfc_expr *e) else 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; else /* TODO: Determine the number of remaining elements in the element - sequence for array element designators. + 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; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d0c52a2783f1..7a2d834e6417 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2008-01-16 Tobias Burnus + + PR fortran/34796 + * gfortran.dg/argument_checking_13.f90: New. + * gfortran.dg/argument_checking_14.f90: New. + 2008-01-15 Thomas Koenig PR libfortran/34671 diff --git a/gcc/testsuite/gfortran.dg/argument_checking_13.f90 b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 new file mode 100644 index 000000000000..ae3fd22b443f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_13.f90 @@ -0,0 +1,83 @@ +! { dg-do compile } +! +! PR fortran/34796 +! +! Argument checks: +! - elements of deferred-shape arrays (= non-dummies) are allowed +! as the memory is contiguous +! - while assumed-shape arrays (= dummy arguments) and pointers are +! not (strides can make them non-contiguous) +! and +! - if the memory is non-contigous, character arguments have as +! storage size only the size of the element itself, check for +! too short actual arguments. +! +subroutine test1(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv1(y) + real :: y(3) + end subroutine rlv1 +end interface + +real :: assumed_sh_dummy(:,:,:) +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" } +end + +subroutine test2(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv2(y) + character :: y(3) + end subroutine rlv2 +end interface + +character(3) :: assumed_sh_dummy(:,:,:) +character(3), pointer :: pointer_dummy(:,:,:) + +character(3), allocatable :: deferred(:,:,:) +character(3), pointer :: ptr(:,:,:) +call rlv2(deferred(1,1,1)) ! Valid since contiguous +call rlv2(ptr(1,1,1)) ! Valid F2003 +call rlv2(assumed_sh_dummy(1,1,1)) ! Valid F2003 +call rlv2(pointer_dummy(1,1,1)) ! Valid F2003 + +! The following is kind of ok: The memory access it valid +! We warn nonetheless as the result is not what is intented +! and also formally wrong. +! Using (1:string_length) would be ok. +call rlv2(ptr(1,1,1)(1:1)) ! { dg-warning "contains too few elements" } +call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-warning "contains too few elements" } +call rlv2(pointer_dummy(1,1,1)(1:3)) ! Valid F2003 +end + +subroutine test3(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv3(y) + character :: y(3) + end subroutine rlv3 +end interface + +character(2) :: assumed_sh_dummy(:,:,:) +character(2), pointer :: pointer_dummy(:,:,:) + +character(2), allocatable :: deferred(:,:,:) +character(2), pointer :: ptr(:,:,:) +call rlv3(deferred(1,1,1)) ! Valid since contiguous +call rlv3(ptr(1,1,1)) ! { dg-warning "contains too few elements" } +call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-warning "contains too few elements" } +call rlv3(pointer_dummy(1,1,1)) ! { dg-warning "contains too few elements" } + +call rlv3(deferred(1,1,1)(1:2)) ! Valid since contiguous +call rlv3(ptr(1,1,1)(1:2)) ! { dg-warning "contains too few elements" } +call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-warning "contains too few elements" } +call rlv3(pointer_dummy(1,1,1)(1:2)) ! { dg-warning "contains too few elements" } +end diff --git a/gcc/testsuite/gfortran.dg/argument_checking_14.f90 b/gcc/testsuite/gfortran.dg/argument_checking_14.f90 new file mode 100644 index 000000000000..4c32b253a5e1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_14.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/34796 +! +! This checks for Fortran 2003 extensions. +! +! Argument checks: +! - elements of deferred-shape arrays (= non-dummies) are allowed +! as the memory is contiguous +! - while assumed-shape arrays (= dummy arguments) and pointers are +! not (strides can make them non-contiguous) +! and +! - if the memory is non-contigous, character arguments have as +! storage size only the size of the element itself, check for +! too short actual arguments. +! +subroutine test2(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv2(y) + character :: y(3) + end subroutine rlv2 +end interface + +character(3) :: assumed_sh_dummy(:,:,:) +character(3), pointer :: pointer_dummy(:,:,:) + +character(3), allocatable :: deferred(:,:,:) +character(3), pointer :: ptr(:,:,:) +call rlv2(deferred(1,1,1)) ! Valid since contiguous +call rlv2(ptr(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(assumed_sh_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(pointer_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } + +! The following is kind of ok: The memory access it valid +! We warn nonetheless as the result is not what is intented +! and also formally wrong. +! Using (1:string_length) would be ok. +call rlv2(deferred(1,1,1)(1:3)) ! OK +call rlv2(ptr(1,1,1)(1:1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(pointer_dummy(1,1,1)(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +end + +subroutine test3(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv3(y) + character :: y(2) + end subroutine rlv3 +end interface + +character(2) :: assumed_sh_dummy(:,:,:) +character(2), pointer :: pointer_dummy(:,:,:) + +character(2), allocatable :: deferred(:,:,:) +character(2), pointer :: ptr(:,:,:) +call rlv3(deferred(1,1,1)) ! Valid since contiguous +call rlv3(ptr(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(pointer_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } + +call rlv3(deferred(1,1,1)(1:2)) ! Valid since contiguous +call rlv3(ptr(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(pointer_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +end