From 9a0aec1dbd7edb70514afbf67b24a1b027463efb Mon Sep 17 00:00:00 2001
From: pbrook <pbrook@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 9 Aug 2004 23:32:59 +0000
Subject: [PATCH] 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@85730 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/fortran/ChangeLog | 18 ++
gcc/fortran/trans-array.c | 43 ++--
gcc/fortran/trans-expr.c | 238 ++++++++++++++++++++--
gcc/fortran/trans.h | 6 +-
gcc/testsuite/ChangeLog | 5 +
gcc/testsuite/gfortran.dg/der_array_1.f90 | 33 +++
6 files changed, 313 insertions(+), 30 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/der_array_1.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8ec2d7f2df52..12aca9d2e227 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b950ec9243d5..bc825bb00cf1 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -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));
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 67f5809bab63..554cf1daf3c1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 9d6473486c28..51c63ce56864 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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. */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4a54700ee512..c42f6dd1454c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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).
diff --git a/gcc/testsuite/gfortran.dg/der_array_1.f90 b/gcc/testsuite/gfortran.dg/der_array_1.f90
new file mode 100644
index 000000000000..00dc7a5c2b33
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/der_array_1.f90
@@ -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
+
--
GitLab