2009-06-07 Daniel Franke <franke.daniel@gmail.com>

        * check.c (dim_rank_check): Return SUCCESS if DIM=NULL.
        (gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
        (gfc_check_minloc_maxloc): Likewise.
        (check_reduction): Likewise.
        (gfc_check_size): Likewise.
        (gfc_check_ubound): Likewise.
        (gfc_check_cshift): Added missing shape-conformance checks.
        (gfc_check_eoshift): Likewise.
        * gfortran.h (gfc_check_conformance): Modified prototype to printf-style.
        * expr.c (gfc_check_conformance): Accept error-message chunks in
        printf-style. Changed all callers.

2009-06-07  Daniel Franke  <franke.daniel@gmail.com>

        PR fortran/36874
        * gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted error message.
        * gfortran.dg/zero_sized_1.f90: Removed checks with incompatible shapes.
        * gfortran.dg/zero_sized_5.f90: Likewise.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148247 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d101c8b..be97669 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,20 @@
 2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
 
+       * check.c (dim_rank_check): Return SUCCESS if DIM=NULL.
+       (gfc_check_lbound): Removed (now) redundant check for DIM=NULL.
+       (gfc_check_minloc_maxloc): Likewise.
+       (check_reduction): Likewise.
+       (gfc_check_size): Likewise.
+       (gfc_check_ubound): Likewise.
+       (gfc_check_cshift): Added missing shape-conformance checks.
+       (gfc_check_eoshift): Likewise.
+       * gfortran.h (gfc_check_conformance): Modified prototype to printf-style.
+       * expr.c (gfc_check_conformance): Accept error-message chunks in 
+       printf-style. Changed all callers.
+
+
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
        PR fortran/25104
        PR fortran/29962
        * intrinsic.h (gfc_simplify_dot_product): New prototype.

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index 17f2221..070e2bf 100644 (file)
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1561,7 +1561,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
   rc = ARITH_OK;
   d = op2->value.constructor;
 
-  if (gfc_check_conformance ("elemental binary operation", op1, op2)
+  if (gfc_check_conformance (op1, op2, "elemental binary operation")
       != SUCCESS)
     rc = ARITH_INCOMMENSURATE;
   else

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index b61909b..eaab309 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -339,6 +339,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed)
   gfc_array_ref *ar;
   int rank;
 
+  if (dim == NULL)
+    return SUCCESS;
+
   if (dim->expr_type != EXPR_CONSTANT
       || (array->expr_type != EXPR_VARIABLE
          && array->expr_type != EXPR_ARRAY))
@@ -876,24 +879,56 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (array->rank == 1)
+  if (dim_check (dim, 2, true) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, array, false) == FAILURE)
+    return FAILURE;
+
+  if (array->rank == 1 || shift->rank == 0)
     {
       if (scalar_check (shift, 1) == FAILURE)
        return FAILURE;
     }
-  else if (shift->rank != array->rank - 1 && shift->rank != 0)
+  else if (shift->rank == array->rank - 1)
     {
-      gfc_error ("SHIFT argument at %L of CSHIFT must have rank %d or be a "
-                "scalar", &shift->where, array->rank - 1);
+      int d;
+      if (!dim)
+       d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+       gfc_extract_int (dim, &d);
+      else
+       d = -1;
+
+      if (d > 0)
+       {
+         int i, j;
+         for (i = 0, j = 0; i < array->rank; i++)
+           if (i != d - 1)
+             {
+               if (!identical_dimen_shape (array, i, shift, j))
+                 {
+                   gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+                              "invalid shape in dimension %d (%ld/%ld)",
+                              gfc_current_intrinsic_arg[1],
+                              gfc_current_intrinsic, &shift->where, i + 1,
+                              mpz_get_si (array->shape[i]),
+                              mpz_get_si (shift->shape[j]));
+                   return FAILURE;
+                 }
+
+               j += 1;
+             }
+       }
+    }
+  else
+    {
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+                "%d or be a scalar", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &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;
-
   return SUCCESS;
 }
 
@@ -1042,55 +1077,85 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   if (type_check (shift, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (array->rank == 1)
+  if (dim_check (dim, 3, true) == FAILURE)
+    return FAILURE;
+
+  if (dim_rank_check (dim, array, false) == FAILURE)
+    return FAILURE;
+
+  if (array->rank == 1 || shift->rank == 0)
     {
-      if (scalar_check (shift, 2) == FAILURE)
+      if (scalar_check (shift, 1) == FAILURE)
        return FAILURE;
     }
-  else if (shift->rank != array->rank - 1 && shift->rank != 0)
+  else if (shift->rank == array->rank - 1)
     {
-      gfc_error ("SHIFT argument at %L of EOSHIFT must have rank %d or be a "
-                "scalar", &shift->where, array->rank - 1);
+      int d;
+      if (!dim)
+       d = 1;
+      else if (dim->expr_type == EXPR_CONSTANT)
+       gfc_extract_int (dim, &d);
+      else
+       d = -1;
+
+      if (d > 0)
+       {
+         int i, j;
+         for (i = 0, j = 0; i < array->rank; i++)
+           if (i != d - 1)
+             {
+               if (!identical_dimen_shape (array, i, shift, j))
+                 {
+                   gfc_error ("'%s' argument of '%s' intrinsic at %L has "
+                              "invalid shape in dimension %d (%ld/%ld)",
+                              gfc_current_intrinsic_arg[1],
+                              gfc_current_intrinsic, &shift->where, i + 1,
+                              mpz_get_si (array->shape[i]),
+                              mpz_get_si (shift->shape[j]));
+                   return FAILURE;
+                 }
+
+               j += 1;
+             }
+       }
+    }
+  else
+    {
+      gfc_error ("'%s' argument of intrinsic '%s' at %L of must have rank "
+                "%d or be a scalar", gfc_current_intrinsic_arg[1],
+                gfc_current_intrinsic, &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;
 
-      if (array->rank == 1)
+      if (array->rank == 1 || boundary->rank == 0)
        {
          if (scalar_check (boundary, 2) == FAILURE)
            return FAILURE;
        }
-      else if (boundary->rank != array->rank - 1 && boundary->rank != 0)
+      else if (boundary->rank == array->rank - 1)
        {
-         gfc_error ("BOUNDARY argument at %L of EOSHIFT must have rank %d or be "
-                    "a scalar", &boundary->where, array->rank - 1);
-         return FAILURE;
+         if (gfc_check_conformance (shift, boundary,
+                                    "arguments '%s' and '%s' for "
+                                    "intrinsic %s",
+                                    gfc_current_intrinsic_arg[1],
+                                    gfc_current_intrinsic_arg[2],
+                                    gfc_current_intrinsic ) == FAILURE)
+           return FAILURE;
        }
-
-      if (shift->rank == boundary->rank)
+      else
        {
-         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;
-             }
+         gfc_error ("'%s' argument of intrinsic '%s' at %L of must have "
+                    "rank %d or be a scalar", gfc_current_intrinsic_arg[1],
+                    gfc_current_intrinsic, &shift->where, array->rank - 1);
+         return FAILURE;
        }
     }
 
-  if (dim_check (dim, 4, true) == FAILURE)
-    return FAILURE;
-
   return SUCCESS;
 }
 
@@ -1512,14 +1577,11 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, false) == FAILURE)
-       return FAILURE;
+  if (dim_check (dim, 1, false) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 1) == FAILURE)
-       return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 1) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -1719,13 +1781,11 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist)
        }
 
       for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++)
-        {
-         char buffer[80];
-         snprintf (buffer, 80, "arguments 'a%d' and 'a%d' for intrinsic '%s'",
-                   m, n, gfc_current_intrinsic);
-         if (gfc_check_conformance (buffer, tmp->expr, x) == FAILURE)
+       if (gfc_check_conformance (tmp->expr, x,
+                                  "arguments 'a%d' and 'a%d' for "
+                                  "intrinsic '%s'", m, n,
+                                  gfc_current_intrinsic) == FAILURE)
            return FAILURE;
-       }
     }
 
   return SUCCESS;
@@ -1905,24 +1965,22 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (d && dim_check (d, 1, false) == FAILURE)
+  if (dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
-  if (d && dim_rank_check (d, a, 0) == FAILURE)
+  if (dim_rank_check (d, a, 0) == FAILURE)
     return FAILURE;
 
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  if (m != NULL)
-    {
-      char buffer[80];
-      snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
-               gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
-               gfc_current_intrinsic);
-      if (gfc_check_conformance (buffer, a, m) == FAILURE)
-       return FAILURE;
-    }
+  if (m != NULL
+      && gfc_check_conformance (a, m,
+                               "arguments '%s' and '%s' for intrinsic %s",
+                               gfc_current_intrinsic_arg[0],
+                               gfc_current_intrinsic_arg[2],
+                               gfc_current_intrinsic ) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -1961,24 +2019,22 @@ check_reduction (gfc_actual_arglist *ap)
       ap->next->next->expr = m;
     }
 
-  if (d && dim_check (d, 1, false) == FAILURE)
+  if (dim_check (d, 1, false) == FAILURE)
     return FAILURE;
 
-  if (d && dim_rank_check (d, a, 0) == FAILURE)
+  if (dim_rank_check (d, a, 0) == FAILURE)
     return FAILURE;
 
   if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  if (m != NULL)
-    {
-      char buffer[80];
-      snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic %s",
-               gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
-               gfc_current_intrinsic);
-      if (gfc_check_conformance (buffer, a, m) == FAILURE)
-       return FAILURE;
-    }
+  if (m != NULL
+      && gfc_check_conformance (a, m,
+                               "arguments '%s' and '%s' for intrinsic %s",
+                               gfc_current_intrinsic_arg[0],
+                               gfc_current_intrinsic_arg[2],
+                               gfc_current_intrinsic) == FAILURE)
+    return FAILURE;
 
   return SUCCESS;
 }
@@ -2133,18 +2189,17 @@ gfc_check_null (gfc_expr *mold)
 gfc_try
 gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
 {
-  char buffer[80];
-
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
   if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
     return FAILURE;
 
-  snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
-           gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
-           gfc_current_intrinsic);
-  if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+  if (gfc_check_conformance (array, mask,
+                            "arguments '%s' and '%s' for intrinsic '%s'",
+                            gfc_current_intrinsic_arg[0],
+                            gfc_current_intrinsic_arg[1],
+                            gfc_current_intrinsic) == FAILURE)
     return FAILURE;
 
   if (vector != NULL)
@@ -2700,14 +2755,11 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, true) == FAILURE)
-       return FAILURE;
+  if (dim_check (dim, 1, true) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 0) == FAILURE)
-       return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 0) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
@@ -3043,14 +3095,11 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (array_check (array, 0) == FAILURE)
     return FAILURE;
 
-  if (dim != NULL)
-    {
-      if (dim_check (dim, 1, false) == FAILURE)
-       return FAILURE;
+  if (dim_check (dim, 1, false) == FAILURE)
+    return FAILURE;
 
-      if (dim_rank_check (dim, array, 0) == FAILURE)
-       return FAILURE;
-    }
+  if (dim_rank_check (dim, array, 0) == FAILURE)
+    return FAILURE;
 
   if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
     return FAILURE;

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 31b0df1..71acbd6 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2776,18 +2776,25 @@ gfc_specification_expr (gfc_expr *e)
 /* Given two expressions, make sure that the arrays are conformable.  */
 
 gfc_try
-gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
+gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
 {
   int op1_flag, op2_flag, d;
   mpz_t op1_size, op2_size;
   gfc_try t;
 
+  va_list argp;
+  char buffer[240];
+
   if (op1->rank == 0 || op2->rank == 0)
     return SUCCESS;
 
+  va_start (argp, optype_msgid);
+  vsnprintf (buffer, 240, optype_msgid, argp);
+  va_end (argp);
+
   if (op1->rank != op2->rank)
     {
-      gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
+      gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
                 op1->rank, op2->rank, &op1->where);
       return FAILURE;
     }
@@ -2802,7 +2809,7 @@ gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
        {
          gfc_error ("Different shape for %s at %L on dimension %d "
-                    "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
+                    "(%d and %d)", _(buffer), &op1->where, d + 1,
                     (int) mpz_get_si (op1_size),
                     (int) mpz_get_si (op2_size));
 
@@ -2950,7 +2957,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 
   /* Check size of array assignments.  */
   if (lvalue->rank != 0 && rvalue->rank != 0
-      && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
+      && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
     return FAILURE;
 
   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 82f07ef..9027904 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2484,7 +2484,7 @@ gfc_try gfc_specification_expr (gfc_expr *);
 int gfc_numeric_ts (gfc_typespec *);
 int gfc_kind_max (gfc_expr *, gfc_expr *);
 
-gfc_try gfc_check_conformance (const char *, gfc_expr *, gfc_expr *);
+gfc_try gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
 gfc_try gfc_check_assign (gfc_expr *, gfc_expr *, int);
 gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 6088a8d..c519f6e 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -3617,14 +3617,13 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
       first_expr = arg->expr;
 
       for ( ; arg && arg->expr; arg = arg->next, n++)
-       {
-          char buffer[80];
-         snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
-                   gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n],
-                   gfc_current_intrinsic);
-         if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE)
-           return FAILURE;
-       }
+       if (gfc_check_conformance (first_expr, arg->expr,
+                                  "arguments '%s' and '%s' for "
+                                  "intrinsic '%s'",
+                                  gfc_current_intrinsic_arg[0],
+                                  gfc_current_intrinsic_arg[n],
+                                  gfc_current_intrinsic) == FAILURE)
+         return FAILURE;
     }
 
   if (t == FAILURE)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8158b71..5bb38fe 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1584,8 +1584,8 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
       /* Elemental procedure's array actual arguments must conform.  */
       if (e != NULL)
        {
-         if (gfc_check_conformance ("elemental procedure", arg->expr, e)
-             == FAILURE)
+         if (gfc_check_conformance (arg->expr, e,
+                                    "elemental procedure") == FAILURE)
            return FAILURE;
        }
       else

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 050a6fe..4b9ac1c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2009-06-07  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/36874
+       * gfortran.dg/intrinsic_argument_conformance_2.f90: Adjusted error message.
+       * gfortran.dg/zero_sized_1.f90: Removed checks with incompatible shapes.
+       * gfortran.dg/zero_sized_5.f90: Likewise.
+
 2009-06-07  H.J. Lu  <hongjiu.lu@intel.com>
 
        PR middle-end/32950

diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
index 44a4b39..c928460 100644 (file)
--- a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
+++ b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_2.f90
@@ -34,7 +34,7 @@ program main
   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" }
+  b = eoshift (a,(/1/), boundary=c(1,:)) ! { dg-error "invalid shape in dimension" }
 
   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" }

diff --git a/gcc/testsuite/gfortran.dg/zero_sized_1.f90 b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
index 5461fb1..85167fc 100644 (file)
--- a/gcc/testsuite/gfortran.dg/zero_sized_1.f90
+++ b/gcc/testsuite/gfortran.dg/zero_sized_1.f90
@@ -15,9 +15,6 @@ subroutine test_cshift
   if (any(cshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
   if (any(cshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
   if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
-  if (any(cshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
-  if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
-  if (any(cshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 0)) call abort
   deallocate(foo,bar,gee)
 end
 
@@ -34,9 +31,6 @@ subroutine test_eoshift
   if (any(eoshift(gee,shift=(/1,-1/),dim=1)/= 0)) call abort
   if (any(eoshift(gee,shift=(/1,-1/),dim=2)/= 0)) call abort
   if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1)/= 0)) call abort
-  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2)/= 0)) call abort
-  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1)/= 0)) call abort
-  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2)/= 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=42.0)/= 0)) call abort
@@ -45,9 +39,6 @@ subroutine test_eoshift
   if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=42.0)/= 0)) call abort
   if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=42.0)/= 0)) call abort
   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(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)/= 0)) call abort
   if (any(eoshift(tempn(2:1),dim=1,shift=1,boundary=-7.0)/= 0)) call abort
@@ -56,9 +47,6 @@ subroutine test_eoshift
   if (any(eoshift(gee,shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
   if (any(eoshift(gee,shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
   if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
-  if (any(eoshift(tempm(5:4,:),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
-  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=1,boundary=(/42.0,-7.0/))/= 0)) call abort
-  if (any(eoshift(tempm(:,5:4),shift=(/1,-1/),dim=2,boundary=(/42.0,-7.0/))/= 0)) call abort
   deallocate(foo,bar,gee)
 end
 

diff --git a/gcc/testsuite/gfortran.dg/zero_sized_5.f90 b/gcc/testsuite/gfortran.dg/zero_sized_5.f90
index 30ca8bf..49a5d54 100644 (file)
--- a/gcc/testsuite/gfortran.dg/zero_sized_5.f90
+++ b/gcc/testsuite/gfortran.dg/zero_sized_5.f90
@@ -8,8 +8,6 @@ program main
   b = cshift (a,1)
   b = cshift (a,j)
   b = eoshift (a,1)
-  b = eoshift (a,(/1/))
   b = eoshift (a,1,boundary=c(1,:))
   b = eoshift (a, j, boundary=c(1,:))
-
 end program main