procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/16919 (ICE with derived type and array constructor)

Browse source 
PR fortran/16919
	* trans-array.c (gfc_add_loop_ss_code): Handle GFC_SS_COMPONENT.
	(gfc_conv_array_index_offset): Allow "temporary" with nonzero delta.
	(gfc_trans_preloop_setup, gfc_trans_scalarized_loop_boundary):
	Handle GFC_SS_COMPONENT.
	(gfc_conv_ss_startstride): Ditto.  Set ss->shape.
	(gfc_conv_loop_setup): Tweak commends. Remove dead code.
	Use ss->shape.
	(gfc_conv_array_initializer): Call specific initializer routines.
	* trans-expr.c (gfc_trans_structure_assign): New function.
	(gfc_trans_subarray_assign): New function.
	(gfc_trans_subcomponent_assign): New fucntion
	(gfc_conv_structure): Use them.
	* trans.h (gfc_ss_type): Add GFC_SS_COMPONENT.
	(gfc_ss): Add shape.
testsuite/
	* gfortran.dg/der_array_1.f90: New test.

From-SVN: r85730
This commit is contained in:
Paul Brook 2004-08-09 23:32:59 +00:00 • committed by Paul Brook
parent b9bfca8100
commit e9cfef6413
6 changed files with 313 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View file

@ -1,3 +1,21 @@
2004-08-10 Paul Brook <paul@codesourcery.com>
PR fortran/16919
* trans-array.c (gfc_add_loop_ss_code): Handle GFC_SS_COMPONENT.
(gfc_conv_array_index_offset): Allow "temporary" with nonzero delta.
(gfc_trans_preloop_setup, gfc_trans_scalarized_loop_boundary):
Handle GFC_SS_COMPONENT.
(gfc_conv_ss_startstride): Ditto. Set ss->shape.
(gfc_conv_loop_setup): Tweak commends. Remove dead code.
Use ss->shape.
(gfc_conv_array_initializer): Call specific initializer routines.
* trans-expr.c (gfc_trans_structure_assign): New function.
(gfc_trans_subarray_assign): New function.
(gfc_trans_subcomponent_assign): New fucntion
(gfc_conv_structure): Use them.
* trans.h (gfc_ss_type): Add GFC_SS_COMPONENT.
(gfc_ss): Add shape.
2004-08-08 Victor Leikehman <lei@il.ibm.com>
* simplify.c (gfc_simplify_shape): Bugfix.

43
gcc/fortran/trans-array.c
View file

@ -1027,6 +1027,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
gfc_se se;
int n;
/* TODO: This can generate bad code if there are ordering dependencies.
eg. a callee allocated function and an unknown size constructor. */
assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
@ -1100,7 +1102,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
break;
case GFC_SS_TEMP:
/* Do nothing. This will be handled later. */
case GFC_SS_COMPONENT:
/* Do nothing. These are handled elsewhere. */
break;
default:
@ -1446,9 +1449,12 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
}
else
{
/* Temporary array. */
/* Temporary array or derived type component. */
assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
if (!integer_zerop (info->delta[i]))
index = fold (build (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]));
}
/* Multiply by the stride. */
@ -1597,7 +1603,8 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
continue;
if (ss->type != GFC_SS_SECTION
&& ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR)
&& ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
&& ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
@ -1819,7 +1826,8 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
continue;
if (ss->type != GFC_SS_SECTION
&& ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR)
&& ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
&& ss->type != GFC_SS_COMPONENT)
continue;
ss->data.info.offset = ss->data.info.saved_offset;
@ -1975,6 +1983,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
case GFC_SS_SECTION:
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen;
break;
@ -1990,6 +1999,9 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->expr && ss->expr->shape && !ss->shape)
ss->shape = ss->expr->shape;
switch (ss->type)
{
case GFC_SS_SECTION:
@ -2271,7 +2283,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->expr && ss->expr->shape)
if (ss->shape)
{
/* The frontend has worked out the size for us. */
loopspec[n] = ss;
@ -2280,6 +2292,10 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
if (ss->type == GFC_SS_CONSTRUCTOR)
{
/* An unknown size constructor will always be rank one.
Higher rank constructors will wither have known shape,
or still be wrapped in a call to reshape. */
assert (loop->dimen == 1);
/* Try to figure out the size of the constructor. */
/* TODO: avoid this by making the frontend set the shape. */
gfc_get_array_cons_size (&i, ss->expr->value.constructor);
@ -2295,7 +2311,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
}
/* TODO: Pick the best bound if we have a choice between a
functions and something else. */
function and something else. */
if (ss->type == GFC_SS_FUNCTION)
{
loopspec[n] = ss;
@ -2305,8 +2321,6 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
if (ss->type != GFC_SS_SECTION)
continue;
info = &ss->data.info;
if (loopspec[n])
specinfo = &loopspec[n]->data.info;
else
@ -2321,6 +2335,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
*/
if (!specinfo)
loopspec[n] = ss;
/* TODO: Is != contructor correct? */
else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
{
if (integer_onep (info->stride[n])
@ -2345,7 +2360,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
info = &loopspec[n]->data.info;
/* Set the extents of this range. */
cshape = loopspec[n]->expr->shape;
cshape = loopspec[n]->shape;
if (cshape && INTEGER_CST_P (info->start[n])
&& INTEGER_CST_P (info->stride[n]))
{
@ -2440,7 +2455,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
/* Calculate the translation from loop variables to array indices. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->type != GFC_SS_SECTION)
if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
@ -2449,7 +2464,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
{
dim = info->dim[n];
/* If we are specifying the range the delta may already be set. */
/* If we are specifying the range the delta is already set. */
if (loopspec[n] != ss)
{
/* Calculate the offset relative to the loop variable.
@ -2705,7 +2720,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
/* A single scalar or derived type value. Create an array with all
elements equal to that value. */
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
if (expr->expr_type == EXPR_CONSTANT)
gfc_conv_constant (&se, expr);
else
gfc_conv_structure (&se, expr, 1);
tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
assert (tmp && INTEGER_CST_P (tmp));

238
gcc/fortran/trans-expr.c
View file

@ -43,6 +43,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
/* Copy the scalarization loop variables. */
@ -1413,6 +1414,209 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
}
}
static tree
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
gfc_se rse;
gfc_se lse;
gfc_ss *rss;
gfc_ss *lss;
stmtblock_t body;
stmtblock_t block;
gfc_loopinfo loop;
int n;
tree tmp;
gfc_start_block (&block);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
/* Walk the rhs. */
rss = gfc_walk_expr (expr);
if (rss == gfc_ss_terminator)
{
/* The rhs is scalar. Add a ss for the expression. */
rss = gfc_get_ss ();
rss->next = gfc_ss_terminator;
rss->type = GFC_SS_SCALAR;
rss->expr = expr;
}
/* Create a SS for the destination. */
lss = gfc_get_ss ();
lss->type = GFC_SS_COMPONENT;
lss->expr = NULL;
lss->shape = gfc_get_shape (cm->as->rank);
lss->next = gfc_ss_terminator;
lss->data.info.dimen = cm->as->rank;
lss->data.info.descriptor = dest;
lss->data.info.data = gfc_conv_array_data (dest);
lss->data.info.offset = gfc_conv_array_offset (dest);
for (n = 0; n < cm->as->rank; n++)
{
lss->data.info.dim[n] = n;
lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
lss->data.info.stride[n] = gfc_index_one_node;
mpz_init (lss->shape[n]);
mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
cm->as->lower[n]->value.integer);
mpz_add_ui (lss->shape[n], lss->shape[n], 1);
}
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
gfc_copy_loopinfo_to_se (&rse, &loop);
rse.ss = rss;
gfc_mark_ss_chain_used (rss, 1);
lse.ss = lss;
gfc_mark_ss_chain_used (lss, 1);
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
gfc_conv_tmp_array_ref (&lse);
gfc_conv_expr (&rse, expr);
tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
gfc_add_expr_to_block (&body, tmp);
if (rse.ss != gfc_ss_terminator)
abort ();
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
/* Wrap the whole thing up. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
for (n = 0; n < cm->as->rank; n++)
mpz_clear (lss->shape[n]);
gfc_free (lss->shape);
return gfc_finish_block (&block);
}
/* Assign a single component of a derived type constructor. */
static tree
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
{
gfc_se se;
gfc_ss *rss;
stmtblock_t block;
tree tmp;
gfc_start_block (&block);
if (cm->pointer)
{
gfc_init_se (&se, NULL);
/* Pointer component. */
if (cm->dimension)
{
/* Array pointer. */
if (expr->expr_type == EXPR_NULL)
{
dest = gfc_conv_descriptor_data (dest);
tmp = fold_convert (TREE_TYPE (se.expr),
null_pointer_node);
gfc_add_modify_expr (&block, dest, tmp);
}
else
{
rss = gfc_walk_expr (expr);
se.direct_byref = 1;
se.expr = dest;
gfc_conv_expr_descriptor (&se, expr, rss);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&block, &se.post);
}
}
else
{
/* Scalar pointers. */
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify_expr (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
}
else if (cm->dimension)
{
tmp = gfc_trans_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
}
else if (expr->ts.type == BT_DERIVED)
{
/* Nested dervived type. */
tmp = gfc_trans_structure_assign (dest, expr);
gfc_add_expr_to_block (&block, tmp);
}
else
{
/* Scalar component. */
gfc_se lse;
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
gfc_conv_expr (&se, expr);
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.cl->backend_decl;
lse.expr = dest;
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
}
/* Assign a derived type contructor to a variable. */
static tree
gfc_trans_structure_assign (tree dest, gfc_expr * expr)
{
gfc_constructor *c;
gfc_component *cm;
stmtblock_t block;
tree field;
tree tmp;
gfc_start_block (&block);
cm = expr->ts.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!c->expr)
continue;
field = cm->backend_decl;
tmp = build (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
}
/* Build an expression for a constructor. If init is nonzero then
this is part of a static variable initializer. */
@ -1424,11 +1628,22 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
tree head;
tree tail;
tree val;
gfc_se cse;
tree type;
tree tmp;
assert (expr->expr_type == EXPR_STRUCTURE || expr->expr_type == EXPR_NULL);
assert (se->ss == NULL);
assert (expr->expr_type == EXPR_STRUCTURE);
type = gfc_typenode_for_spec (&expr->ts);
if (!init)
{
/* Create a temporary variable and fill it in. */
se->expr = gfc_create_var (type, expr->ts.derived->name);
tmp = gfc_trans_structure_assign (se->expr, expr);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
head = build1 (CONSTRUCTOR, type, NULL_TREE);
tail = NULL_TREE;
@ -1439,22 +1654,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!c->expr)
continue;
gfc_init_se (&cse, se);
/* Evaluate the expression for this component. */
if (init)
{
cse.expr = gfc_conv_initializer (c->expr, &cm->ts,
TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
}
else
{
gfc_conv_expr (&cse, c->expr);
gfc_add_block_to_block (&se->pre, &cse.pre);
gfc_add_block_to_block (&se->post, &cse.post);
}
val = gfc_conv_initializer (c->expr, &cm->ts,
TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
/* Build a TREE_CHAIN to hold it. */
val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE);
val = tree_cons (cm->backend_decl, val, NULL_TREE);
/* Add it to the list. */
if (tail == NULL_TREE)
@ -1497,7 +1701,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
if (se->ss && se->ss->expr == expr
&& (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
{
/* Substiture a scalar expression evaluated outside the scalarization
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
se->expr = se->ss->data.scalar.expr;
se->string_length = se->ss->data.scalar.string_length;

6
gcc/fortran/trans.h
View file

@ -148,7 +148,10 @@ typedef enum
/* An intrinsic function call. Many intrinsic functions which map directly
to library calls are created as GFC_SS_FUNCTION nodes. */
GFC_SS_INTRINSIC
GFC_SS_INTRINSIC,
/* A component of a derived type. */
GFC_SS_COMPONENT
}
gfc_ss_type;
@ -158,6 +161,7 @@ typedef struct gfc_ss
{
gfc_ss_type type;
gfc_expr *expr;
mpz_t *shape;
union
{
/* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE. */

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2004-08-10 Paul Brook <paul@codesourcery.com>
PR fortran/16919
* gfortran.dg/der_array_1.f90: New test.
2004-08-09 David Edelsohn <edelsohn@gnu.org>
* gcc.dg/cpp/assert4.c: _AIX asserts #system(unix).

33
gcc/testsuite/gfortran.dg/der_array_1.f90 Normal file
View file

@ -0,0 +1,33 @@
! { dg-do run }
! Test derived type constructors for derived types containing arrays.
! PR16919
program der_array_1
implicit none
integer n
integer m
! The 4 components here test known shape array, unknown shape array,
! multi-dimensional arrays and array pointers
type t
integer :: a(2)
integer :: b(2)
integer, dimension(2, 3) :: c
integer, pointer, dimension(:) :: p
end type
type(t) :: v
integer, dimension(2, 3) :: d
integer, dimension(:), pointer :: e
integer, dimension(2) :: f
m = 2
f = (/3, 4/)
d = reshape ((/5, 6, 7, 8, 9, 10/), (/2, 3/));
allocate (e(2))
v = t((/1, 2/), reshape (f, (/m/)), d, e);
if (any (v%a .ne. (/1, 2/)) .or. any (v%b .ne. (/3, 4/)) &
.or. any (v%c .ne. d) .or. .not. associated (v%p, e)) &
call abort ()
deallocate(e)
end program