re PR fortran/34796 (Too strict error checking for assumed-shaped array)

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

        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  <burnus@net-b.de>

        PR fortran/34796
        * gfortran.dg/argument_checking_13.f90: New.
        * gfortran.dg/argument_checking_14.f90: New.

From-SVN: r131566

gcc/fortran/ChangeLog

+2008-01-16  Tobias Burnus  <burnus@net-b.de>
+
+	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  <sebastian.pop@amd.com>
 
 	* f95-lang.c (gfc_init_builtin_functions): Initialize GOMP builtins

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;
 }
 

gcc/testsuite/ChangeLog

+2008-01-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34796
+	* gfortran.dg/argument_checking_13.f90: New.
+	* gfortran.dg/argument_checking_14.f90: New.
+
 2008-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
 	
 	PR libfortran/34671

gcc/testsuite/gfortran.dg/argument_checking_13.f90

+! { 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

gcc/testsuite/gfortran.dg/argument_checking_14.f90

+! { 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