From 94538bd12ae8ffa02164399a616ef806e77f797b Mon Sep 17 00:00:00 2001 From: Victor Leikehman Date: Sun, 8 Aug 2004 12:28:25 +0000 Subject: [PATCH] simplify.c (gfc_simplify_shape): Bugfix. 2004-08-08 Victor Leikehman * 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 | 11 +++++++++++ gcc/fortran/expr.c | 44 ++++++++++++++++++++++++++++++++++++++++++ gcc/fortran/gfortran.h | 3 ++- gcc/fortran/iresolve.c | 32 ++++++++++++++++++++++++++---- gcc/fortran/simplify.c | 6 +++--- 5 files changed, 88 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b4338512ce7..8ec2d7f2df5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2004-08-08 Victor Leikehman + + * 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 * intrinsic.c (add_subroutines): Add getenv and diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index adff08e2070..99db76d908c 100644 --- a/gcc/fortran/expr.c +++ b/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. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 533479c63cd..19a22147758 100644 --- a/gcc/fortran/gfortran.h +++ b/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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index b42294d7d23..21fd0150c0b 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -31,6 +31,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "config.h" #include #include +#include #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; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 0a32d6f5cfc..bffda5973df 100644 --- a/gcc/fortran/simplify.c +++ b/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); -- 2.30.2