simplify.c (gfc_simplify_shape): Bugfix.

2004-08-08  Victor Leikehman  <lei@il.ibm.com>

	* simplify.c (gfc_simplify_shape): Bugfix.
	* expr.c (gfc_copy_shape_excluding): New function.
	* gfortran.h (gfc_get_shape): Bugfix.
	(gfc_copy_shape_excluding): Added declaration.
	* iresolve.c (gfc_resolve_all, gfc_resolve_any, gfc_resolve_count,
	gfc_resolve_cshift, gfc_resolve_eoshift, gfc_resolve_lbound,
	gfc_resolve_ubound, gfc_resolve_transpose): Added compile
	time resolution of shape.

From-SVN: r85685

gcc/fortran/ChangeLog

+2004-08-08  Victor Leikehman  <lei@il.ibm.com>
+
+	* simplify.c (gfc_simplify_shape): Bugfix.
+	* expr.c (gfc_copy_shape_excluding): New function.
+	* gfortran.h (gfc_get_shape): Bugfix.
+	(gfc_copy_shape_excluding): Added declaration.
+	* iresolve.c (gfc_resolve_all, gfc_resolve_any, gfc_resolve_count,
+	gfc_resolve_cshift, gfc_resolve_eoshift, gfc_resolve_lbound,
+	gfc_resolve_ubound, gfc_resolve_transpose): Added compile
+	time resolution of shape.
+
 2004-08-06  Janne Blomqvist  <jblomqvi@cc.hut.fi>
 
 	* intrinsic.c (add_subroutines): Add getenv and

gcc/fortran/expr.c

@@ -330,6 +330,50 @@ gfc_copy_shape (mpz_t * shape, int rank)
 }
 
 
+/* Copy a shape array excluding dimension N, where N is an integer
+   constant expression.  Dimensions are numbered in fortran style --
+   starting with ONE.
+
+   So, if the original shape array contains R elements
+      { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
+   the result contains R-1 elements:
+      { s1 ... sN-1  sN+1    ...  sR-1}
+
+   If anything goes wrong -- N is not a constant, its value is out
+   of range -- or anything else, just returns NULL.
+*/
+
+mpz_t *
+gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
+{
+  mpz_t *new_shape, *s;
+  int i, n;
+
+  if (shape == NULL 
+      || rank <= 1
+      || dim == NULL
+      || dim->expr_type != EXPR_CONSTANT 
+      || dim->ts.type != BT_INTEGER)
+    return NULL;
+
+  n = mpz_get_si (dim->value.integer);
+  n--; /* Convert to zero based index */
+  if (n < 0 && n >= rank)
+    return NULL;
+
+  s = new_shape = gfc_get_shape (rank-1);
+
+  for (i = 0; i < rank; i++)
+    {
+      if (i == n)
+        continue;
+      mpz_init_set (*s, shape[i]);
+      s++;
+    }
+
+  return new_shape;
+}
+
 /* Given an expression pointer, return a copy of the expression.  This
    subroutine is recursive.  */
 

gcc/fortran/gfortran.h

@@ -989,7 +989,7 @@ typedef struct gfc_expr
 gfc_expr;
 
 
-#define gfc_get_shape(rank) ((mpz_t *) gfc_getmem(rank*sizeof(mpz_t)))
+#define gfc_get_shape(rank) ((mpz_t *) gfc_getmem((rank)*sizeof(mpz_t)))
 
 /* Structures for information associated with different kinds of
    numbers.  The first set of integer parameters define all there is
@@ -1584,6 +1584,7 @@ void gfc_replace_expr (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_int_expr (int);
 gfc_expr *gfc_logical_expr (int, locus *);
 mpz_t *gfc_copy_shape (mpz_t *, int);
+mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
 gfc_expr *gfc_copy_expr (gfc_expr *);
 
 try gfc_specification_expr (gfc_expr *);

gcc/fortran/iresolve.c

@@ -31,6 +31,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #include "config.h"
 #include <string.h>
 #include <stdarg.h>
+#include <assert.h>
 
 #include "gfortran.h"
 #include "intrinsic.h"
@@ -188,6 +189,7 @@ gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
     {
       gfc_resolve_index (dim, 1);
       f->rank = mask->rank - 1;
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
   f->value.function.name =
@@ -227,6 +229,7 @@ gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
     {
       gfc_resolve_index (dim, 1);
       f->rank = mask->rank - 1;
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
   f->value.function.name =
@@ -371,6 +374,7 @@ gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
     {
       f->rank = mask->rank - 1;
       gfc_resolve_index (dim, 1);
+      f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
     }
 
   f->value.function.name =
@@ -388,6 +392,7 @@ gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
 
   f->ts = array->ts;
   f->rank = array->rank;
+  f->shape = gfc_copy_shape (array->shape, array->rank);
 
   if (shift->rank > 0)
     n = 1;
@@ -477,6 +482,7 @@ gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
 
   f->ts = array->ts;
   f->rank = array->rank;
+  f->shape = gfc_copy_shape (array->shape, array->rank);
 
   n = 0;
   if (shift->rank > 0)
@@ -654,7 +660,7 @@ gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
 
 
 void
-gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
+gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
 		    gfc_expr * dim)
 {
   static char lbound[] = "__lbound";
@@ -662,7 +668,13 @@ gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind ();
 
-  f->rank = (dim == NULL) ? 1 : 0;
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], array->rank);
+    }
+
   f->value.function.name = lbound;
 }
 
@@ -1259,6 +1271,12 @@ gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
 
   f->ts = matrix->ts;
   f->rank = 2;
+  if (matrix->shape)
+    {
+      f->shape = gfc_get_shape (2);
+      mpz_init_set (f->shape[0], matrix->shape[1]);
+      mpz_init_set (f->shape[1], matrix->shape[0]);
+    }
 
   switch (matrix->ts.type)
     {
@@ -1304,7 +1322,7 @@ gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
 
 
 void
-gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
+gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
 		    gfc_expr * dim)
 {
   static char ubound[] = "__ubound";
@@ -1312,7 +1330,13 @@ gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
   f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind ();
 
-  f->rank = (dim == NULL) ? 1 : 0;
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], array->rank);
+    }
+
   f->value.function.name = ubound;
 }
 

gcc/fortran/simplify.c

@@ -3213,12 +3213,12 @@ gfc_simplify_shape (gfc_expr * source)
   int n;
   try t;
 
+  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
+    return NULL;
+
   result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind (),
 				  &source->where);
 
-  if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
-    return result;
-
   ar = gfc_find_array_ref (source);
 
   t = gfc_array_ref_shape (ar, shape);