Skip to content

R
riscv-gcc-1
Commit 94538bd1 by Victor Leikehman Committed by Paul Brook
Options

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
Showing with 88 additions and 8 deletions
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);
......
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