Attachment 12320 Details for Bug 20541 – Patch + testcases for allocatable components

[patch] Patch + testcases for allocatable components

alloc_comps0924.diff (text/plain), 94.58 KB, created by Paul Thomas on 2006-09-24 17:31:08 UTC

(hide)

Description:

Filename:

MIME Type:

Creator: Paul Thomas

Created: 2006-09-24 17:31:08 UTC

Size: 94.58 KB

patch

obsolete

>Index: gcc/fortran/interface.c
>===================================================================
>*** gcc/fortran/interface.c	(revision 117054)
>--- gcc/fortran/interface.c	(working copy)
>*************** gfc_compare_derived_types (gfc_symbol * 
>*** 374,379 ****
>--- 374,382 ----
>        if (dt1->dimension != dt2->dimension)
>  	return 0;
>  
>+      if (dt1->allocatable != dt2->allocatable)
>+ 	return 0;
>+ 
>        if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
>  	return 0;
>  
>Index: gcc/fortran/intrinsic.c
>===================================================================
>*** gcc/fortran/intrinsic.c	(revision 117054)
>--- gcc/fortran/intrinsic.c	(working copy)
>*************** add_subroutines (void)
>*** 2391,2396 ****
>--- 2391,2401 ----
>  	      length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
>  	      trim_name, BT_LOGICAL, dl, OPTIONAL);
>  
>+   add_sym_2s ("move_alloc", 0, 0, BT_UNKNOWN, 0, GFC_STD_F2003,
>+ 	      gfc_check_move_alloc, NULL, NULL,
>+ 	      f, BT_UNKNOWN, 0, REQUIRED,
>+ 	      t, BT_UNKNOWN, 0, REQUIRED);
>+ 
>    add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
>  	      gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
>  	      f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
>Index: gcc/fortran/trans-array.c
>===================================================================
>*** gcc/fortran/trans-array.c	(revision 117054)
>--- gcc/fortran/trans-array.c	(working copy)
>*************** gfc_array_allocate (gfc_se * se, gfc_exp
>*** 3236,3267 ****
>    tree size;
>    gfc_expr **lower;
>    gfc_expr **upper;
>!   gfc_ref *ref;
>!   int allocatable_array;
>!   int must_be_pointer;
>  
>    ref = expr->ref;
>  
>-   /* In Fortran 95, components can only contain pointers, so that,
>-      in ALLOCATE (foo%bar(2)), bar must be a pointer component.
>-      We test this by checking for ref->next.
>-      An implementation of TR 15581 would need to change this.  */
>- 
>-   if (ref)
>-     must_be_pointer = ref->next != NULL;
>-   else
>-     must_be_pointer = 0;
>-   
>    /* Find the last reference in the chain.  */
>    while (ref && ref->next != NULL)
>      {
>        gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
>        ref = ref->next;
>      }
>  
>    if (ref == NULL || ref->type != REF_ARRAY)
>      return false;
>  
>    /* Figure out the size of the array.  */
>    switch (ref->u.ar.type)
>      {
>--- 3236,3262 ----
>    tree size;
>    gfc_expr **lower;
>    gfc_expr **upper;
>!   gfc_ref *ref, *prev_ref = NULL;
>!   bool allocatable_array;
>  
>    ref = expr->ref;
>  
>    /* Find the last reference in the chain.  */
>    while (ref && ref->next != NULL)
>      {
>        gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
>+       prev_ref = ref;
>        ref = ref->next;
>      }
>  
>    if (ref == NULL || ref->type != REF_ARRAY)
>      return false;
>  
>+   if (!prev_ref)
>+     allocatable_array = expr->symtree->n.sym->attr.allocatable;
>+   else
>+     allocatable_array = prev_ref->u.c.component->allocatable;
>+ 
>    /* Figure out the size of the array.  */
>    switch (ref->u.ar.type)
>      {
>*************** gfc_array_allocate (gfc_se * se, gfc_exp
>*** 3294,3304 ****
>    tmp = gfc_conv_descriptor_data_addr (se->expr);
>    pointer = gfc_evaluate_now (tmp, &se->pre);
>  
>-   if (must_be_pointer)
>-     allocatable_array = 0;
>-   else
>-     allocatable_array = expr->symtree->n.sym->attr.allocatable;
>- 
>    if (TYPE_PRECISION (gfc_array_index_type) == 32)
>      {
>        if (allocatable_array)
>--- 3289,3294 ----
>*************** gfc_array_allocate (gfc_se * se, gfc_exp
>*** 3325,3330 ****
>--- 3315,3327 ----
>    tmp = gfc_conv_descriptor_offset (se->expr);
>    gfc_add_modify_expr (&se->pre, tmp, offset);
>  
>+   if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
>+     {
>+       tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
>+ 				    ref->u.ar.as->rank);
>+       gfc_add_expr_to_block (&se->pre, tmp);
>+     }
>+ 
>    return true;
>  }
>  
>*************** gfc_conv_array_initializer (tree type, g
>*** 3465,3470 ****
>--- 3462,3470 ----
>          }
>        break;
>  
>+     case EXPR_NULL:
>+       return gfc_build_null_descriptor (type);
>+ 
>      default:
>        gcc_unreachable ();
>      }
>*************** gfc_conv_array_parameter (gfc_se * se, g
>*** 4547,4552 ****
>--- 4547,4563 ----
>    se->want_pointer = 1;
>    gfc_conv_expr_descriptor (se, expr, ss);
>  
>+   /* Deallocate the allocatable components of structures that are
>+      not variable.  */
>+   if (expr->ts.type == BT_DERIVED
>+ 	&& expr->ts.derived->attr.alloc_comp
>+ 	&& expr->expr_type != EXPR_VARIABLE)
>+     {
>+       tmp = build_fold_indirect_ref (se->expr);
>+       tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
>+       gfc_add_expr_to_block (&se->post, tmp);
>+     }
>+ 
>    if (g77)
>      {
>        desc = se->expr;
>*************** tree
>*** 4595,4619 ****
>  gfc_trans_dealloc_allocated (tree descriptor)
>  { 
>    tree tmp;
>!   tree deallocate;
>    stmtblock_t block;
>  
>    gfc_start_block (&block);
>-   deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
>  
>!   tmp = gfc_conv_descriptor_data_get (descriptor);
>!   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
>!                 build_int_cst (TREE_TYPE (tmp), 0));
>!   tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
>    gfc_add_expr_to_block (&block, tmp);
>  
>    tmp = gfc_finish_block (&block);
>  
>!   return tmp;
>  }
>  
>  
>! /* NULLIFY an allocatable/pointer array on function entry, free it on exit.  */
>  
>  tree
>  gfc_trans_deferred_array (gfc_symbol * sym, tree body)
>--- 4606,4926 ----
>  gfc_trans_dealloc_allocated (tree descriptor)
>  { 
>    tree tmp;
>!   tree ptr;
>!   tree var;
>    stmtblock_t block;
>  
>    gfc_start_block (&block);
>  
>!   tmp = gfc_conv_descriptor_data_addr (descriptor);
>!   var = gfc_evaluate_now (tmp, &block);
>!   tmp = gfc_create_var (gfc_array_index_type, NULL);
>!   ptr = build_fold_addr_expr (tmp);
>! 
>!   /* Call array_deallocate with an int* present in the second argument.
>!      Although it is ignored here, it's presence ensures that arrays that
>!      are already deallocated are ignored.  */
>!   tmp = gfc_chainon_list (NULL_TREE, var);
>!   tmp = gfc_chainon_list (tmp, ptr);
>!   tmp = build_function_call_expr (gfor_fndecl_deallocate, tmp);
>    gfc_add_expr_to_block (&block, tmp);
>+   return gfc_finish_block (&block);
>+ }
>+ 
>  
>+ /* This helper function calculates the size in words of a full array.  */
>+ 
>+ static tree
>+ get_full_array_size (stmtblock_t *block, tree decl, int rank)
>+ {
>+   tree idx;
>+   tree nelems;
>+   tree tmp;
>+   idx = gfc_rank_cst[rank - 1];
>+   nelems = gfc_conv_descriptor_ubound (decl, idx);
>+   tmp = gfc_conv_descriptor_lbound (decl, idx);
>+   tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
>+   tmp = build2 (PLUS_EXPR, gfc_array_index_type,
>+ 		tmp, gfc_index_one_node);
>+   tmp = gfc_evaluate_now (tmp, block);
>+ 
>+   nelems = gfc_conv_descriptor_stride (decl, idx);
>+   tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
>+   return gfc_evaluate_now (tmp, block);
>+ }
>+ 
>+ 
>+ /* Allocate dest to the same size as src, and copy src -> dest.  */
>+ 
>+ tree
>+ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
>+ {
>+   tree tmp;
>+   tree size;
>+   tree nelems;
>+   tree args;
>+   tree null_cond;
>+   tree null_data;
>+   stmtblock_t block;
>+ 
>+   /* If the source is null, set the destination to null. */
>+   gfc_init_block (&block);
>+   gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
>+   null_data = gfc_finish_block (&block);
>+ 
>+   gfc_init_block (&block);
>+ 
>+   nelems = get_full_array_size (&block, src, rank);
>+   size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
>+ 		      TYPE_SIZE_UNIT (gfc_get_element_type (type)));
>+ 
>+   /* Allocate memory to the destination.  */
>+   tmp = gfc_chainon_list (NULL_TREE, size);
>+   if (gfc_index_integer_kind == 4)
>+     tmp = build_function_call_expr (gfor_fndecl_internal_malloc, tmp);
>+   else if (gfc_index_integer_kind == 8)
>+     tmp = build_function_call_expr (gfor_fndecl_internal_malloc64, tmp);
>+   else
>+     gcc_unreachable ();
>+   tmp = fold (convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)),
>+ 	      tmp));
>+   gfc_conv_descriptor_data_set (&block, dest, tmp);
>+ 
>+   /* We know the temporary and the value will be the same length,
>+      so can use memcpy.  */
>+   tmp = gfc_conv_descriptor_data_get (dest);
>+   args = gfc_chainon_list (NULL_TREE, tmp);
>+   tmp = gfc_conv_descriptor_data_get (src);
>+   args = gfc_chainon_list (args, tmp);
>+   args = gfc_chainon_list (args, size);
>+   tmp = built_in_decls[BUILT_IN_MEMCPY];
>+   tmp = build_function_call_expr (tmp, args);
>+   gfc_add_expr_to_block (&block, tmp);
>    tmp = gfc_finish_block (&block);
>  
>!   /* Null the destination if the source is null; otherwise do
>!      the allocate and copy.  */
>!   null_cond = gfc_conv_descriptor_data_get (src);
>!   null_cond = convert (pvoid_type_node, null_cond);
>!   null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
>! 		      null_pointer_node);
>!   return build3_v (COND_EXPR, null_cond, tmp, null_data);
>  }
>  
>  
>! /* Recursively traverse an object of derived type, generating code to
>!    deallocate, nullify or copy allocatable components.  This is the work horse
>!    function for the functions named in this enum.  */
>! 
>! enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
>! 
>! static tree
>! structure_alloc_comps (gfc_symbol * der_type, tree decl,
>! 		       tree dest, int rank, int purpose)
>! {
>!   gfc_component *c;
>!   gfc_loopinfo loop;
>!   stmtblock_t fnblock;
>!   stmtblock_t loopbody;
>!   tree tmp;
>!   tree comp;
>!   tree dcmp;
>!   tree nelems;
>!   tree index;
>!   tree var;
>!   tree cdecl;
>!   tree ctype;
>!   tree vref, dref;
>!   tree null_cond = NULL_TREE;
>! 
>!   gfc_init_block (&fnblock);
>! 
>!   /* If this an array of derived types with allocatable components
>!      build a loop and recursively call this function.  */
>!   if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE
>! 	|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
>!     {
>!       tmp = gfc_conv_array_data (decl);
>!       var = build_fold_indirect_ref (tmp);
>! 	
>!       /* Get the number of elements - 1 and set the counter.  */
>!       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
>! 	{
>! 	  /* Use the descriptor for an allocatable array.  Since this
>! 	     is a full array reference, we only need the descriptor
>! 	     information from dimension = rank.  */
>! 	  tmp = get_full_array_size (&fnblock, decl, rank);
>! 	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
>! 			tmp, gfc_index_one_node);
>! 
>! 	  null_cond = gfc_conv_descriptor_data_get (decl);
>! 	  null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
>! 			      build_int_cst (TREE_TYPE (tmp), 0));
>! 	}
>!       else
>! 	{
>! 	  /*  Otherwise use the TYPE_DOMAIN information.  */
>! 	  tmp =  array_type_nelts (TREE_TYPE (decl));
>! 	  tmp = fold_convert (gfc_array_index_type, tmp);
>! 	}
>! 
>!       /* Remember that this is, in fact, the no. of elements - 1.  */
>!       nelems = gfc_evaluate_now (tmp, &fnblock);
>!       index = gfc_create_var (gfc_array_index_type, "S");
>! 
>!       /* Build the body of the loop.  */
>!       gfc_init_block (&loopbody);
>! 
>!       vref = gfc_build_array_ref (var, index);
>! 
>!       if (purpose == COPY_ALLOC_COMP)
>!         {
>!           tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
>! 	  gfc_add_expr_to_block (&fnblock, tmp);
>! 
>! 	  tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
>! 	  dref = gfc_build_array_ref (tmp, index);
>! 	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
>! 	}
>!       else
>!         tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
>! 
>!       gfc_add_expr_to_block (&loopbody, tmp);
>! 
>!       /* Build the loop and return. */
>!       gfc_init_loopinfo (&loop);
>!       loop.dimen = 1;
>!       loop.from[0] = gfc_index_zero_node;
>!       loop.loopvar[0] = index;
>!       loop.to[0] = nelems;
>!       gfc_trans_scalarizing_loops (&loop, &loopbody);
>!       gfc_add_block_to_block (&fnblock, &loop.pre);
>! 
>!       tmp = gfc_finish_block (&fnblock);
>!       if (null_cond != NULL_TREE)
>! 	tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
>! 
>!       return tmp;
>!     }
>! 
>!   /* Otherwise, act on the components or recursively call self to
>!      act on a chain of components. */
>!   for (c = der_type->components; c; c = c->next)
>!     {
>!       bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
>! 				    && c->ts.derived->attr.alloc_comp;
>!       cdecl = c->backend_decl;
>!       ctype = TREE_TYPE (cdecl);
>! 
>!       switch (purpose)
>! 	{
>! 	case DEALLOCATE_ALLOC_COMP:
>! 	  /* Do not deallocate the components of ultimate pointer
>! 	     components.  */
>! 	  if (cmp_has_alloc_comps && !c->pointer)
>! 	    {
>! 	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
>! 	      rank = c->as ? c->as->rank : 0;
>! 	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
>! 					   rank, purpose);
>! 	      gfc_add_expr_to_block (&fnblock, tmp);
>! 	    }
>! 
>! 	  if (c->allocatable)
>! 	    {
>! 	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
>! 	      tmp = gfc_trans_dealloc_allocated (comp);
>! 	      gfc_add_expr_to_block (&fnblock, tmp);
>! 	    }
>! 	  break;
>! 
>! 	case NULLIFY_ALLOC_COMP:
>! 	  if (c->pointer)
>! 	    continue;
>! 	  else if (c->allocatable)
>! 	    {
>! 	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
>! 	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
>! 	    }
>!           else if (cmp_has_alloc_comps)
>! 	    {
>! 	      comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
>! 	      rank = c->as ? c->as->rank : 0;
>! 	      tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
>! 					   rank, purpose);
>! 	      gfc_add_expr_to_block (&fnblock, tmp);
>! 	    }
>! 	  break;
>! 
>! 	case COPY_ALLOC_COMP:
>! 	  if (c->pointer)
>! 	    continue;
>! 
>! 	  /* We need source and destination components.  */
>! 	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
>! 	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
>! 	  dcmp = fold_convert (TREE_TYPE (comp), dcmp);
>! 
>! 	  if (c->allocatable && !cmp_has_alloc_comps)
>! 	    {
>! 	      tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
>! 	      gfc_add_expr_to_block (&fnblock, tmp);
>! 	    }
>! 
>!           if (cmp_has_alloc_comps)
>! 	    {	      
>! 	      tmp = fold_convert (TREE_TYPE (dcmp), comp);
>! 	      gfc_add_modify_expr (&fnblock, dcmp, tmp);
>! 	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
>! 					   c->as->rank, purpose);
>! 	      gfc_add_expr_to_block (&fnblock, tmp);
>! 	    }
>! 	  break;
>! 
>! 	default:
>! 	  gcc_unreachable ();
>! 	  break;
>! 	}
>!     }
>! 
>!   return gfc_finish_block (&fnblock);
>! }
>! 
>! /* Recursively traverse an object of derived type, generating code to
>!    nullify allocatable components.  */
>! 
>! tree
>! gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
>! {
>!   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
>! 				NULLIFY_ALLOC_COMP);
>! }
>! 
>! 
>! /* Recursively traverse an object of derived type, generating code to
>!    deallocate allocatable components.  */
>! 
>! tree
>! gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
>! {
>!   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
>! 				DEALLOCATE_ALLOC_COMP);
>! }
>! 
>! 
>! /* Recursively traverse an object of derived type, generating code to
>!    copy its allocatable components.  */
>! 
>! tree
>! gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
>! {
>!   return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP);
>! }
>! 
>! 
>! /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
>!    Do likewise, recursively if necessary, with the allocatable components of
>!    derived types.  */
>  
>  tree
>  gfc_trans_deferred_array (gfc_symbol * sym, tree body)
>*************** gfc_trans_deferred_array (gfc_symbol * s
>*** 4623,4638 ****
>    tree descriptor;
>    stmtblock_t fnblock;
>    locus loc;
>  
>    /* Make sure the frontend gets these right.  */
>!   if (!(sym->attr.pointer || sym->attr.allocatable))
>!     fatal_error
>!       ("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
>  
>    gfc_init_block (&fnblock);
>  
>    gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
>!                 || TREE_CODE (sym->backend_decl) == PARM_DECL);
>  
>    if (sym->ts.type == BT_CHARACTER
>        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
>--- 4930,4951 ----
>    tree descriptor;
>    stmtblock_t fnblock;
>    locus loc;
>+   int rank;
>+   bool sym_has_alloc_comp;
>+ 
>+   sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
>+ 			  && sym->ts.derived->attr.alloc_comp;
>  
>    /* Make sure the frontend gets these right.  */
>!   if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
>!     fatal_error ("Possible frontend bug: Deferred array size without pointer, "
>! 		 "allocatable attribute or derived type without allocatable "
>! 		 "components.");
>  
>    gfc_init_block (&fnblock);
>  
>    gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL
>! 		|| TREE_CODE (sym->backend_decl) == PARM_DECL);
>  
>    if (sym->ts.type == BT_CHARACTER
>        && !INTEGER_CST_P (sym->ts.cl->backend_decl))
>*************** gfc_trans_deferred_array (gfc_symbol * s
>*** 4653,4659 ****
>    gfc_set_backend_locus (&sym->declared_at);
>    descriptor = sym->backend_decl;
>  
>!   if (TREE_STATIC (descriptor))
>      {
>        /* SAVEd variables are not freed on exit.  */
>        gfc_trans_static_array_pointer (sym);
>--- 4966,4975 ----
>    gfc_set_backend_locus (&sym->declared_at);
>    descriptor = sym->backend_decl;
>  
>!   /* Although static, derived types with deafult initializers and
>!      allocatable components must not be nulled wholesale; instead they
>!      are treated component by component.  */
>!   if (TREE_STATIC (descriptor) && !sym_has_alloc_comp)
>      {
>        /* SAVEd variables are not freed on exit.  */
>        gfc_trans_static_array_pointer (sym);
>*************** gfc_trans_deferred_array (gfc_symbol * s
>*** 4662,4683 ****
>  
>    /* Get the descriptor type.  */
>    type = TREE_TYPE (sym->backend_decl);
>!   if (!GFC_DESCRIPTOR_TYPE_P (type))
>      {
>        /* If the backend_decl is not a descriptor, we must have a pointer
>  	 to one.  */
>        descriptor = build_fold_indirect_ref (sym->backend_decl);
>        type = TREE_TYPE (descriptor);
>-       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
>      }
>! 
>    /* NULLIFY the data pointer.  */
>!   gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
>  
>    gfc_add_expr_to_block (&fnblock, body);
>  
>    gfc_set_backend_locus (&loc);
>!   /* Allocatable arrays need to be freed when they go out of scope.  */
>    if (sym->attr.allocatable)
>      {
>        tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
>--- 4978,5017 ----
>  
>    /* Get the descriptor type.  */
>    type = TREE_TYPE (sym->backend_decl);
>!     
>!   if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
>!     {
>!       rank = sym->as ? sym->as->rank : 0;
>!       tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
>!       gfc_add_expr_to_block (&fnblock, tmp);
>!     }
>!   else if (!GFC_DESCRIPTOR_TYPE_P (type))
>      {
>        /* If the backend_decl is not a descriptor, we must have a pointer
>  	 to one.  */
>        descriptor = build_fold_indirect_ref (sym->backend_decl);
>        type = TREE_TYPE (descriptor);
>      }
>!   
>    /* NULLIFY the data pointer.  */
>!   if (GFC_DESCRIPTOR_TYPE_P (type))
>!     gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
>  
>    gfc_add_expr_to_block (&fnblock, body);
>  
>    gfc_set_backend_locus (&loc);
>! 
>!   /* Allocatable arrays need to be freed when they go out of scope.
>!      The allocatable components of pointers must not be touched.  */
>!   if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
>!       && !sym->attr.pointer)
>!     {
>!       int rank;
>!       rank = sym->as ? sym->as->rank : 0;
>!       tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
>!       gfc_add_expr_to_block (&fnblock, tmp);
>!     }
>! 
>    if (sym->attr.allocatable)
>      {
>        tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
>Index: gcc/fortran/trans-expr.c
>===================================================================
>*** gcc/fortran/trans-expr.c	(revision 117054)
>--- gcc/fortran/trans-expr.c	(working copy)
>*************** Software Foundation, 51 Franklin Street,
>*** 42,48 ****
>  #include "trans-stmt.h"
>  #include "dependency.h"
>  
>! static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
>  static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
>  						 gfc_expr *);
>  
>--- 42,48 ----
>  #include "trans-stmt.h"
>  #include "dependency.h"
>  
>! static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
>  static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
>  						 gfc_expr *);
>  
>*************** gfc_conv_aliased_arg (gfc_se * parmse, g
>*** 1701,1707 ****
>  
>    if (intent != INTENT_OUT)
>      {
>!       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
>        gfc_add_expr_to_block (&body, tmp);
>        gcc_assert (rse.ss == gfc_ss_terminator);
>        gfc_trans_scalarizing_loops (&loop, &body);
>--- 1701,1707 ----
>  
>    if (intent != INTENT_OUT)
>      {
>!       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);
>*************** gfc_conv_aliased_arg (gfc_se * parmse, g
>*** 1792,1798 ****
>  
>    gcc_assert (lse.ss == gfc_ss_terminator);
>  
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
>    gfc_add_expr_to_block (&body, tmp);
>    
>    /* Generate the copying loops.  */
>--- 1792,1798 ----
>  
>    gcc_assert (lse.ss == gfc_ss_terminator);
>  
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
>    gfc_add_expr_to_block (&body, tmp);
>    
>    /* Generate the copying loops.  */
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 1864,1869 ****
>--- 1864,1870 ----
>    gfc_ss *argss;
>    gfc_ss_info *info;
>    int byref;
>+   int parm_kind;
>    tree type;
>    tree var;
>    tree len;
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 1877,1882 ****
>--- 1878,1884 ----
>    gfc_expr *e;
>    gfc_symbol *fsym;
>    stmtblock_t post;
>+   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
>  
>    arglist = NULL_TREE;
>    retargs = NULL_TREE;
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 1919,1924 ****
>--- 1921,1927 ----
>      {
>        e = arg->expr;
>        fsym = formal ? formal->sym : NULL;
>+       parm_kind = MISSING;
>        if (e == NULL)
>  	{
>  
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 1947,1952 ****
>--- 1950,1956 ----
>  	  /* An elemental function inside a scalarized loop.  */
>            gfc_init_se (&parmse, se);
>            gfc_conv_expr_reference (&parmse, e);
>+ 	  parm_kind = ELEMENTAL;
>  	}
>        else
>  	{
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 1957,1968 ****
>--- 1961,1974 ----
>  	  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);
>                  }
>              }
>*************** gfc_conv_function_call (gfc_se * se, gfc
>*** 2039,2044 ****
>--- 2045,2093 ----
>  	  parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
>  	}
>  
>+       /* 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)
>*************** gfc_trans_subarray_assign (tree dest, gf
>*** 2625,2631 ****
>  
>    gfc_conv_expr (&rse, expr);
>  
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
>    gfc_add_expr_to_block (&body, tmp);
>  
>    gcc_assert (rse.ss == gfc_ss_terminator);
>--- 2674,2680 ----
>  
>    gfc_conv_expr (&rse, expr);
>  
>!   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);
>*************** gfc_trans_subarray_assign (tree dest, gf
>*** 2646,2662 ****
>    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);
>--- 2695,2717 ----
>    return gfc_finish_block (&block);
>  }
>  
>+ 
>  /* Assign a single component of a derived type constructor.  */
>  
>  static tree
>! gfc_trans_subcomponent_assign (gfc_se * outer_se, 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);
>*************** gfc_trans_subcomponent_assign (tree dest
>*** 2689,2696 ****
>      }
>    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)
>      {
>--- 2744,2811 ----
>      }
>    else if (cm->dimension)
>      {
>!       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)
>      {
>*************** gfc_trans_subcomponent_assign (tree dest
>*** 2704,2718 ****
>        else
>  	{
>  	  /* Nested constructors.  */
>! 	  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);
>  
>--- 2819,2831 ----
>        else
>  	{
>  	  /* Nested constructors.  */
>! 	  tmp = gfc_trans_structure_assign (outer_se, dest, expr);
>  	  gfc_add_expr_to_block (&block, tmp);
>  	}
>      }
>    else
>      {
>        /* Scalar component.  */
>        gfc_init_se (&se, NULL);
>        gfc_init_se (&lse, NULL);
>  
>*************** gfc_trans_subcomponent_assign (tree dest
>*** 2720,2726 ****
>        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);
>--- 2833,2839 ----
>        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, true, false);
>        gfc_add_expr_to_block (&block, tmp);
>      }
>    return gfc_finish_block (&block);
>*************** gfc_trans_subcomponent_assign (tree dest
>*** 2729,2735 ****
>  /* Assign a derived type constructor to a variable.  */
>  
>  static tree
>! gfc_trans_structure_assign (tree dest, gfc_expr * expr)
>  {
>    gfc_constructor *c;
>    gfc_component *cm;
>--- 2842,2848 ----
>  /* Assign a derived type constructor to a variable.  */
>  
>  static tree
>! gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
>  {
>    gfc_constructor *c;
>    gfc_component *cm;
>*************** gfc_trans_structure_assign (tree dest, g
>*** 2747,2753 ****
>  
>        field = cm->backend_decl;
>        tmp = build3 (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);
>--- 2860,2866 ----
>  
>        field = cm->backend_decl;
>        tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
>!       tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
>        gfc_add_expr_to_block (&block, tmp);
>      }
>    return gfc_finish_block (&block);
>*************** gfc_conv_structure (gfc_se * se, gfc_exp
>*** 2774,2791 ****
>      {
>        /* 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;
>      }
>  
>    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;
>  
>        val = gfc_conv_initializer (c->expr, &cm->ts,
>  	  TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
>  
>--- 2887,2908 ----
>      {
>        /* Create a temporary variable and fill it in.  */
>        se->expr = gfc_create_var (type, expr->ts.derived->name);
>!       tmp = gfc_trans_structure_assign (se, se->expr, expr);
>        gfc_add_expr_to_block (&se->pre, tmp);
>        return;
>      }
>  
>    cm = expr->ts.derived->components;
>+ 
>    for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
>      {
>!       /* Skip absent members in default initializers and allocatable
>! 	 components.  */
>        if (!c->expr)
>          continue;
>  
>+       gcc_assert (!cm->allocatable);
>+ 
>        val = gfc_conv_initializer (c->expr, &cm->ts,
>  	  TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
>  
>*************** gfc_conv_string_parameter (gfc_se * se)
>*** 3078,3093 ****
>  
>  
>  /* Generate code for assignment of scalar variables.  Includes character
>!    strings.  */
>  
>  tree
>! gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
>  {
>    stmtblock_t block;
>  
>    gfc_init_block (&block);
>  
>!   if (type == BT_CHARACTER)
>      {
>        gcc_assert (lse->string_length != NULL_TREE
>  	      && rse->string_length != NULL_TREE);
>--- 3195,3213 ----
>  
>  
>  /* Generate code for assignment of scalar variables.  Includes character
>!    strings and derived types with allocatable components.  */
>  
>  tree
>! 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 (ts.type == BT_CHARACTER)
>      {
>        gcc_assert (lse->string_length != NULL_TREE
>  	      && rse->string_length != NULL_TREE);
>*************** gfc_trans_scalar_assign (gfc_se * lse, g
>*** 3101,3106 ****
>--- 3221,3270 ----
>        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);
>*************** gfc_trans_assignment (gfc_expr * expr1, 
>*** 3206,3211 ****
>--- 3370,3376 ----
>    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)
>*************** gfc_trans_assignment (gfc_expr * expr1, 
>*** 3284,3293 ****
>    else
>      gfc_init_block (&body);
>  
>    /* Translate the expression.  */
>    gfc_conv_expr (&rse, expr2);
>  
>!   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
>      {
>        gfc_conv_tmp_array_ref (&lse);
>        gfc_advance_se_ss_chain (&lse);
>--- 3449,3460 ----
>    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 (l_is_temp)
>      {
>        gfc_conv_tmp_array_ref (&lse);
>        gfc_advance_se_ss_chain (&lse);
>*************** gfc_trans_assignment (gfc_expr * expr1, 
>*** 3295,3301 ****
>    else
>      gfc_conv_expr (&lse, expr1);
>  
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
>    gfc_add_expr_to_block (&body, tmp);
>  
>    if (lss == gfc_ss_terminator)
>--- 3462,3469 ----
>    else
>      gfc_conv_expr (&lse, expr1);
>  
>!   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)
>*************** gfc_trans_assignment (gfc_expr * expr1, 
>*** 3308,3314 ****
>        gcc_assert (lse.ss == gfc_ss_terminator
>  		  && rse.ss == gfc_ss_terminator);
>  
>!       if (loop.temp_ss != NULL)
>  	{
>  	  gfc_trans_scalarized_loop_boundary (&loop, &body);
>  
>--- 3476,3482 ----
>        gcc_assert (lse.ss == gfc_ss_terminator
>  		  && rse.ss == gfc_ss_terminator);
>  
>!       if (l_is_temp)
>  	{
>  	  gfc_trans_scalarized_loop_boundary (&loop, &body);
>  
>*************** gfc_trans_assignment (gfc_expr * expr1, 
>*** 3328,3336 ****
>  	  gcc_assert (lse.ss == gfc_ss_terminator
>  		      && rse.ss == gfc_ss_terminator);
>  
>! 	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
>  	  gfc_add_expr_to_block (&body, tmp);
>  	}
>        /* Generate the copying loops.  */
>        gfc_trans_scalarizing_loops (&loop, &body);
>  
>--- 3496,3505 ----
>  	  gcc_assert (lse.ss == gfc_ss_terminator
>  		      && rse.ss == gfc_ss_terminator);
>  
>! 	  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);
>  
>Index: gcc/fortran/symbol.c
>===================================================================
>*** gcc/fortran/symbol.c	(revision 117054)
>--- gcc/fortran/symbol.c	(working copy)
>*************** gfc_set_component_attr (gfc_component * 
>*** 1523,1528 ****
>--- 1523,1529 ----
>  
>    c->dimension = attr->dimension;
>    c->pointer = attr->pointer;
>+   c->allocatable = attr->allocatable;
>  }
>  
>  
>*************** gfc_get_component_attr (symbol_attribute
>*** 1536,1541 ****
>--- 1537,1543 ----
>    gfc_clear_attr (attr);
>    attr->dimension = c->dimension;
>    attr->pointer = c->pointer;
>+   attr->allocatable = c->allocatable;
>  }
>  
>  
>Index: gcc/fortran/intrinsic.h
>===================================================================
>*** gcc/fortran/intrinsic.h	(revision 117054)
>--- gcc/fortran/intrinsic.h	(working copy)
>*************** try gfc_check_free (gfc_expr *);
>*** 153,158 ****
>--- 153,159 ----
>  try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
>  try gfc_check_gerror (gfc_expr *);
>  try gfc_check_getlog (gfc_expr *);
>+ try gfc_check_move_alloc (gfc_expr *, gfc_expr *);
>  try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
>  		      gfc_expr *);
>  try gfc_check_random_number (gfc_expr *);
>Index: gcc/fortran/decl.c
>===================================================================
>*** gcc/fortran/decl.c	(revision 117054)
>--- gcc/fortran/decl.c	(working copy)
>*************** build_struct (const char *name, gfc_char
>*** 962,975 ****
>  
>    /* Check array components.  */
>    if (!c->dimension)
>!     return SUCCESS;
>  
>    if (c->pointer)
>      {
>        if (c->as->type != AS_DEFERRED)
>  	{
>! 	  gfc_error ("Pointer array component of structure at %C "
>! 		     "must have a deferred shape");
>  	  return FAILURE;
>  	}
>      }
>--- 962,992 ----
>  
>    /* Check array components.  */
>    if (!c->dimension)
>!     {
>!       if (c->allocatable)
>! 	{
>! 	  gfc_error ("Allocatable component at %C must be an array");
>! 	  return FAILURE;
>! 	}
>!       else
>! 	return SUCCESS;
>!     }
>  
>    if (c->pointer)
>      {
>        if (c->as->type != AS_DEFERRED)
>  	{
>! 	  gfc_error ("Pointer array component of structure at %C must have a "
>! 		     "deferred shape");
>! 	  return FAILURE;
>! 	}
>!     }
>!   else if (c->allocatable)
>!     {
>!       if (c->as->type != AS_DEFERRED)
>! 	{
>! 	  gfc_error ("Allocatable component of structure at %C must have a "
>! 		     "deferred shape");
>  	  return FAILURE;
>  	}
>      }
>*************** variable_decl (int elem)
>*** 1315,1322 ****
>      t = add_init_expr_to_sym (name, &initializer, &var_locus);
>    else
>      {
>!       if (current_ts.type == BT_DERIVED && !current_attr.pointer
>! 	  && !initializer)
>  	initializer = gfc_default_initializer (&current_ts);
>        t = build_struct (name, cl, &initializer, &as);
>      }
>--- 1332,1341 ----
>      t = add_init_expr_to_sym (name, &initializer, &var_locus);
>    else
>      {
>!       if (current_ts.type == BT_DERIVED
>! 	    && !current_attr.pointer
>! 	    && !current_attr.allocatable
>! 	    && !initializer)
>  	initializer = gfc_default_initializer (&current_ts);
>        t = build_struct (name, cl, &initializer, &as);
>      }
>*************** match_attr_spec (void)
>*** 2141,2151 ****
>  	  && d != DECL_DIMENSION && d != DECL_POINTER
>  	  && d != DECL_COLON && d != DECL_NONE)
>  	{
>! 
>! 	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
>! 		     &seen_at[d]);
>! 	  m = MATCH_ERROR;
>! 	  goto cleanup;
>  	}
>  
>        if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
>--- 2160,2183 ----
>  	  && d != DECL_DIMENSION && d != DECL_POINTER
>  	  && d != DECL_COLON && d != DECL_NONE)
>  	{
>! 	  if (d == DECL_ALLOCATABLE)
>! 	    {
>! 	      if (gfc_notify_std (GFC_STD_F2003, 
>! 				   "In the selected standard, the ALLOCATABLE "
>! 				   "attribute at %C is not allowed in a TYPE "
>! 				   "definition") == FAILURE)         
>! 		{
>! 		  m = MATCH_ERROR;
>! 		  goto cleanup;
>! 		}
>!             }
>!           else
>! 	    {
>! 	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
>! 			  &seen_at[d]);
>! 	      m = MATCH_ERROR;
>! 	      goto cleanup;
>! 	    }
>  	}
>  
>        if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
>Index: gcc/fortran/trans-array.h
>===================================================================
>*** gcc/fortran/trans-array.h	(revision 117054)
>--- gcc/fortran/trans-array.h	(working copy)
>*************** tree gfc_trans_dummy_array_bias (gfc_sym
>*** 43,48 ****
>--- 43,57 ----
>  tree gfc_trans_g77_array (gfc_symbol *, tree);
>  /* Generate code to deallocate an array, if it is allocated.  */
>  tree gfc_trans_dealloc_allocated (tree);
>+ 
>+ tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank);
>+ 
>+ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
>+ 
>+ tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
>+ 
>+ tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
>+ 
>  /* Add initialization for deferred arrays.  */
>  tree gfc_trans_deferred_array (gfc_symbol *, tree);
>  /* Generate an initializer for a static pointer or allocatable array.  */
>Index: gcc/fortran/gfortran.texi
>===================================================================
>*** gcc/fortran/gfortran.texi	(revision 117054)
>--- gcc/fortran/gfortran.texi	(working copy)
>*************** available.
>*** 1370,1376 ****
>  @itemize
>  @item 
>  Intrinsics @code{command_argument_count}, @code{get_command},
>! @code{get_command_argument}, and @code{get_environment_variable}.
>  
>  @item 
>  @cindex Array constructors
>--- 1370,1377 ----
>  @itemize
>  @item 
>  Intrinsics @code{command_argument_count}, @code{get_command},
>! @code{get_command_argument}, @code{get_environment_variable}, and
>! @code{move_alloc}.
>  
>  @item 
>  @cindex Array constructors
>*************** Support for the declaration of enumerati
>*** 1397,1410 ****
>  
>  @item
>  @cindex TR 15581
>! The following parts of TR 15581:
>  @itemize
>  @item
>  @cindex @code{ALLOCATABLE} dummy arguments
>! The @code{ALLOCATABLE} attribute for dummy arguments.
>  @item
>  @cindex @code{ALLOCATABLE} function results
>  @code{ALLOCATABLE} function results
>  @end itemize
>  
>  @item
>--- 1398,1414 ----
>  
>  @item
>  @cindex TR 15581
>! TR 15581:
>  @itemize
>  @item
>  @cindex @code{ALLOCATABLE} dummy arguments
>! @code{ALLOCATABLE} dummy arguments.
>  @item
>  @cindex @code{ALLOCATABLE} function results
>  @code{ALLOCATABLE} function results
>+ @item
>+ @cindex @code{ALLOCATABLE} components of derived types
>+ @code{ALLOCATABLE} components of derived types
>  @end itemize
>  
>  @item
>Index: gcc/fortran/gfortran.h
>===================================================================
>*** gcc/fortran/gfortran.h	(revision 117054)
>--- gcc/fortran/gfortran.h	(working copy)
>*************** typedef struct
>*** 532,537 ****
>--- 532,540 ----
>    /* Special attributes for Cray pointers, pointees.  */
>    unsigned cray_pointer:1, cray_pointee:1;
>  
>+   /* The symbol is a derived type with allocatable components, possibly nested.
>+    */
>+   unsigned alloc_comp:1;
>  }
>  symbol_attribute;
>  
>*************** typedef struct gfc_component
>*** 649,655 ****
>    const char *name;
>    gfc_typespec ts;
>  
>!   int pointer, dimension;
>    gfc_array_spec *as;
>  
>    tree backend_decl;
>--- 652,658 ----
>    const char *name;
>    gfc_typespec ts;
>  
>!   int pointer, allocatable, dimension;
>    gfc_array_spec *as;
>  
>    tree backend_decl;
>*************** void gfc_resolve_omp_do_blocks (gfc_code
>*** 1969,1974 ****
>--- 1972,1978 ----
>  void gfc_free_actual_arglist (gfc_actual_arglist *);
>  gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
>  const char *gfc_extract_int (gfc_expr *, int *);
>+ gfc_expr *gfc_expr_to_initialize (gfc_expr *);
>  
>  gfc_expr *gfc_build_conversion (gfc_expr *);
>  void gfc_free_ref_list (gfc_ref *);
>Index: gcc/fortran/trans-stmt.c
>===================================================================
>*** gcc/fortran/trans-stmt.c	(revision 117054)
>--- gcc/fortran/trans-stmt.c	(working copy)
>*************** generate_loop_for_temp_to_lhs (gfc_expr 
>*** 1802,1808 ****
>        gfc_conv_expr (&lse, expr);
>  
>        /* Use the scalar assignment.  */
>!       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
>  
>        /* Form the mask expression according to the mask tree list.  */
>        if (wheremask)
>--- 1802,1808 ----
>        gfc_conv_expr (&lse, expr);
>  
>        /* Use the scalar assignment.  */
>!       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
>  
>        /* Form the mask expression according to the mask tree list.  */
>        if (wheremask)
>*************** generate_loop_for_rhs_to_temp (gfc_expr 
>*** 1897,1903 ****
>      }
>  
>    /* Use the scalar assignment.  */
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
>  
>    /* Form the mask expression according to the mask tree list.  */
>    if (wheremask)
>--- 1897,1903 ----
>      }
>  
>    /* Use the scalar assignment.  */
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
>  
>    /* Form the mask expression according to the mask tree list.  */
>    if (wheremask)
>*************** gfc_trans_where_assign (gfc_expr *expr1,
>*** 2978,2984 ****
>      maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
>  
>    /* Use the scalar assignment as is.  */
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
>    tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
>  
>    gfc_add_expr_to_block (&body, tmp);
>--- 2978,2985 ----
>      maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
>  
>    /* Use the scalar assignment as is.  */
>!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
>! 				 loop.temp_ss != NULL, false);
>    tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
>  
>    gfc_add_expr_to_block (&body, tmp);
>*************** gfc_trans_where_assign (gfc_expr *expr1,
>*** 3031,3037 ****
>  				    maskexpr);
>  
>            /* Use the scalar assignment as is.  */
>!           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
>            tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
>            gfc_add_expr_to_block (&body, tmp);
>  
>--- 3032,3038 ----
>  				    maskexpr);
>  
>            /* Use the scalar assignment as is.  */
>!           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
>            tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
>            gfc_add_expr_to_block (&body, tmp);
>  
>*************** gfc_trans_where_3 (gfc_code * cblock, gf
>*** 3406,3413 ****
>          gfc_conv_expr (&edse, edst);
>      }
>  
>!   tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
>!   estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
>  		 : build_empty_stmt ();
>    tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
>    gfc_add_expr_to_block (&body, tmp);
>--- 3407,3414 ----
>          gfc_conv_expr (&edse, edst);
>      }
>  
>!   tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
>!   estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
>  		 : build_empty_stmt ();
>    tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
>    gfc_add_expr_to_block (&body, tmp);
>*************** gfc_trans_allocate (gfc_code * code)
>*** 3591,3596 ****
>--- 3592,3605 ----
>  				 parm, tmp, build_empty_stmt ());
>  	      gfc_add_expr_to_block (&se.pre, tmp);
>  	    }
>+ 
>+ 	  if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
>+ 	    {
>+ 	      tmp = build_fold_indirect_ref (se.expr);
>+ 	      tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
>+ 	      gfc_add_expr_to_block (&se.pre, tmp);
>+ 	    }
>+ 
>  	}
>  
>        tmp = gfc_finish_block (&se.pre);
>*************** gfc_trans_deallocate (gfc_code * code)
>*** 3675,3680 ****
>--- 3684,3709 ----
>        se.descriptor_only = 1;
>        gfc_conv_expr (&se, expr);
>  
>+       if (expr->ts.type == BT_DERIVED
>+ 	    && expr->ts.derived->attr.alloc_comp)
>+         {
>+ 	  gfc_ref *ref;
>+ 	  gfc_ref *last = NULL;
>+ 	  for (ref = expr->ref; ref; ref = ref->next)
>+ 	    if (ref->type == REF_COMPONENT)
>+ 	      last = ref;
>+ 
>+ 	  /* Do not deallocate the components of a derived type
>+ 	     ultimate pointer component.  */
>+ 	  if (!(last && last->u.c.component->pointer)
>+ 		   && !(!last && expr->symtree->n.sym->attr.pointer))
>+ 	    {
>+ 	      tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
>+ 						expr->rank);
>+ 	      gfc_add_expr_to_block (&se.pre, tmp);
>+ 	    }
>+ 	}
>+ 
>        if (expr->rank)
>  	tmp = gfc_array_deallocate (se.expr, pstat);
>        else
>Index: gcc/fortran/module.c
>===================================================================
>*** gcc/fortran/module.c	(revision 117054)
>--- gcc/fortran/module.c	(working copy)
>*************** typedef enum
>*** 1435,1441 ****
>    AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
>    AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
>    AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
>!   AB_CRAY_POINTEE, AB_THREADPRIVATE
>  }
>  ab_attribute;
>  
>--- 1435,1441 ----
>    AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
>    AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
>    AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
>!   AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP
>  }
>  ab_attribute;
>  
>*************** static const mstring attr_bits[] =
>*** 1465,1470 ****
>--- 1465,1471 ----
>      minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
>      minit ("CRAY_POINTER", AB_CRAY_POINTER),
>      minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
>+     minit ("ALLOC_COMP", AB_ALLOC_COMP),
>      minit (NULL, -1)
>  };
>  
>*************** mio_symbol_attribute (symbol_attribute *
>*** 1556,1561 ****
>--- 1557,1565 ----
>        if (attr->cray_pointee)
>  	MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
>  
>+       if (attr->alloc_comp)
>+ 	MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
>+ 
>        mio_rparen ();
>  
>      }
>*************** mio_symbol_attribute (symbol_attribute *
>*** 1644,1649 ****
>--- 1648,1656 ----
>  	    case AB_CRAY_POINTEE:
>  	      attr->cray_pointee = 1;
>  	      break;
>+ 	    case AB_ALLOC_COMP:
>+ 	      attr->alloc_comp = 1;
>+ 	      break;
>  	    }
>  	}
>      }
>*************** mio_component (gfc_component * c)
>*** 1951,1956 ****
>--- 1958,1964 ----
>  
>    mio_integer (&c->dimension);
>    mio_integer (&c->pointer);
>+   mio_integer (&c->allocatable);
>  
>    mio_expr (&c->initializer);
>    mio_rparen ();
>Index: gcc/fortran/trans-types.c
>===================================================================
>*** gcc/fortran/trans-types.c	(revision 117054)
>--- gcc/fortran/trans-types.c	(working copy)
>*************** gfc_get_derived_type (gfc_symbol * deriv
>*** 1550,1556 ****
>           required.  */
>        if (c->dimension)
>  	{
>! 	  if (c->pointer)
>  	    {
>  	      /* Pointers to arrays aren't actually pointer types.  The
>  	         descriptors are separate, but the data is common.  */
>--- 1550,1556 ----
>           required.  */
>        if (c->dimension)
>  	{
>! 	  if (c->pointer || c->allocatable)
>  	    {
>  	      /* Pointers to arrays aren't actually pointer types.  The
>  	         descriptors are separate, but the data is common.  */
>Index: gcc/fortran/trans.h
>===================================================================
>*** gcc/fortran/trans.h	(revision 117054)
>--- gcc/fortran/trans.h	(working copy)
>*************** int gfc_conv_function_call (gfc_se *, gf
>*** 307,313 ****
>  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
>  
>  /* Generate code for a scalar assignment.  */
>! tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt);
>  
>  /* Translate COMMON blocks.  */
>  void gfc_trans_common (gfc_namespace *);
>--- 307,313 ----
>  /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
>  
>  /* Generate code for a scalar assignment.  */
>! tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool);
>  
>  /* Translate COMMON blocks.  */
>  void gfc_trans_common (gfc_namespace *);
>Index: gcc/fortran/resolve.c
>===================================================================
>*** gcc/fortran/resolve.c	(revision 117054)
>--- gcc/fortran/resolve.c	(working copy)
>*************** resolve_structure_cons (gfc_expr * expr)
>*** 596,611 ****
>  
>    for (; comp; comp = comp->next, cons = cons->next)
>      {
>!       if (! cons->expr)
>  	{
>  	  t = FAILURE;
>  	  continue;
>  	}
>  
>!       if (gfc_resolve_expr (cons->expr) == FAILURE)
>! 	{
>  	  t = FAILURE;
>- 	  continue;
>  	}
>  
>        /* If we don't have the right type, try to convert it.  */
>--- 596,619 ----
>  
>    for (; comp; comp = comp->next, cons = cons->next)
>      {
>!       if (!cons->expr)
>! 	continue;
>! 
>!       if (gfc_resolve_expr (cons->expr) == FAILURE)
>  	{
>  	  t = FAILURE;
>  	  continue;
>  	}
>  
>!       if (cons->expr->expr_type != EXPR_NULL
>! 	    && comp->as && comp->as->rank != cons->expr->rank
>! 	    && (comp->allocatable || cons->expr->rank))
>! 	{
>! 	  gfc_error ("The rank of the element in the derived type "
>! 		     "constructor at %L does not match that of the "
>! 		     "component (%d/%d)", &cons->expr->where,
>! 		     cons->expr->rank, comp->as ? comp->as->rank : 0);
>  	  t = FAILURE;
>  	}
>  
>        /* If we don't have the right type, try to convert it.  */
>*************** resolve_actual_arglist (gfc_actual_argli
>*** 919,931 ****
>  
>  
>  /* Do the checks of the actual argument list that are specific to elemental
>!    procedures.  If called with c == NULL, we have a function, otherwise if
>!    expr == NULL, we have a subroutine.  */
>  static try
>  resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
>  {
>!   gfc_actual_arglist *arg0;
>!   gfc_actual_arglist *arg;
>    gfc_symbol *esym = NULL;
>    gfc_intrinsic_sym *isym = NULL;
>    gfc_expr *e = NULL;
>--- 927,938 ----
>  
>  
>  /* Do the checks of the actual argument list that are specific to elemental
>!    procedures.  */
>  static try
>  resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
>  {
>!   gfc_actual_arglist * arg0;
>!   gfc_actual_arglist * arg;
>    gfc_symbol *esym = NULL;
>    gfc_intrinsic_sym *isym = NULL;
>    gfc_expr *e = NULL;
>*************** resolve_elemental_actual (gfc_expr *expr
>*** 973,979 ****
>  		&& arg->expr->symtree->n.sym->attr.optional)
>  	    set_by_optional = true;
>  
>! 	  /* Function specific; set the result rank and shape.  */
>  	  if (expr)
>  	    {
>  	      expr->rank = rank;
>--- 980,986 ----
>  		&& arg->expr->symtree->n.sym->attr.optional)
>  	    set_by_optional = true;
>  
>! 	  /* Function specific.  */
>  	  if (expr)
>  	    {
>  	      expr->rank = rank;
>*************** resolve_deallocate_expr (gfc_expr * e)
>*** 3312,3318 ****
>  
>  /* Given the expression node e for an allocatable/pointer of derived type to be
>     allocated, get the expression node to be initialized afterwards (needed for
>!    derived types with default initializers).  */
>  
>  static gfc_expr *
>  expr_to_initialize (gfc_expr * e)
>--- 3319,3326 ----
>  
>  /* Given the expression node e for an allocatable/pointer of derived type to be
>     allocated, get the expression node to be initialized afterwards (needed for
>!    derived types with default initializers, and derived types with allocatable
>!    components that need nullification.)  */
>  
>  static gfc_expr *
>  expr_to_initialize (gfc_expr * e)
>*************** resolve_allocate_expr (gfc_expr * e, gfc
>*** 3421,3428 ****
>          init_st->loc = code->loc;
>          init_st->op = EXEC_ASSIGN;
>          init_st->expr = expr_to_initialize (e);
>!         init_st->expr2 = init_e;
>! 
>          init_st->next = code->next;
>          code->next = init_st;
>      }
>--- 3429,3435 ----
>          init_st->loc = code->loc;
>          init_st->op = EXEC_ASSIGN;
>          init_st->expr = expr_to_initialize (e);
>! 	init_st->expr2 = init_e;
>          init_st->next = code->next;
>          code->next = init_st;
>      }
>*************** resolve_transfer (gfc_code * code)
>*** 4031,4036 ****
>--- 4038,4050 ----
>  	  return;
>  	}
>  
>+       if (ts->derived->attr.alloc_comp)
>+ 	{
>+ 	  gfc_error ("Data transfer element at %L cannot have "
>+ 		     "ALLOCATABLE components", &code->loc);
>+ 	  return;
>+ 	}
>+ 
>        if (derived_inaccessible (ts->derived))
>  	{
>  	  gfc_error ("Data transfer element at %L cannot have "
>*************** resolve_fl_derived (gfc_symbol *sym)
>*** 5412,5418 ****
>  	    }
>  	}
>  
>!       if (c->pointer || c->as == NULL)
>  	continue;
>  
>        for (i = 0; i < c->as->rank; i++)
>--- 5426,5432 ----
>  	    }
>  	}
>  
>!       if (c->pointer || c->allocatable ||  c->as == NULL)
>  	continue;
>  
>        for (i = 0; i < c->as->rank; i++)
>Index: gcc/fortran/trans-decl.c
>===================================================================
>*** gcc/fortran/trans-decl.c	(revision 117054)
>--- gcc/fortran/trans-decl.c	(working copy)
>*************** gfc_get_symbol_decl (gfc_symbol * sym)
>*** 957,962 ****
>--- 957,965 ----
>  	GFC_DECL_PACKED_ARRAY (decl) = 1;
>      }
>  
>+   if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
>+     gfc_defer_symbol_init (sym);
>+ 
>    gfc_finish_var_decl (decl, sym);
>  
>    if (sym->ts.type == BT_CHARACTER)
>*************** gfc_trans_deferred_vars (gfc_symbol * pr
>*** 2559,2564 ****
>--- 2562,2569 ----
>  
>    for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
>      {
>+       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
>+ 				   && sym->ts.derived->attr.alloc_comp;
>        if (sym->attr.dimension)
>  	{
>  	  switch (sym->as->type)
>*************** gfc_trans_deferred_vars (gfc_symbol * pr
>*** 2601,2613 ****
>  	      break;
>  
>  	    case AS_DEFERRED:
>! 	      fnbody = gfc_trans_deferred_array (sym, fnbody);
>  	      break;
>  
>  	    default:
>  	      gcc_unreachable ();
>  	    }
>  	}
>        else if (sym->ts.type == BT_CHARACTER)
>  	{
>  	  gfc_get_backend_locus (&loc);
>--- 2606,2623 ----
>  	      break;
>  
>  	    case AS_DEFERRED:
>! 	      if (!sym_has_alloc_comp)
>! 		fnbody = gfc_trans_deferred_array (sym, fnbody);
>  	      break;
>  
>  	    default:
>  	      gcc_unreachable ();
>  	    }
>+ 	  if (sym_has_alloc_comp)
>+ 	    fnbody = gfc_trans_deferred_array (sym, fnbody);
>  	}
>+       else if (sym_has_alloc_comp)
>+ 	fnbody = gfc_trans_deferred_array (sym, fnbody);
>        else if (sym->ts.type == BT_CHARACTER)
>  	{
>  	  gfc_get_backend_locus (&loc);
>*************** gfc_generate_function_code (gfc_namespac
>*** 2959,2968 ****
>--- 2969,2980 ----
>    tree old_context;
>    tree decl;
>    tree tmp;
>+   tree tmp2;
>    stmtblock_t block;
>    stmtblock_t body;
>    tree result;
>    gfc_symbol *sym;
>+   int rank;
>  
>    sym = ns->proc_name;
>  
>*************** gfc_generate_function_code (gfc_namespac
>*** 3122,3128 ****
>    tmp = gfc_finish_block (&body);
>    /* Add code to create and cleanup arrays.  */
>    tmp = gfc_trans_deferred_vars (sym, tmp);
>-   gfc_add_expr_to_block (&block, tmp);
>  
>    if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
>      {
>--- 3134,3139 ----
>*************** gfc_generate_function_code (gfc_namespac
>*** 3137,3143 ****
>        else
>  	result = sym->result->backend_decl;
>  
>!       if (result == NULL_TREE)
>  	warning (0, "Function return value not set");
>        else
>  	{
>--- 3148,3165 ----
>        else
>  	result = sym->result->backend_decl;
>  
>!       if (result != NULL_TREE && sym->attr.function
>! 	    && sym->ts.type == BT_DERIVED
>! 	    && sym->ts.derived->attr.alloc_comp)
>! 	{
>! 	  rank = sym->as ? sym->as->rank : 0;
>! 	  tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
>! 	  gfc_add_expr_to_block (&block, tmp2);
>! 	}
>! 
>!      gfc_add_expr_to_block (&block, tmp);
>! 
>!      if (result == NULL_TREE)
>  	warning (0, "Function return value not set");
>        else
>  	{
>*************** gfc_generate_function_code (gfc_namespac
>*** 3148,3153 ****
>--- 3170,3178 ----
>  	  gfc_add_expr_to_block (&block, tmp);
>  	}
>      }
>+   else
>+     gfc_add_expr_to_block (&block, tmp);
>+ 
>  
>    /* Add all the decls we created during processing.  */
>    decl = saved_function_decls;
>Index: gcc/fortran/parse.c
>===================================================================
>*** gcc/fortran/parse.c	(revision 117054)
>--- gcc/fortran/parse.c	(working copy)
>*************** parse_derived (void)
>*** 1499,1504 ****
>--- 1499,1506 ----
>    int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
>    gfc_statement st;
>    gfc_state_data s;
>+   gfc_symbol *sym;
>+   gfc_component *c;
>  
>    error_flag = 0;
>  
>*************** parse_derived (void)
>*** 1595,1600 ****
>--- 1597,1614 ----
>  	}
>      }
>  
>+   /* Look for allocatable components.  */
>+   sym = gfc_current_block ();
>+   for (c = sym->components; c; c = c->next)
>+     {
>+       if (c->allocatable || (c->ts.type == BT_DERIVED
>+ 		    	     && c->ts.derived->attr.alloc_comp))
>+ 	{
>+ 	  sym->attr.alloc_comp = 1;
>+ 	  break;
>+ 	}
>+      }
>+ 
>    pop_state ();
>  }
>  
>Index: gcc/fortran/check.c
>===================================================================
>*** gcc/fortran/check.c	(revision 117054)
>--- gcc/fortran/check.c	(working copy)
>*************** gfc_check_all_any (gfc_expr * mask, gfc_
>*** 477,489 ****
>  try
>  gfc_check_allocated (gfc_expr * array)
>  {
>    if (variable_check (array, 0) == FAILURE)
>      return FAILURE;
>  
>    if (array_check (array, 0) == FAILURE)
>      return FAILURE;
>  
>!   if (!array->symtree->n.sym->attr.allocatable)
>      {
>        gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
>  		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
>--- 477,492 ----
>  try
>  gfc_check_allocated (gfc_expr * array)
>  {
>+   symbol_attribute attr;
>+ 
>    if (variable_check (array, 0) == FAILURE)
>      return FAILURE;
>  
>    if (array_check (array, 0) == FAILURE)
>      return FAILURE;
>  
>!   attr = gfc_variable_attr (array, NULL);
>!   if (!attr.allocatable)
>      {
>        gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
>  		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
>*************** gfc_check_merge (gfc_expr * tsource, gfc
>*** 1814,1819 ****
>--- 1817,1880 ----
>    return SUCCESS;
>  }
>  
>+ try
>+ gfc_check_move_alloc (gfc_expr * from, gfc_expr * to)
>+ {
>+   symbol_attribute attr;
>+ 
>+   if (variable_check (from, 0) == FAILURE)
>+     return FAILURE;
>+ 
>+   if (array_check (from, 0) == FAILURE)
>+     return FAILURE;
>+ 
>+   attr = gfc_variable_attr (from, NULL);
>+   if (!attr.allocatable)
>+     {
>+       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
>+ 		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
>+ 		 &from->where);
>+       return FAILURE;
>+     }
>+ 
>+   if (variable_check (to, 0) == FAILURE)
>+     return FAILURE;
>+ 
>+   if (array_check (to, 0) == FAILURE)
>+     return FAILURE;
>+ 
>+   attr = gfc_variable_attr (to, NULL);
>+   if (!attr.allocatable)
>+     {
>+       gfc_error ("'%s' argument of '%s' intrinsic at %L must be ALLOCATABLE",
>+ 		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
>+ 		 &to->where);
>+       return FAILURE;
>+     }
>+ 
>+   if (same_type_check (from, 0, to, 1) == FAILURE)
>+     return FAILURE;
>+ 
>+   if (to->rank != from->rank)
>+     {
>+       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
>+ 		 "have the same rank %d/%d", gfc_current_intrinsic_arg[0],
>+ 		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
>+ 		 &to->where,  from->rank, to->rank);
>+       return FAILURE;
>+     }
>+ 
>+   if (to->ts.kind != from->ts.kind)
>+     {
>+       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
>+ 		 "be of the same kind %d/%d", gfc_current_intrinsic_arg[0],
>+ 		 gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
>+ 		 &to->where, from->ts.kind, to->ts.kind);
>+       return FAILURE;
>+     }
>+ 
>+   return SUCCESS;
>+ }
>  
>  try
>  gfc_check_nearest (gfc_expr * x, gfc_expr * s)
>Index: gcc/fortran/primary.c
>===================================================================
>*** gcc/fortran/primary.c	(revision 117054)
>--- gcc/fortran/primary.c	(working copy)
>*************** check_substring:
>*** 1711,1717 ****
>  symbol_attribute
>  gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
>  {
>!   int dimension, pointer, target;
>    symbol_attribute attr;
>    gfc_ref *ref;
>  
>--- 1711,1717 ----
>  symbol_attribute
>  gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
>  {
>!   int dimension, pointer, allocatable, target;
>    symbol_attribute attr;
>    gfc_ref *ref;
>  
>*************** gfc_variable_attr (gfc_expr * expr, gfc_
>*** 1723,1728 ****
>--- 1723,1729 ----
>  
>    dimension = attr.dimension;
>    pointer = attr.pointer;
>+   allocatable = attr.allocatable;
>  
>    target = attr.target;
>    if (pointer)
>*************** gfc_variable_attr (gfc_expr * expr, gfc_
>*** 1743,1754 ****
>  	    break;
>  
>  	  case AR_SECTION:
>! 	    pointer = 0;
>  	    dimension = 1;
>  	    break;
>  
>  	  case AR_ELEMENT:
>! 	    pointer = 0;
>  	    break;
>  
>  	  case AR_UNKNOWN:
>--- 1744,1755 ----
>  	    break;
>  
>  	  case AR_SECTION:
>! 	    allocatable = pointer = 0;
>  	    dimension = 1;
>  	    break;
>  
>  	  case AR_ELEMENT:
>! 	    allocatable = pointer = 0;
>  	    break;
>  
>  	  case AR_UNKNOWN:
>*************** gfc_variable_attr (gfc_expr * expr, gfc_
>*** 1763,1780 ****
>  	  *ts = ref->u.c.component->ts;
>  
>  	pointer = ref->u.c.component->pointer;
>  	if (pointer)
>  	  target = 1;
>  
>  	break;
>  
>        case REF_SUBSTRING:
>! 	pointer = 0;
>  	break;
>        }
>  
>    attr.dimension = dimension;
>    attr.pointer = pointer;
>    attr.target = target;
>  
>    return attr;
>--- 1764,1783 ----
>  	  *ts = ref->u.c.component->ts;
>  
>  	pointer = ref->u.c.component->pointer;
>+ 	allocatable = ref->u.c.component->allocatable;
>  	if (pointer)
>  	  target = 1;
>  
>  	break;
>  
>        case REF_SUBSTRING:
>! 	allocatable = pointer = 0;
>  	break;
>        }
>  
>    attr.dimension = dimension;
>    attr.pointer = pointer;
>+   attr.allocatable = allocatable;
>    attr.target = target;
>  
>    return attr;
>Index: gcc/fortran/intrinsic.texi
>===================================================================
>*** gcc/fortran/intrinsic.texi	(revision 117054)
>--- gcc/fortran/intrinsic.texi	(working copy)
>*************** Some intrinsics have documentation yet t
>*** 181,186 ****
>--- 181,187 ----
>  * @code{MINVAL}:        MINVAL,    Minimum value of an array
>  * @code{MOD}:           MOD,       Remainder function
>  * @code{MODULO}:        MODULO,    Modulo function
>+ * @code{MOVE_ALLOC}:    MOVE_ALLOC, Move allocation from one object to another
>  * @code{MVBITS}:        MVBITS,    Move bits from one integer to another
>  * @code{NEAREST}:       NEAREST,   Nearest representable number
>  * @code{NINT}:          NINT,      Nearest whole number
>*************** Elemental subroutine
>*** 5833,5838 ****
>--- 5834,5883 ----
>  
>  
>  
>+ @node MOVE_ALLOC
>+ @section @code{MOVE_ALLOC} --- Move allocation from one object to another
>+ @findex @code{MOVE_ALLOC} intrinsic
>+ @cindex MOVE_ALLOC
>+ 
>+ @table @asis
>+ @item @emph{Description}:
>+ @code{MOVE_ALLOC(SRC, DEST)} moves the allocation from @var{SRC} to
>+ @var{DEST}.  @var{SRC} will become deallocated in the process.
>+ 
>+ @item @emph{Option}:
>+ f2003, gnu
>+ 
>+ @item @emph{Class}:
>+ Subroutine
>+ 
>+ @item @emph{Syntax}:
>+ @code{CALL MOVE_ALLOC(SRC, DEST)}
>+ 
>+ @item @emph{Arguments}:
>+ @multitable @columnfractions .15 .80
>+ @item @var{SRC} @tab @code{ALLOCATABLE}, @code{INTENT(INOUT)}, may be of any type and kind.
>+ @item @var{DEST} @tab @code{ALLOCATABLE}, @code{INTENT(OUT)}, shall be of the same type, kind and rank as @var{SRC}
>+ @end multitable
>+ 
>+ @item @emph{Return value}:
>+ None
>+ 
>+ @item @emph{Example}:
>+ @smallexample
>+ program test_move_alloc
>+     integer, allocatable :: a(:), b(:)
>+ 
>+     allocate(a(3))
>+     a = [ 1, 2, 3 ]
>+     call move_alloc(a, b)
>+     print *, allocated(a), allocated(b)
>+     print *, b
>+ end program test_move_alloc
>+ @end smallexample
>+ @end table
>+ 
>+ 
>+ 
>  @node NEAREST
>  @section @code{NEAREST} --- Nearest representable number
>  @findex @code{NEAREST} intrinsic
>Index: libgfortran/Makefile.in
>===================================================================
>*** libgfortran/Makefile.in	(revision 117054)
>--- libgfortran/Makefile.in	(working copy)
>*************** am__objects_30 = associated.lo abort.lo 
>*** 167,178 ****
>  	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
>  	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
>  	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
>! 	pack_generic.lo perror.lo signal.lo size.lo sleep.lo \
>! 	spread_generic.lo string_intrinsics.lo system.lo rand.lo \
>! 	random.lo rename.lo reshape_generic.lo reshape_packed.lo \
>! 	selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
>! 	system_clock.lo time.lo transpose_generic.lo tty.lo umask.lo \
>! 	unlink.lo unpack_generic.lo in_pack_generic.lo \
>  	in_unpack_generic.lo
>  am__objects_31 =
>  am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
>--- 167,178 ----
>  	eoshift2.lo etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo \
>  	gerror.lo getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo \
>  	kill.lo ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
>! 	move_alloc.lo pack_generic.lo perror.lo signal.lo size.lo \
>! 	sleep.lo spread_generic.lo string_intrinsics.lo system.lo \
>! 	rand.lo random.lo rename.lo reshape_generic.lo \
>! 	reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
>! 	stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
>! 	tty.lo umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
>  	in_unpack_generic.lo
>  am__objects_31 =
>  am__objects_32 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
>*************** AUTOHEADER = @AUTOHEADER@
>*** 264,269 ****
>--- 264,270 ----
>  AUTOMAKE = @AUTOMAKE@
>  AWK = @AWK@
>  CC = @CC@
>+ CFLAGS = @CFLAGS@
>  CPP = @CPP@
>  CPPFLAGS = @CPPFLAGS@
>  CYGPATH_W = @CYGPATH_W@
>*************** EXEEXT = @EXEEXT@
>*** 276,281 ****
>--- 277,283 ----
>  FC = @FC@
>  FCFLAGS = @FCFLAGS@
>  FPU_HOST_HEADER = @FPU_HOST_HEADER@
>+ GREP = @GREP@
>  INSTALL_DATA = @INSTALL_DATA@
>  INSTALL_PROGRAM = @INSTALL_PROGRAM@
>  INSTALL_SCRIPT = @INSTALL_SCRIPT@
>*************** SET_MAKE = @SET_MAKE@
>*** 303,314 ****
>  SHELL = @SHELL@
>  STRIP = @STRIP@
>  VERSION = @VERSION@
>- ac_ct_AR = @ac_ct_AR@
>- ac_ct_AS = @ac_ct_AS@
>  ac_ct_CC = @ac_ct_CC@
>  ac_ct_FC = @ac_ct_FC@
>- ac_ct_RANLIB = @ac_ct_RANLIB@
>- ac_ct_STRIP = @ac_ct_STRIP@
>  am__leading_dot = @am__leading_dot@
>  am__tar = @am__tar@
>  am__untar = @am__untar@
>--- 305,312 ----
>*************** build_os = @build_os@
>*** 321,326 ****
>--- 319,327 ----
>  build_subdir = @build_subdir@
>  build_vendor = @build_vendor@
>  datadir = @datadir@
>+ datarootdir = @datarootdir@
>+ docdir = @docdir@
>+ dvidir = @dvidir@
>  enable_shared = @enable_shared@
>  enable_static = @enable_static@
>  exec_prefix = @exec_prefix@
>*************** host_cpu = @host_cpu@
>*** 331,348 ****
>--- 332,353 ----
>  host_os = @host_os@
>  host_subdir = @host_subdir@
>  host_vendor = @host_vendor@
>+ htmldir = @htmldir@
>  includedir = @includedir@
>  infodir = @infodir@
>  install_sh = @install_sh@
>  libdir = @libdir@
>  libexecdir = @libexecdir@
>+ localedir = @localedir@
>  localstatedir = @localstatedir@
>  mandir = @mandir@
>  mkdir_p = @mkdir_p@
>  multi_basedir = @multi_basedir@
>  oldincludedir = @oldincludedir@
>+ pdfdir = @pdfdir@
>  prefix = @prefix@
>  program_transform_name = @program_transform_name@
>+ psdir = @psdir@
>  sbindir = @sbindir@
>  sharedstatedir = @sharedstatedir@
>  sysconfdir = @sysconfdir@
>*************** intrinsics/ishftc.c \
>*** 418,423 ****
>--- 423,429 ----
>  intrinsics/link.c \
>  intrinsics/malloc.c \
>  intrinsics/mvbits.c \
>+ intrinsics/move_alloc.c \
>  intrinsics/pack_generic.c \
>  intrinsics/perror.c \
>  intrinsics/signal.c \
>*************** malloc.lo: intrinsics/malloc.c
>*** 2304,2309 ****
>--- 2310,2318 ----
>  mvbits.lo: intrinsics/mvbits.c
>  	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
>  
>+ move_alloc.lo: intrinsics/move_alloc.c
>+ 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o move_alloc.lo `test -f 'intrinsics/move_alloc.c' || echo '$(srcdir)/'`intrinsics/move_alloc.c
>+ 
>  pack_generic.lo: intrinsics/pack_generic.c
>  	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
>  
>Index: libgfortran/intrinsics/move_alloc.c
>===================================================================
>*** libgfortran/intrinsics/move_alloc.c	(revision 0)
>--- libgfortran/intrinsics/move_alloc.c	(revision 0)
>***************
>*** 0 ****
>--- 1,67 ----
>+ /* Generic implementation of the MOVE_ALLOC intrinsic
>+    Copyright (C) 2006 Free Software Foundation, Inc.
>+    Contributed by Paul Thomas
>+ 
>+ This file is part of the GNU Fortran 95 runtime library (libgfortran).
>+ 
>+ Libgfortran is free software; you can redistribute it and/or
>+ modify it under the terms of the GNU General Public
>+ License as published by the Free Software Foundation; either
>+ version 2 of the License, or (at your option) any later version.
>+ 
>+ In addition to the permissions in the GNU General Public License, the
>+ Free Software Foundation gives you unlimited permission to link the
>+ compiled version of this file into combinations with other programs,
>+ and to distribute those combinations without any restriction coming
>+ from the use of this file.  (The General Public License restrictions
>+ do apply in other respects; for example, they cover modification of
>+ the file, and distribution when not linked into a combine
>+ executable.)
>+ 
>+ Ligbfortran is distributed in the hope that it will be useful,
>+ but WITHOUT ANY WARRANTY; without even the implied warranty of
>+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
>+ GNU General Public License for more details.
>+ 
>+ You should have received a copy of the GNU General Public
>+ License along with libgfortran; see the file COPYING.  If not,
>+ write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
>+ Boston, MA 02110-1301, USA.  */
>+ 
>+ #include "libgfortran.h"
>+ 
>+ extern void move_alloc (gfc_array_char *, gfc_array_char *);
>+ export_proto(move_alloc);
>+ 
>+ void
>+ move_alloc (gfc_array_char * from, gfc_array_char * to)
>+ {
>+   int i;
>+ 
>+   internal_free (to->data);
>+ 
>+   for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
>+     {
>+       to->dim[i].lbound = from->dim[i].lbound;
>+       to->dim[i].ubound = from->dim[i].ubound;
>+       to->dim[i].stride = from->dim[i].stride;
>+       from->dim[i].stride = 0;
>+       from->dim[i].ubound = from->dim[i].lbound;
>+     }
>+ 
>+   to->offset = from->offset;
>+   to->dtype = from->dtype;
>+   to->data = from->data;
>+   from->data = NULL;
>+ }
>+ 
>+ extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4,
>+ 			  gfc_array_char *, GFC_INTEGER_4);
>+ export_proto(move_alloc_c);
>+ 
>+ void
>+ move_alloc_c (gfc_array_char * from, GFC_INTEGER_4 from_length __attribute__((unused)),
>+ 	      gfc_array_char * to, GFC_INTEGER_4 to_length __attribute__((unused)))
>+ {
>+   move_alloc (from, to);
>+ }
>Index: libgfortran/Makefile.am
>===================================================================
>*** libgfortran/Makefile.am	(revision 117054)
>--- libgfortran/Makefile.am	(working copy)
>*************** intrinsics/ishftc.c \
>*** 74,79 ****
>--- 74,80 ----
>  intrinsics/link.c \
>  intrinsics/malloc.c \
>  intrinsics/mvbits.c \
>+ intrinsics/move_alloc.c \
>  intrinsics/pack_generic.c \
>  intrinsics/perror.c \
>  intrinsics/signal.c \
>Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,57 ----
>+ ! { dg-do run }
>+ ! Test assignments of derived type with allocatable components (PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+   type :: ivs
>+     character(1), allocatable :: chars(:)
>+   end type ivs
>+ 
>+   type(ivs) :: a, b
>+   type(ivs) :: x(3), y(3)
>+   
>+   allocate(a%chars(5))
>+   a%chars = (/"h","e","l","l","o"/)
>+ 
>+ ! An intrinsic assignment must deallocate the l-value and copy across
>+ ! the array from the r-value.
>+   b = a
>+   if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
>+   if (allocated (a%chars) .eqv. .false.) call abort ()
>+ 
>+ ! Scalar to array needs to copy the derived type, to its ultimate components,
>+ ! to each of the l-value elements.  */
>+   x = b
>+   x(2)%chars = (/"g","'","d","a","y"/)
>+   if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
>+   if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (allocated (b%chars) .eqv. .false.) call abort ()
>+   deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
>+ 
>+ ! Array intrinsic assignments are like their scalar counterpart and
>+ ! must deallocate each element of the l-value and copy across the
>+ ! arrays from the r-value elements.
>+   allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
>+   x(1)%chars = (/"h","e","l","l","o"/)
>+   x(2)%chars = (/"g","'","d","a","y"/)
>+   x(3)%chars = (/"g","o","d","a","g"/)
>+   y(2:1:-1) = x(1:2)
>+   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
>+   if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
>+ 
>+ ! In the case of an assignment where there is a dependency, so that a
>+ ! temporary is necessary, each element must be copied to its
>+ ! destination after it has been deallocated.
>+   y(2:3) = y(1:2)
>+   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
>+ 
>+ ! An identity assignment must not do any deallocation....!
>+   y = y
>+   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
>+   if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
>+ end
>Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_assign_2.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,50 ----
>+ ! { dg-do run }
>+ ! Test FORALL and WHERE with derived types with allocatable components (PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+   type :: a
>+     integer, allocatable :: i(:)
>+   end type a
>+ 
>+   type :: b
>+     type (a), allocatable :: at(:)
>+   end type b
>+ 
>+   type(a) :: x(2)
>+   type(b) :: y(2)
>+   integer i, m(4)
>+ 
>+   x(1) = a((/1,2,3,4/))
>+   x(2) = a((/1,2,3,4/)+10)
>+ 
>+   forall (j=1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10)  x(j)%i(i) =  j*4-i
>+ 
>+   if (any ((/((x(i)%i(j), j= 1,4), i=1,2)/) .ne. &
>+           (/1,2,1,0,11,12,5,4/))) call abort ()
>+ 
>+   y(1) = b((/x(1),x(2)/))
>+   y(2) = b((/x(2),x(1)/))
>+ 
>+   forall (k=1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10 )
>+     y(k)%at(j)%i(i) =  j*4-i+k
>+   end forall
>+ 
>+   if (any((/(((y(k)%at(i)%i(j), j= 1,4), i=1,2), k =1,2)/) .ne. &
>+          (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () 
>+ 
>+   where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0
>+ 
>+   if (any((/(((y(k)%at(i)%i(j), j= 1,4), i=1,2), k =1,2)/) .ne. &
>+          (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) call abort () 
>+ 
>+   where (y((2))%at(:)%i(2) > 8)
>+     y(2)%at(:)%i(2) = 77
>+   end where
>+ 
>+   if (any((/(((y(k)%at(i)%i(j), j= 1,4), i=1,2), k =1,2)/) .ne. &
>+          (/0,0,2,1,11,12,6,5,11,77,3,2,9,8,7,6/))) call abort ()
>+ 
>+ 
>+ end
>Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_assign_3.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,36 ----
>+ ! { dg-do run }
>+ ! Test assignments of nested derived types with allocatable components(PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+   type :: a
>+     integer, allocatable :: i(:)
>+   end type a
>+ 
>+   type :: b
>+     type (a), allocatable :: at(:)
>+   end type b
>+ 
>+   type(a) :: x(2)
>+   type(b) :: y(2), z(2)
>+   integer i, m(4)
>+ 
>+   x(1) = a((/1,2,3,4/))
>+   x(2) = a((/1,2,3,4/)+10)
>+ 
>+   y(1) = b((/x(1),x(2)/))
>+   y(2) = b((/x(2),x(1)/))
>+ 
>+   y(2) = y(1)
>+   forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) &
>+                              y(1)%at(j)%i(k) = 999
>+   if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) call abort ()
>+ 
>+ 
>+   z = y
>+   forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) &
>+                              z(i)%at(j)%i(k) = 999
>+   if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) call abort ()
>+ 
>+ end
>Index: gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_initializer_1.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,55 ----
>+ ! { dg-do run }
>+ ! This checks the correct functioning of derived types with default initializers
>+ ! and allocatable components.
>+ !
>+ ! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
>+ !
>+ module p_type_mod
>+ 
>+   type m_type
>+     integer, allocatable :: p(:)
>+   end type m_type
>+ 
>+   type basep_type
>+     type(m_type), allocatable :: av(:)
>+     type(m_type), pointer :: ap => null ()
>+     integer :: i = 101
>+   end type basep_type
>+ 
>+   type p_type
>+     type(basep_type), allocatable :: basepv(:)
>+     integer :: p1 , p2 = 1
>+   end type p_type
>+ end module p_type_mod
>+ 
>+ program foo
>+  
>+  use p_type_mod
>+   implicit none
>+ 
>+   type(m_type), target :: a
>+   type(p_type) :: pre
>+   type(basep_type) :: wee
>+ 
>+   a = m_type ((/101,102/))  
>+ 
>+   call p_bld (a, pre)
>+ 
>+   if (associated (wee%ap) .or. wee%i /= 101) call abort ()
>+   wee%ap => a
>+   if (.not.associated (wee%ap) .or. allocated (wee%av)) call abort ()
>+   wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99)
>+   if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) call abort () 
>+ 
>+ contains
>+ 
>+     subroutine p_bld (a, p)
>+       use p_type_mod
>+       type (m_type) :: a
>+       type(p_type) :: p
>+       if (any (a%p .ne. (/101,102/))) call abort ()
>+       if (allocated (p%basepv) .or. (p%p2 .ne. 1)) call abort ()
>+     end subroutine p_bld
>+ 
>+ end program foo
>+ ! { dg-final { cleanup-modules "p_type_mod" } }
>Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,108 ----
>+ ! { dg-do run }
>+ ! { dg-options "-fdump-tree-original" }
>+ ! Test constructors of derived type with allocatable components (PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+ 
>+ Program test_constructor
>+ 
>+     implicit none
>+ 
>+     type :: thytype
>+         integer(4) :: a(2,2)
>+     end type thytype
>+ 
>+     type :: mytype
>+         integer(4), allocatable :: a(:, :)
>+         type(thytype), allocatable :: q(:)
>+     end type mytype
>+ 
>+     type (mytype) :: x
>+     type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
>+     integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
>+     integer, allocatable :: yy(:,:)
>+     type (thytype), allocatable :: bar(:)
>+     integer :: i
>+ 
>+     ! Check that null() works
>+     x = mytype(null(), null())
>+     if (allocated(x%a) .or. allocated(x%q)) call abort()
>+ 
>+     ! Check that unallocated allocatables work
>+     x = mytype(yy, bar)
>+     if (allocated(x%a) .or. allocated(x%q)) call abort()
>+ 
>+     ! Check that non-allocatables work
>+     x = mytype(y, [foo, foo])
>+     if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
>+     if (any(lbound(x%a) /= lbound(y))) call abort()
>+     if (any(ubound(x%a) /= ubound(y))) call abort()
>+     if (any(x%a /= y)) call abort()
>+     if (size(x%q) /= 2) call abort()
>+     do i = 1, 2
>+         if (any(x%q(i)%a /= foo%a)) call abort()
>+     end do
>+ 
>+     ! Check that allocated allocatables work
>+     allocate(yy(size(y,1), size(y,2)))
>+     yy = y
>+     allocate(bar(2))
>+     bar = [foo, foo]
>+     x = mytype(yy, bar)
>+     if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
>+     if (any(x%a /= y)) call abort()
>+     if (size(x%q) /= 2) call abort()
>+     do i = 1, 2
>+         if (any(x%q(i)%a /= foo%a)) call abort()
>+     end do
>+ 
>+     ! Functions returning arrays
>+     x = mytype(bluhu(), null())
>+     if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
>+     if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
>+ 
>+     ! Functions returning allocatable arrays
>+     x = mytype(blaha(), null())
>+     if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
>+     if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
>+ 
>+     ! Check that passing the constructor to a procedure works
>+     call check_mytype (mytype(y, [foo, foo]))
>+ 
>+ contains
>+ 
>+     subroutine check_mytype(x)
>+         type(mytype), intent(in) :: x
>+         integer :: i
>+ 
>+         if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
>+         if (any(lbound(x%a) /= lbound(y))) call abort()
>+         if (any(ubound(x%a) /= ubound(y))) call abort()
>+         if (any(x%a /= y)) call abort()
>+         if (size(x%q) /= 2) call abort()
>+         do i = 1, 2
>+             if (any(x%q(i)%a /= foo%a)) call abort()
>+         end do
>+ 
>+     end subroutine check_mytype
>+ 
>+ 
>+     function bluhu()
>+         integer :: bluhu(2,2)
>+ 
>+         bluhu = reshape ([41, 98, 54, 76], [2,2])
>+     end function bluhu
>+ 
>+ 
>+     function blaha()
>+         integer, allocatable :: blaha(:,:)
>+ 
>+         allocate(blaha(2,2))
>+         blaha = reshape ([40, 97, 53, 75], [2,2])
>+     end function blaha
>+ 
>+ end program test_constructor
>+ ! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }
>+ ! { dg-final { cleanup-tree-dump "original" } }
>Index: gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_constructor_2.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,26 ----
>+ ! { dg-do run }
>+ ! Test constructors of nested derived types with allocatable components(PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+   type :: thytype
>+     integer(4), allocatable :: h(:)
>+   end type thytype
>+ 
>+   type :: mytype
>+     type(thytype), allocatable :: q(:)
>+   end type mytype
>+ 
>+   type (mytype) :: x
>+   type (thytype) :: w(2)
>+   integer :: y(2) =(/1,2/)
>+ 
>+   w = (/thytype(y), thytype (2*y)/)
>+   x = mytype (w)
>+   if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) call abort ()
>+ 
>+   x = mytype ((/thytype(3*y), thytype (4*y)/))
>+   if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) call abort ()
>+ 
>+ end
>Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,143 ----
>+ ! { dg-do run}
>+ ! { dg-options "-O2 -fdump-tree-original" }
>+ !
>+ ! Check some basic functionality of allocatable components, including that they
>+ ! are nullified when created and automatically deallocated when
>+ ! 1. A variable goes out of scope
>+ ! 2. INTENT(OUT) dummies
>+ ! 3. Function results
>+ !
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+ module alloc_m
>+ 
>+     implicit none
>+ 
>+     type :: alloc1
>+         real, allocatable :: x(:)
>+     end type alloc1
>+ 
>+ end module alloc_m
>+ 
>+ 
>+ program alloc
>+ 
>+     use alloc_m
>+ 
>+     implicit none
>+ 
>+     type :: alloc2
>+         type(alloc1), allocatable :: a1(:)
>+         integer, allocatable :: a2(:)
>+     end type alloc2
>+ 
>+     type(alloc2) :: b
>+     integer :: i
>+     type(alloc2), allocatable :: c(:)
>+ 
>+     if (allocated(b%a2) .OR. allocated(b%a1)) then
>+         write (0, *) 'main - 1'
>+         call abort()
>+     end if
>+ 
>+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
>+     call allocate_alloc2(b)
>+     call check_alloc2(b)
>+ 
>+     do i = 1, size(b%a1)
>+         ! 1 call to _gfortran_deallocate
>+         deallocate(b%a1(i)%x)
>+     end do
>+ 
>+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
>+     call allocate_alloc2(b)
>+ 
>+     call check_alloc2(return_alloc2())
>+     ! 3 calls to _gfortran_deallocate (function result)
>+ 
>+     allocate(c(1))
>+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
>+     call allocate_alloc2(c(1))
>+     ! 4 calls to _gfortran_deallocate
>+     deallocate(c)
>+ 
>+     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
>+ 
>+ contains
>+ 
>+     subroutine allocate_alloc2(b)
>+         type(alloc2), intent(out) :: b
>+         integer :: i
>+ 
>+         if (allocated(b%a2) .OR. allocated(b%a1)) then
>+             write (0, *) 'allocate_alloc2 - 1'
>+             call abort()
>+         end if
>+ 
>+         allocate (b%a2(3))
>+         b%a2 = [ 1, 2, 3 ]
>+ 
>+         allocate (b%a1(3))
>+ 
>+         do i = 1, 3
>+             if (allocated(b%a1(i)%x)) then
>+                 write (0, *) 'allocate_alloc2 - 2', i
>+                 call abort()
>+             end if
>+             allocate (b%a1(i)%x(3))
>+             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
>+         end do
>+ 
>+     end subroutine allocate_alloc2
>+ 
>+ 
>+     type(alloc2) function return_alloc2() result(b)
>+         if (allocated(b%a2) .OR. allocated(b%a1)) then
>+             write (0, *) 'return_alloc2 - 1'
>+             call abort()
>+         end if
>+ 
>+         allocate (b%a2(3))
>+         b%a2 = [ 1, 2, 3 ]
>+ 
>+         allocate (b%a1(3))
>+ 
>+         do i = 1, 3
>+             if (allocated(b%a1(i)%x)) then
>+                 write (0, *) 'return_alloc2 - 2', i
>+                 call abort()
>+             end if
>+             allocate (b%a1(i)%x(3))
>+             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
>+         end do
>+     end function return_alloc2
>+ 
>+ 
>+     subroutine check_alloc2(b)
>+         type(alloc2), intent(in) :: b
>+ 
>+         if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
>+             write (0, *) 'check_alloc2 - 1'
>+             call abort()
>+         end if
>+         if (any(b%a2 /= [ 1, 2, 3 ])) then
>+             write (0, *) 'check_alloc2 - 2'
>+             call abort()
>+         end if
>+         do i = 1, 3
>+             if (.NOT.allocated(b%a1(i)%x)) then
>+                 write (0, *) 'check_alloc2 - 3', i
>+                 call abort()
>+             end if
>+             if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
>+                 write (0, *) 'check_alloc2 - 4', i
>+                 call abort()
>+             end if
>+         end do
>+     end subroutine check_alloc2
>+ 
>+ end program alloc
>+ ! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
>+ ! { dg-final { cleanup-tree-dump "original" } }
>Index: gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90
>===================================================================
>*** gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90	(revision 0)
>--- gcc/testsuite/gfortran.dg/alloc_comp_basics_2.f90	(revision 0)
>***************
>*** 0 ****
>--- 1,39 ----
>+ ! { dg-do run }
>+ ! Check "double" allocations of allocatable components (PR 20541).
>+ !
>+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
>+ !            and Paul Thomas  <pault@gcc.gnu.org>
>+ !
>+ program main
>+ 
>+   implicit none
>+ 
>+   type foo
>+      integer, dimension(:), allocatable :: array
>+   end type foo
>+ 
>+   type(foo),allocatable,dimension(:) :: mol
>+   type(foo),pointer,dimension(:) :: molp
>+   integer :: i
>+ 
>+   allocate (mol(1))
>+   allocate (mol(1), stat=i)
>+   !print *, i  ! /= 0
>+   if (i == 0) call abort()
>+ 
>+   allocate (mol(1)%array(5))
>+   allocate (mol(1)%array(5),stat=i)
>+   !print *, i  ! /= 0
>+   if (i == 0) call abort()
>+ 
>+   allocate (molp(1))
>+   allocate (molp(1), stat=i)
>+   !print *, i  ! == 0
>+   if (i /= 0) call abort()
>+ 
>+   allocate (molp(1)%array(5))
>+   allocate (molp(1)%array(5),stat=i)
>+   !print *, i  ! /= 0
>+   if (i == 0) call abort()
>+ 
>+ end program main

Actions: View | Diff

Attachments on bug 20541: 11867 | 11871 | 11910 | 11975 | 12049 | 12060 | 12106 | 12313 | 12320 | 12350 | 12354 | 12373