Commit 94538bd1 by Victor Leikehman Committed by Paul Brook

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
parent 352a77c8
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> 2004-08-06 Janne Blomqvist <jblomqvi@cc.hut.fi>
* intrinsic.c (add_subroutines): Add getenv and * intrinsic.c (add_subroutines): Add getenv and
......
...@@ -330,6 +330,50 @@ gfc_copy_shape (mpz_t * shape, int rank) ...@@ -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 /* Given an expression pointer, return a copy of the expression. This
subroutine is recursive. */ subroutine is recursive. */
......
...@@ -989,7 +989,7 @@ typedef struct gfc_expr ...@@ -989,7 +989,7 @@ typedef struct gfc_expr
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 /* Structures for information associated with different kinds of
numbers. The first set of integer parameters define all there is numbers. The first set of integer parameters define all there is
...@@ -1584,6 +1584,7 @@ void gfc_replace_expr (gfc_expr *, gfc_expr *); ...@@ -1584,6 +1584,7 @@ void gfc_replace_expr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_int_expr (int); gfc_expr *gfc_int_expr (int);
gfc_expr *gfc_logical_expr (int, locus *); gfc_expr *gfc_logical_expr (int, locus *);
mpz_t *gfc_copy_shape (mpz_t *, int); 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 *); gfc_expr *gfc_copy_expr (gfc_expr *);
try gfc_specification_expr (gfc_expr *); try gfc_specification_expr (gfc_expr *);
......
...@@ -31,6 +31,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA ...@@ -31,6 +31,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "config.h" #include "config.h"
#include <string.h> #include <string.h>
#include <stdarg.h> #include <stdarg.h>
#include <assert.h>
#include "gfortran.h" #include "gfortran.h"
#include "intrinsic.h" #include "intrinsic.h"
...@@ -188,6 +189,7 @@ gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) ...@@ -188,6 +189,7 @@ gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{ {
gfc_resolve_index (dim, 1); gfc_resolve_index (dim, 1);
f->rank = mask->rank - 1; f->rank = mask->rank - 1;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
} }
f->value.function.name = f->value.function.name =
...@@ -227,6 +229,7 @@ gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) ...@@ -227,6 +229,7 @@ gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{ {
gfc_resolve_index (dim, 1); gfc_resolve_index (dim, 1);
f->rank = mask->rank - 1; f->rank = mask->rank - 1;
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
} }
f->value.function.name = f->value.function.name =
...@@ -371,6 +374,7 @@ gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) ...@@ -371,6 +374,7 @@ gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim)
{ {
f->rank = mask->rank - 1; f->rank = mask->rank - 1;
gfc_resolve_index (dim, 1); gfc_resolve_index (dim, 1);
f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim);
} }
f->value.function.name = f->value.function.name =
...@@ -388,6 +392,7 @@ gfc_resolve_cshift (gfc_expr * f, gfc_expr * array, ...@@ -388,6 +392,7 @@ gfc_resolve_cshift (gfc_expr * f, gfc_expr * array,
f->ts = array->ts; f->ts = array->ts;
f->rank = array->rank; f->rank = array->rank;
f->shape = gfc_copy_shape (array->shape, array->rank);
if (shift->rank > 0) if (shift->rank > 0)
n = 1; n = 1;
...@@ -477,6 +482,7 @@ gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array, ...@@ -477,6 +482,7 @@ gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array,
f->ts = array->ts; f->ts = array->ts;
f->rank = array->rank; f->rank = array->rank;
f->shape = gfc_copy_shape (array->shape, array->rank);
n = 0; n = 0;
if (shift->rank > 0) if (shift->rank > 0)
...@@ -654,7 +660,7 @@ gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift, ...@@ -654,7 +660,7 @@ gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
void void
gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
gfc_expr * dim) gfc_expr * dim)
{ {
static char lbound[] = "__lbound"; static char lbound[] = "__lbound";
...@@ -662,7 +668,13 @@ gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, ...@@ -662,7 +668,13 @@ gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
f->ts.type = BT_INTEGER; f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind (); 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; f->value.function.name = lbound;
} }
...@@ -1259,6 +1271,12 @@ gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix) ...@@ -1259,6 +1271,12 @@ gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix)
f->ts = matrix->ts; f->ts = matrix->ts;
f->rank = 2; 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) switch (matrix->ts.type)
{ {
...@@ -1304,7 +1322,7 @@ gfc_resolve_trim (gfc_expr * f, gfc_expr * string) ...@@ -1304,7 +1322,7 @@ gfc_resolve_trim (gfc_expr * f, gfc_expr * string)
void void
gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
gfc_expr * dim) gfc_expr * dim)
{ {
static char ubound[] = "__ubound"; static char ubound[] = "__ubound";
...@@ -1312,7 +1330,13 @@ gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, ...@@ -1312,7 +1330,13 @@ gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED,
f->ts.type = BT_INTEGER; f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind (); 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; f->value.function.name = ubound;
} }
......
...@@ -3213,12 +3213,12 @@ gfc_simplify_shape (gfc_expr * source) ...@@ -3213,12 +3213,12 @@ gfc_simplify_shape (gfc_expr * source)
int n; int n;
try t; try t;
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return NULL;
result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind (), result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind (),
&source->where); &source->where);
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return result;
ar = gfc_find_array_ref (source); ar = gfc_find_array_ref (source);
t = gfc_array_ref_shape (ar, shape); t = gfc_array_ref_shape (ar, shape);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment