Re: [patch, Fortran] Add rank checks for EOSHIFT and CSHIFT

[Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>]

On Sat, Jul 19, 2008 at 12:22:51AM +0200, Tobias Burnus wrote:
> This adds the missing rank checks for EOSHIFT and CSHIFT, which I mentioned in
> http://gcc.gnu.org/ml/fortran/2008-07/msg00116.html

Updated patch: It now also contains rank/shape checks for UNPACK plus
more EOSHIFT checks.

Build and make check-gfortran + check in libgomp on x86-64-linux without
any failure.  OK for the trunk?

Tobias

2008-07-19  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank
        checks for cshift's shift and eoshift's shift and boundary args.
	(gfc_check_unpack): Add rank and shape tests for unpack.

2008-07-19  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/intrinsic_argument_conformance_2.f90: New.
	* gfortran.dg/zero_sized_1.f90: Fix conformance bugs.

Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(Revision 137975)
+++ gcc/fortran/check.c	(Arbeitskopie)
@@ -876,11 +876,16 @@ gfc_check_cshift (gfc_expr *array, gfc_e
       if (scalar_check (shift, 1) == FAILURE)
 	return FAILURE;
     }
-  else
+  else if (shift->rank != array->rank - 1 && shift->rank != 0)
     {
-      /* TODO: more requirements on shift parameter.  */
+      gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a "
+		 "scalar", &shift->where, array->rank - 1);
+      return FAILURE;
     }
 
+  /* TODO: Add shape conformance check between array (w/o dimension dim)
+     and shift. */
+
   if (dim_check (dim, 2, true) == FAILURE)
     return FAILURE;
 
@@ -1037,17 +1042,45 @@ gfc_check_eoshift (gfc_expr *array, gfc_
       if (scalar_check (shift, 2) == FAILURE)
 	return FAILURE;
     }
-  else
+  else if (shift->rank != array->rank - 1 && shift->rank != 0)
     {
-      /* TODO: more weird restrictions on shift.  */
+      gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a "
+		 "scalar", &shift->where, array->rank - 1);
+      return FAILURE;
     }
 
+  /* TODO: Add shape conformance check between array (w/o dimension dim)
+     and shift. */
+
   if (boundary != NULL)
     {
       if (same_type_check (array, 0, boundary, 2) == FAILURE)
 	return FAILURE;
 
-      /* TODO: more restrictions on boundary.  */
+      if (array->rank == 1)
+	{
+	  if (scalar_check (boundary, 2) == FAILURE)
+	    return FAILURE;
+	}
+      else if (boundary->rank != array->rank - 1 && boundary->rank != 0)
+	{
+	  gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be "
+		     "a scalar", &boundary->where, array->rank - 1);
+	  return FAILURE;
+	}
+
+      if (shift->rank == boundary->rank)
+	{
+	  int i;
+	  for (i = 0; i < shift->rank; i++)
+	    if (! identical_dimen_shape (shift, i, boundary, i))
+	      {
+		gfc_error ("Different shape in dimension %d for SHIFT and "
+			   "BOUNDARY arguments of EOSHIFT at %L", shift->rank,
+			   &boundary->where);
+		return FAILURE;
+	      }
+	}
     }
 
   if (dim_check (dim, 4, true) == FAILURE)
@@ -2886,6 +2919,25 @@ gfc_check_unpack (gfc_expr *vector, gfc_
   if (same_type_check (vector, 0, field, 2) == FAILURE)
     return FAILURE;
 
+  if (mask->rank != field->rank && field->rank != 0)
+    {
+      gfc_error ("FIELD argument at %L of UNPACK must have the same rank as "
+		 "MASK or be a scalar", &field->where);
+      return FAILURE;
+    }
+
+  if (mask->rank == field->rank)
+    {
+      int i;
+      for (i = 0; i < field->rank; i++)
+	if (! identical_dimen_shape (mask, i, field, i))
+	{
+	  gfc_error ("Different shape in dimension %d for MASK and FIELD "
+		     "arguments of UNPACK at %L", mask->rank, &field->where);
+	  return FAILURE;
+	}
+    }
+
   return SUCCESS;
 }
 
Index: gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90	(Revision 0)
@@ -0,0 +1,44 @@
+! { dg-do compile }
+! Some CSHIFT, EOSHIFT and UNPACK conformance tests
+!
+program main
+  implicit none
+  real, dimension(1)   :: a1, b1, c1
+  real, dimension(1,1) :: a2, b2, c2
+  real, dimension(1,0) :: a, b, c
+  real :: tempn(1), tempv(5)
+  real,allocatable :: foo(:)
+  allocate(foo(0))
+  tempn = 2.0
+
+  a1 = 0
+  a2 = 0
+  c1 = 0
+  a2 = 0
+
+  b1 = cshift (a1,1)
+  b1 = cshift (a1,(/1/)) ! { dg-error "must be a scalar" }
+  b1 = eoshift (a1,1)
+  b2 = eoshift (a1,c1(1)) ! { dg-error "must be INTEGER" }
+  b1 = eoshift (a1,(/1/)) ! { dg-error "must be a scalar" }
+  b1 = eoshift (a1,1,boundary=c1) ! { dg-error "must be a scalar" }
+  b1 = eoshift (a1,(/1/), boundary=c2) ! { dg-error "must be a scalar" }
+
+  b2 = cshift (a2,1)
+  b2 = cshift (a2,(/1/))
+  b2 = cshift (a2,reshape([1],[1,1])) ! { dg-error "have rank 1 or be a scalar" }
+  b2 = eoshift (a2,1)
+  b2 = eoshift (a2,c1) ! { dg-error "must be INTEGER" }
+  b2 = eoshift (a2,(/1/))
+  b2 = eoshift (a2,reshape([1],[1,1]), boundary=c1) ! { dg-error "have rank 1 or be a scalar" }
+  b2 = eoshift (a2,1,boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" }
+  b2 = eoshift (a2,(/1/), boundary=c2(:,:)) ! { dg-error "have rank 1 or be a scalar" }
+
+  b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "Different shape in dimension 1" }
+
+  if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
+  if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort() ! { dg-error "must be a scalar" }
+
+  if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
+  if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort() ! { dg-error "Different shape" }
+end program main
Index: gcc/testsuite/gfortran.dg/zero_sized_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/zero_sized_1.f90	(Revision 137975)
+++ gcc/testsuite/gfortran.dg/zero_sized_1.f90	(Arbeitskopie)
@@ -49,8 +49,8 @@ subroutine test_eoshift
   if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
   if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
 
-  if (any(eoshift(foo,dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
-  if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=(/42.0,-7.0/))/= 0)) call abort
+  if (any(eoshift(foo,dim=1,shift=1,boundary=42.0)/= 0)) call abort
+  if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) call abort
   if (any(eoshift(bar,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
   if (any(eoshift(bar,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
   if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
@@ -159,15 +159,17 @@ end
 subroutine test_unpack
   integer :: tempn(1,5), tempv(5)
   integer,allocatable :: foo(:,:), bar(:)
+  integer :: zero
   tempn = 2 
   tempv = 5
+  zero = 0
   allocate(foo(0,1:7),bar(0:-1))
   if (any(unpack(tempv,tempv/=0,tempv) /= 5) .or. &
       size(unpack(tempv,tempv/=0,tempv)) /= 5) call abort
   if (any(unpack(tempv(1:0),tempv/=0,tempv) /= 5) .or. &
       size(unpack(tempv(1:0),tempv/=0,tempv)) /= 5) call abort
-  if (any(unpack(tempv,tempv(1:0)/=0,tempv) /= -47)) call abort
-  if (any(unpack(tempv(5:4),tempv(1:0)/=0,tempv) /= -47)) call abort
+  if (any(unpack(tempv,tempv(1:zero)/=0,tempv) /= -47)) call abort
+  if (any(unpack(tempv(5:4),tempv(1:zero)/=0,tempv) /= -47)) call abort
   if (any(unpack(bar,foo==foo,foo) /= -47)) call abort
   deallocate(foo,bar)
 end