From 99afd94b259027a9f7de2153159e56dc31468ae6 Mon Sep 17 00:00:00 2001 From: pbrook Date: Sun, 8 Aug 2004 12:28:25 +0000 Subject: 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@85685 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/expr.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) (limited to 'gcc/fortran/expr.c') 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. */ -- cgit v1.2.3