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

+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.

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));

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;

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.  */

gcc/testsuite/ChangeLog

+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).

gcc/testsuite/gfortran.dg/der_array_1.f90

+! { 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
+