check.c (gfc_check_cshift,gfc_check_eoshift,gfc_check_unpack): Add rank checks for...

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.

From-SVN: r137983

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 87279c4..6077028 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
        * gfortran.h (new): Remove macro.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c0f9891..4132d83 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -876,11 +876,16 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
       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_expr *shift, gfc_expr *boundary,
       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_expr *mask, gfc_expr *field)
   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;
 }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 338edcd..105edc4 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.
+
 2008-07-18  Kris Van Hees  <kris.van.hees@oracle.com>
 
        * g++.dg/ext/utf-array.C: Fix broken merge/checkin.

diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
new file mode 100644 (file)
index 0000000..44a4b39
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
index 224b2c0..5461fb1 100644 (file)
--- a/gcc/testsuite/gfortran.dg/zero_sized_1.f90
+++ b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
@@ -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