[multiple changes]

2006-10-05  Erik Edelmann <edelmann@gcc.gnu.org>
	    Paul Thomas <pault@gcc.gnu.org>

	PR fortran/20541
	* interface.c (gfc_compare_derived_types): Add comparison of
	the allocatable field.
	* intrinsic.c (add_subroutines): Add MOVE_ALLOC.
	* trans-expr.c (gfc_conv_aliased_arg, gfc_trans_subarray_assign,
	gfc_trans_subcomponent_assign, gfc_conv_string_parameter,
	gfc_trans_scalar_assign): Add extra arguments l_is_temp
	and r_is_var to references to latter function.
	(gfc_conv_function_call): Add enum for types of argument and
	an associated variable parm_kind. Deallocate components of
	INTENT(OUT) and non-variable arrays.
	(gfc_trans_subcomponent_assign): Add block to assign arrays
	to allocatable components.
	(gfc_trans_scalar_assign): Add block to handle assignments of
	derived types with allocatable components, using the above new
	arguments to control allocation/deallocation of memory and the
	copying of allocated arrays.
	* trans-array.c (gfc_array_allocate): Remove old identification 
	of pointer and replace with that of an allocatable array. Add
	nullify of structures with allocatable components. 
	(gfc_conv_array_initializer): Treat EXPR_NULL.
	(gfc_conv_array_parameter): Deallocate allocatable components
	of non-variable structures.
	(gfc_trans_dealloc_allocated): Use second argument of library
	deallocate to inhibit, without error, freeing NULL pointers.
	(get_full_array_size): New function to return the size of a
	full array.
	(gfc_duplicate_allocatable): New function to allocate and copy
	allocated data.
	(structure_alloc_comps): New recursive function to deallocate,
	nullify or copy allocatable components.
	(gfc_nullify_alloc_comp, gfc_deallocate_alloc_comp,
	gfc_copy_alloc_comp): New interface functions to call previous.
	(gfc_trans_deferred_array): Add the code to nullify allocatable
	components, when entering scope, and to deallocate them on
	leaving. Do not call gfc_trans_static_array_pointer and return
	for structures with allocatable components and default
	initializers.
	* symbol.c (gfc_set_component_attr): Set allocatable field.
	(gfc_get_component_attr): Set the allocatable attribute.
	* intrinsic.h : Prototype for gfc_check_move_alloc.
	* decl.c (build_struct): Apply TR15581 constraints for
	allocatable components.
	(variable_decl): Default initializer is always NULL for
	allocatable components.
	(match_attr_spec): Allow, or not, allocatable components,
	according to the standard in force.
	* trans-array.h : Prototypes for gfc_nullify_alloc_comp,
	gfc_deallocate_alloc_comp, gfc_copy_alloc_comp and
	gfc_duplicate_allocatable.
	* gfortran.texi : Add mention of TR15581 extensions.
	* gfortran.h : Add attribute alloc_comp, add
	gfc_components field allocatable and add the prototype
	for gfc_expr_to_initialize.
	* trans-stmt.c (generate_loop_for_temp_to_lhs,
	generate_loop_for_rhs_to_temp, gfc_trans_where_assign,
	gfc_trans_where_3): Add extra arguments to calls to
	gfc_trans_scalar_assign and set appropriately.
	(gfc_trans_allocate): Nullify allocatable components.
	(gfc_trans_deallocate): Deallocate to ultimate allocatable
	components but stop at ultimate pointer components.
	* module.c (mio_symbol_attribute, mio_symbol_attribute,
	mio_component): Add module support for allocatable
	components.
	* trans-types.c (gfc_get_derived_type): Treat allocatable
	components.
	* trans.h : Add two boolean arguments to
	gfc_trans_scalar_assign.
	* resolve.c (resolve_structure_cons): Check conformance of
	constructor element and the component.
	(resolve_allocate_expr): Add expression to nullify the
	constructor expression for allocatable components.
	(resolve_transfer): Inhibit I/O of derived types with
	allocatable components.
	(resolve_fl_derived): Skip check of bounds of allocatable
	components.
	* trans-decl.c (gfc_get_symbol_decl): Add derived types
	with allocatable components to deferred variable.
	(gfc_trans_deferred_vars): Make calls for derived types
	with allocatable components to gfc_trans_deferred_array.
	(gfc_generate_function_code): Nullify allocatable
	component function result on entry.
	* parse.c (parse_derived): Set symbol attr.allocatable if
	allocatable components are present.
	* check.c (gfc_check_allocated): Enforce attr.allocatable
	for intrinsic arguments.
	(gfc_check_move_alloc): Check arguments of move_alloc.
	* primary.c (gfc_variable_attr): Set allocatable attribute.
	* intrinsic.texi : Add index entry and section for
	for move_alloc.

	PR fortran/29115
	* resolve.c (resolve_structure_cons): It is an error if the
	pointer component elements of a derived type constructor are
	not pointer or target.


	PR fortran/29211
	* trans-stmt.c (generate_loop_for_temp_to_lhs,
	generate_loop_for_rhs_to_temp): Provide a string length for
	the temporary by copying that of the other side of the scalar
	assignment.


2006-10-05  Paul Thomas  <pault@gcc.gnu.org>
	    Erik Edelmann  <edelmann@gcc.gnu.org>

	PR libgfortran/20541
	* Makefile.in : Add move_alloc.
	* intrinsics/move_alloc.c: New function.
	* Makefile.am : Add move_alloc.



2006-10-05  Erik Edelmann  <edelmann@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/20541
	* gfortran.dg/alloc_comp_basics_1.f90: New test.
	* gfortran.dg/alloc_comp_basics_2.f90: New test.
	* gfortran.dg/alloc_comp_assign_1.f90: New test.
	* gfortran.dg/alloc_comp_assign_2.f90: New test.
	* gfortran.dg/alloc_comp_assign_3.f90: New test.
	* gfortran.dg/alloc_comp_assign_4.f90: New test.
	* gfortran.dg/alloc_comp_constraint_1.f90: New test.
	* gfortran.dg/alloc_comp_constraint_2.f90: New test.
	* gfortran.dg/alloc_comp_constraint_3.f90: New test.
	* gfortran.dg/alloc_comp_constructor_1.f90: New test.
	* gfortran.dg/alloc_comp_constructor_2.f90: New test.
	* gfortran.dg/alloc_comp_initializer_1.f90: New test.
	* gfortran.dg/alloc_comp_std.f90: New test.
	* gfortran.dg/move_alloc.f90: New test.

	PR fortran/29115
	* gfortran.dg/derived_constructor_comps_2.f90: New test.

	PR fortran/29211
	* gfortran.dg/forall_char_dependencies_1.f90: New test.

From-SVN: r117558

1 files changed, 185 insertions, 17 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4bce65e..c5a4be3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1701,7 +1701,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 
   if (intent != INTENT_OUT)
     {
-      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+      tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
       gfc_add_expr_to_block (&body, tmp);
       gcc_assert (rse.ss == gfc_ss_terminator);
       gfc_trans_scalarizing_loops (&loop, &body);
@@ -1792,7 +1792,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
 
   gcc_assert (lse.ss == gfc_ss_terminator);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
   gfc_add_expr_to_block (&body, tmp);
   
   /* Generate the copying loops.  */
@@ -1864,6 +1864,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   gfc_ss *argss;
   gfc_ss_info *info;
   int byref;
+  int parm_kind;
   tree type;
   tree var;
   tree len;
@@ -1877,6 +1878,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   gfc_expr *e;
   gfc_symbol *fsym;
   stmtblock_t post;
+  enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -1919,6 +1921,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
     {
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
+      parm_kind = MISSING;
       if (e == NULL)
 	{
 
@@ -1947,6 +1950,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  /* An elemental function inside a scalarized loop.  */
           gfc_init_se (&parmse, se);
           gfc_conv_expr_reference (&parmse, e);
+	  parm_kind = ELEMENTAL;
 	}
       else
 	{
@@ -1957,12 +1961,14 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  if (argss == gfc_ss_terminator)
             {
 	      gfc_conv_expr_reference (&parmse, e);
+	      parm_kind = SCALAR;
               if (fsym && fsym->attr.pointer
 		  && e->expr_type != EXPR_NULL)
                 {
                   /* Scalar pointer dummy args require an extra level of
 		  indirection. The null pointer already contains
 		  this level of indirection.  */
+		  parm_kind = SCALAR_POINTER;
                   parmse.expr = build_fold_addr_expr (parmse.expr);
                 }
             }
@@ -2050,6 +2056,49 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
 
+      /* Allocated allocatable components of derived types must be
+	 deallocated for INTENT(OUT) dummy arguments and non-variable
+         scalars.  Non-variable arrays are dealt with in trans-array.c
+         (gfc_conv_array_parameter).  */
+      if (e && e->ts.type == BT_DERIVED
+	    && e->ts.derived->attr.alloc_comp
+	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
+		   ||
+		(e->expr_type != EXPR_VARIABLE && !e->rank)))
+        {
+	  int parm_rank;
+	  tmp = build_fold_indirect_ref (parmse.expr);
+	  parm_rank = e->rank;
+	  switch (parm_kind)
+	    {
+	    case (ELEMENTAL):
+	    case (SCALAR):
+	      parm_rank = 0;
+	      break;
+
+	    case (SCALAR_POINTER):
+              tmp = build_fold_indirect_ref (tmp);
+	      break;
+	    case (ARRAY):
+              tmp = parmse.expr;
+	      break;
+	    }
+
+          tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
+	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
+			    tmp, build_empty_stmt ());
+
+	  if (e->expr_type != EXPR_VARIABLE)
+	    /* Don't deallocate non-variables until they have been used.  */
+	    gfc_add_expr_to_block (&se->post, tmp);
+	  else 
+	    {
+	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
+	      gfc_add_expr_to_block (&se->pre, tmp);
+	    }
+        }
+
       /* Character strings are passed as two parameters, a length and a
          pointer.  */
       if (parmse.string_length != NULL_TREE)
@@ -2636,7 +2685,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 
   gfc_conv_expr (&rse, expr);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
   gfc_add_expr_to_block (&body, tmp);
 
   gcc_assert (rse.ss == gfc_ss_terminator);
@@ -2657,17 +2706,22 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   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_se lse;
   gfc_ss *rss;
   stmtblock_t block;
   tree tmp;
+  tree offset;
+  int n;
 
   gfc_start_block (&block);
+
   if (cm->pointer)
     {
       gfc_init_se (&se, NULL);
@@ -2700,8 +2754,68 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     }
   else if (cm->dimension)
     {
-      tmp = gfc_trans_subarray_assign (dest, cm, expr);
-      gfc_add_expr_to_block (&block, tmp);
+      if (cm->allocatable && expr->expr_type == EXPR_NULL)
+ 	gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      else if (cm->allocatable)
+        {
+          tree tmp2;
+
+          gfc_init_se (&se, NULL);
+ 
+	  rss = gfc_walk_expr (expr);
+          se.want_pointer = 0;
+          gfc_conv_expr_descriptor (&se, expr, rss);
+	  gfc_add_block_to_block (&block, &se.pre);
+
+	  tmp = fold_convert (TREE_TYPE (dest), se.expr);
+	  gfc_add_modify_expr (&block, dest, tmp);
+
+          if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
+	    tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
+				       cm->as->rank);
+	  else
+            tmp = gfc_duplicate_allocatable (dest, se.expr,
+					     TREE_TYPE(cm->backend_decl),
+					     cm->as->rank);
+
+          gfc_add_expr_to_block (&block, tmp);
+
+          gfc_add_block_to_block (&block, &se.post);
+          gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
+
+          /* Shift the lbound and ubound of temporaries to being unity, rather
+             than zero, based.  Calculate the offset for all cases.  */
+          offset = gfc_conv_descriptor_offset (dest);
+          gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
+          tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+          for (n = 0; n < expr->rank; n++)
+            {
+              if (expr->expr_type != EXPR_VARIABLE
+                  && expr->expr_type != EXPR_CONSTANT)
+                {
+                  tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
+                  gfc_add_modify_expr (&block, tmp,
+                                       fold_build2 (PLUS_EXPR,
+				      		    gfc_array_index_type,
+                                                    tmp, gfc_index_one_node));
+                  tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
+                  gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
+                }
+              tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+                                 gfc_conv_descriptor_lbound (dest,
+							     gfc_rank_cst[n]),
+                                 gfc_conv_descriptor_stride (dest,
+							     gfc_rank_cst[n]));
+              gfc_add_modify_expr (&block, tmp2, tmp);
+              tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+              gfc_add_modify_expr (&block, offset, tmp);
+            }
+        }
+      else
+        {
+	  tmp = gfc_trans_subarray_assign (dest, cm, expr);
+	  gfc_add_expr_to_block (&block, tmp);
+        }
     }
   else if (expr->ts.type == BT_DERIVED)
     {
@@ -2722,8 +2836,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   else
     {
       /* Scalar component.  */
-      gfc_se lse;
-
       gfc_init_se (&se, NULL);
       gfc_init_se (&lse, NULL);
 
@@ -2731,7 +2843,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * 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);
+      tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
       gfc_add_expr_to_block (&block, tmp);
     }
   return gfc_finish_block (&block);
@@ -2791,10 +2903,14 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
     }
 
   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)
+      /* Skip absent members in default initializers and allocatable
+	 components.  Although the latter have a default initializer
+	 of EXPR_NULL,... by default, the static nullify is not needed
+	 since this is done every time we come into scope.  */
+      if (!c->expr || cm->allocatable)
         continue;
 
       val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -3089,16 +3205,19 @@ gfc_conv_string_parameter (gfc_se * se)
 
 
 /* Generate code for assignment of scalar variables.  Includes character
-   strings.  */
+   strings and derived types with allocatable components.  */
 
 tree
-gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
+gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
+			 bool l_is_temp, bool r_is_var)
 {
   stmtblock_t block;
+  tree tmp;
+  tree cond;
 
   gfc_init_block (&block);
 
-  if (type == BT_CHARACTER)
+  if (ts.type == BT_CHARACTER)
     {
       gcc_assert (lse->string_length != NULL_TREE
 	      && rse->string_length != NULL_TREE);
@@ -3112,6 +3231,50 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
 			     rse->string_length, rse->expr);
     }
+  else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+    {
+      cond = NULL_TREE;
+	
+      /* Are the rhs and the lhs the same?  */
+      if (r_is_var)
+	{
+	  cond = fold_build2 (EQ_EXPR, boolean_type_node,
+			      build_fold_addr_expr (lse->expr),
+			      build_fold_addr_expr (rse->expr));
+	  cond = gfc_evaluate_now (cond, &lse->pre);
+	}
+
+      /* Deallocate the lhs allocated components as long as it is not
+	 the same as the rhs.  */
+      if (!l_is_temp)
+	{
+	  tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
+	  if (r_is_var)
+	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+	  gfc_add_expr_to_block (&lse->pre, tmp);
+	}
+	
+      gfc_add_block_to_block (&block, &lse->pre);
+      gfc_add_block_to_block (&block, &rse->pre);
+
+      gfc_add_modify_expr (&block, lse->expr,
+			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+
+      /* Do a deep copy if the rhs is a variable, if it is not the
+	 same as the lhs.  Otherwise, nullify the data fields so that the
+	 lhs retains the allocated resources.  */
+      if (r_is_var)
+	{
+	  tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
+	  tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	{
+	  tmp = gfc_nullify_alloc_comp (ts.derived, rse->expr, 0);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+    }
   else
     {
       gfc_add_block_to_block (&block, &lse->pre);
@@ -3217,6 +3380,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
+  bool l_is_temp;
 
   /* Special case a single function returning an array.  */
   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
@@ -3295,10 +3459,12 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
   else
     gfc_init_block (&body);
 
+  l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
+
   /* Translate the expression.  */
   gfc_conv_expr (&rse, expr2);
 
-  if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
+  if (l_is_temp)
     {
       gfc_conv_tmp_array_ref (&lse);
       gfc_advance_se_ss_chain (&lse);
@@ -3306,7 +3472,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
   else
     gfc_conv_expr (&lse, expr1);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
+				 expr2->expr_type == EXPR_VARIABLE);
   gfc_add_expr_to_block (&body, tmp);
 
   if (lss == gfc_ss_terminator)
@@ -3319,7 +3486,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gcc_assert (lse.ss == gfc_ss_terminator
 		  && rse.ss == gfc_ss_terminator);
 
-      if (loop.temp_ss != NULL)
+      if (l_is_temp)
 	{
 	  gfc_trans_scalarized_loop_boundary (&loop, &body);
 
@@ -3339,9 +3506,10 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gcc_assert (lse.ss == gfc_ss_terminator
 		      && rse.ss == gfc_ss_terminator);
 
-	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
+	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
 	  gfc_add_expr_to_block (&body, tmp);
 	}
+
       /* Generate the copying loops.  */
       gfc_trans_scalarizing_loops (&loop, &body);