From e9cfef641351af682f2f6e1bc0fabbd2e08982b5 Mon Sep 17 00:00:00 2001 From: Paul Brook Date: Mon, 9 Aug 2004 23:32:59 +0000 Subject: [PATCH] re PR fortran/16919 (ICE with derived type and array constructor) 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 --- 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 8ec2d7f2df5..12aca9d2e22 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2004-08-10 Paul Brook + + 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 * simplify.c (gfc_simplify_shape): Bugfix. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b950ec9243d..bc825bb00cf 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 67f5809bab6..554cf1daf3c 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 9d6473486c2..51c63ce5686 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 4a54700ee51..c42f6dd1454 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-10 Paul Brook + + PR fortran/16919 + * gfortran.dg/der_array_1.f90: New test. + 2004-08-09 David Edelsohn * 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 00000000000..00dc7a5c2b3 --- /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 + -- 2.30.2