Arrays in derived type constructors

[Paul Brook <paul at codesourcery dot com>]

The following patch fixes array in derived type constructors.
We handle these by creating a temporary variable, then performing the 
assignment as if the individual components had been assigned.

The can generate spectacularly inefficient code, particularly when combined 
with array constructors. However it works and in some cases is necessary for 
correctness.

Tested on i686-linux.
Applied to mainline.

Paul

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.
testsuite/
        * gfortran.dg/der_array_1.f90: New test.

Index: trans-array.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.12
diff -u -p -r1.12 trans-array.c
--- trans-array.c	6 Aug 2004 15:01:06 -0000	1.12
+++ trans-array.c	9 Aug 2004 23:12:45 -0000
@@ -1027,6 +1027,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loo
   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 * loo
 	  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
     }
   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 * 
 	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_
 	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 * 
 	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 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, g
       /* 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));
Index: trans-expr.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.17
diff -u -p -r1.17 trans-expr.c
--- trans-expr.c	6 Aug 2004 15:01:06 -0000	1.17
+++ trans-expr.c	9 Aug 2004 23:19:59 -0000
@@ -43,6 +43,7 @@ Software Foundation, 59 Temple Place - S
 /* 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, g
     }
 }
   
+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_exp
   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_exp
       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 * e
   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;
Index: trans.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans.h,v
retrieving revision 1.9
diff -u -p -r1.9 trans.h
--- trans.h	17 Jul 2004 19:35:03 -0000	1.9
+++ trans.h	9 Aug 2004 00:27:22 -0000
@@ -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.  */

Attachment: der_array_1.f90
Description: Text document