This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR20541 - allocatable components (TR15541)


:ADDPATCH:

This patch implements the part of TR15541 that is concerned with allocatable components of derived types. This extension to the F95 standard offers three important advantages over pointer components:

(i) Automatic deallocation of memory upon going out of scope;
(ii)The automatic handling of allocation and copying of data in assignements of derived types with allocatable components; and
(iii) Performance advantages through the automatic transfer of allocated resources.


In the end, we have concentrated on (i) and (ii) and rather less on (iii). This is a starting point and it will be worthwhile looking for opportunities to avoid copying and freeing, which undoubtedly occurs at present.

The reason for (i) and (ii) is to ensure automatically that there is no memory leakage. To the best of our ability, we have checked that this is so but would appreciate users supplying us with evidence to the contrary.

It was not entirely intended, at the start, that the bulk of the patch be in the translation stage. Instead, we had the idea that some master library functions could do most of the work. This initial idea was not overthrown by plan but rather because the initial demonstrations of feasibility and the establishment of the framework all were done in trans-XXXX.c. One area that could be improved, by returning to the original concept, is that of deallocation on leaving scope. It would be effective to traverse a list of allocated resources, rather than checking all the allocatable components, whether allocated or not. Equally though, since the code is all inline it is quite quick.

The patch has become rather substantial for which we apologise to the reviewer(s). If it is any consolation, neither of us would have started upon this project had we appreciated what would be involved!

It should be noted that a couple of other PRs have been cleared up in the course of developing this patch and that several incipient but unreported problems have also been dealt with. These are:

(i) PR29098, which involves ICEs resulting from default initializers with components that are not set
http://gcc.gnu.org/ml/gcc-patches/2006-09/msg00671.html (Fixed on trunk);
(ii) PR29211, which is associated with character assignments with depencies, in FORALL statements or blocks, causing ICEs (Bundled in here);
(iii) Derived type constructors with array components had no checks for compliance, even of rank - ie. the constructor elements should either be scalar of have the same rank as the component;
(iv) A failure of derived type association (groan!) that seems to be specific to derived types with allocatable components had to be sorted out; and
(v) The F2003 intrinsic MOVE_ALLOC has been implemented.


PR29115 was uncovered and fixed in the course of rather intensive work on derived type constructors - it is also included here because it became intimately intermingled with the main patch

Much of the patch consists of fairly mundane housekeeping or enabling bits and pieces. It is not really worth covering those here and you are referred to the patch, the ChangeLog and the patched code for these, since they are relatively simple and clear.

The major action occurs in trans-array.c, trans-decl.c and trans-expr.c:

(i) trans-array.c

The patch to this file is mostly associated with the deallocation, nullification and copying of derived types with allocatable components. Life is made relatively easy by the arrays being whole and packed. Thus, obtaining the size of and accessing all the components of the allocatable arrays is very straight forward.

Three interface functions call a single multi-purpose, recursive function structure_alloc_comps. This has to be recursive to handle components that are themselves derived types with allocatable components. The code branches between scalars and arrays. The latter are handled using a helper function to obtain the array size and looping, to make recursive calls to treat the allocatable components, using bits of the scalarizer. The scalar section does the actual business of deallocation, nullification and copying.

The rest of the modifications to this file are relatively minor.

(ii) trans-decl.c

The code modification to this file is small. Instead much of the marshalling of the derived types with allocatable components is done here; specifically by adding these beasts to the list of "deferred_variables", which marks them for automatic nullifcation and deallocation, on scope entry and exit. Similarly nullification of function results with allocatable components is done here.

(iii) trans-expr.c

This file contains nearly all the modifications needed for assignement and derived type constructors. These modifications are all associated with memory management; ensuring that the resources are copied or transferred, as necessary.

The handling of assignments requires the addition of an extra block within gfc_trans_scalar_assign and two new arguments. Under the control of these latter, which indicate that the lhs is a temporary or the rhs is a variable, deallocation of the lhs and copying/transfer of the rhs data are done.

As well as the assignment calls form within trans-expr.c, trans-stmt.c is a big user because of the special ssignments made within FORALL and WHERE blocks.


The testsuite additions check most of the major features of allocatable components, although we have no doubt that future PRs in this are will expose the need for more! They are all commented as to their purpose and serve as a useful template of the capabilities of this extra feature.



The patch has been extensively tested and we thank Salvatore Filippone and Steve Kargl for their efforts; Salvatore for doing his best as the "Patch Buster"(We'll have to buy him a 50's Buick... ) and Steve for checking that allocatable components do not break anything else. We are grateful to a number of the other "usual suspects", such as Jerry DeLisle and Jack Howarth, who have added vocal support and tests over a range of platforms.


It is important to realise that this patch is mostly insulated from the rest of Fortran95, behind if statements that require objects with allocatable components. We are reasonably sure, thanks to Steve's and our own efforts, that we have tested that this is the case. However, uttering that thought is an invitation to be proven wrong! The most serious breach of this "insulation" is the small change to derived type association in trans_types.c. After the previous experience, one of us will be watching this part like a hawk!

Steve has suggested an extra compiler option to go with -std=f95; add an -fenable-tr15541 option. We will undertake to do this but not right away; we have to get reaquainted with our families and friends.

We hope that this extension proves to be useful and that the bugs that are almost certainly there will trickle in at a managable pace!

Regtested a silly number of times on a wide range of platforms and OS's (in the last 24 hours: SUSE10.1/AMD64, FC5/Athlon1700 and Cygwin_NT/PIV) - OK for trunk?

Phew!

Erik and Paul

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

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

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


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


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

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



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

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

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

	PR fortran/29211
	* gfortran.dg/forall_char_dependencies_1.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 117440)
--- 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 117440)
--- 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-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 117440)
--- gcc/fortran/trans-expr.c	(working copy)
*************** 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
*** 2050,2055 ****
--- 2056,2104 ----
        gfc_add_block_to_block (&se->pre, &parmse.pre);
        gfc_add_block_to_block (&post, &parmse.post);
  
+       /* Allocated allocatable components of derived types must be
+ 	 deallocated for INTENT(OUT) dummy arguments and non-variable
+          scalars.  Non-variable arrays are dealt with in trans-array.c
+          (gfc_conv_array_parameter).  */
+       if (e && e->ts.type == BT_DERIVED
+ 	    && e->ts.derived->attr.alloc_comp
+ 	    && ((formal && formal->sym->attr.intent == INTENT_OUT)
+ 		   ||
+ 		(e->expr_type != EXPR_VARIABLE && !e->rank)))
+         {
+ 	  int parm_rank;
+ 	  tmp = build_fold_indirect_ref (parmse.expr);
+ 	  parm_rank = e->rank;
+ 	  switch (parm_kind)
+ 	    {
+ 	    case (ELEMENTAL):
+ 	    case (SCALAR):
+ 	      parm_rank = 0;
+ 	      break;
+ 
+ 	    case (SCALAR_POINTER):
+               tmp = build_fold_indirect_ref (tmp);
+ 	      break;
+ 	    case (ARRAY):
+               tmp = parmse.expr;
+ 	      break;
+ 	    }
+ 
+           tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ 	  if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
+ 	    tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
+ 			    tmp, build_empty_stmt ());
+ 
+ 	  if (e->expr_type != EXPR_VARIABLE)
+ 	    /* Don't deallocate non-variables until they have been used.  */
+ 	    gfc_add_expr_to_block (&se->post, tmp);
+ 	  else 
+ 	    {
+ 	      gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
+ 	      gfc_add_expr_to_block (&se->pre, tmp);
+ 	    }
+         }
+ 
        /* Character strings are passed as two parameters, a length and a
           pointer.  */
        if (parmse.string_length != NULL_TREE)
*************** gfc_trans_subarray_assign (tree dest, gf
*** 2636,2642 ****
  
    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);
--- 2685,2691 ----
  
    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
*** 2657,2673 ****
--- 2706,2727 ----
    return gfc_finish_block (&block);
  }
  
+ 
  /* Assign a single component of a derived type constructor.  */
  
  static tree
  gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
  {
    gfc_se se;
+   gfc_se lse;
    gfc_ss *rss;
    stmtblock_t block;
    tree tmp;
+   tree offset;
+   int n;
  
    gfc_start_block (&block);
+ 
    if (cm->pointer)
      {
        gfc_init_se (&se, NULL);
*************** gfc_trans_subcomponent_assign (tree dest
*** 2700,2707 ****
      }
    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)
      {
--- 2754,2821 ----
      }
    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
*** 2722,2729 ****
    else
      {
        /* Scalar component.  */
-       gfc_se lse;
- 
        gfc_init_se (&se, NULL);
        gfc_init_se (&lse, NULL);
  
--- 2836,2841 ----
*************** gfc_trans_subcomponent_assign (tree dest
*** 2731,2737 ****
        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);
--- 2843,2849 ----
        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_conv_structure (gfc_se * se, gfc_exp
*** 2791,2800 ****
      }
  
    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,
--- 2903,2916 ----
      }
  
    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.  Although the latter have a default initializer
! 	 of EXPR_NULL,... by default, the static nullify is not needed
! 	 since this is done every time we come into scope.  */
!       if (!c->expr || cm->allocatable)
          continue;
  
        val = gfc_conv_initializer (c->expr, &cm->ts,
*************** gfc_conv_string_parameter (gfc_se * se)
*** 3089,3104 ****
  
  
  /* 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);
--- 3205,3223 ----
  
  
  /* 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
*** 3112,3117 ****
--- 3231,3280 ----
        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, 
*** 3217,3222 ****
--- 3380,3386 ----
    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, 
*** 3295,3304 ****
    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);
--- 3459,3470 ----
    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, 
*** 3306,3312 ****
    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)
--- 3472,3479 ----
    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, 
*** 3319,3325 ****
        gcc_assert (lse.ss == gfc_ss_terminator
  		  && rse.ss == gfc_ss_terminator);
  
!       if (loop.temp_ss != NULL)
  	{
  	  gfc_trans_scalarized_loop_boundary (&loop, &body);
  
--- 3486,3492 ----
        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, 
*** 3339,3347 ****
  	  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);
  
--- 3506,3515 ----
  	  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/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 117440)
--- 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,3328 ----
    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 ****
--- 3463,3471 ----
          }
        break;
  
+     case EXPR_NULL:
+       return gfc_build_null_descriptor (type);
+ 
      default:
        gcc_unreachable ();
      }
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 4547,4552 ****
--- 4548,4564 ----
    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)
--- 4607,4928 ----
  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)
! 	    {
! 	      rank = c->as ? c->as->rank : 0;
! 	      tmp = fold_convert (TREE_TYPE (dcmp), comp);
! 	      gfc_add_modify_expr (&fnblock, dcmp, tmp);
! 	      tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
! 					   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))
--- 4932,4953 ----
    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);
--- 4968,4977 ----
    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);
--- 4980,5019 ----
  
    /* 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/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 117440)
--- 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/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 117440)
--- 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)
*** 1284,1289 ****
--- 1301,1314 ----
  	}
      }
  
+   if (initializer != NULL && current_attr.allocatable
+ 	&& gfc_current_state () == COMP_DERIVED)
+     {
+       gfc_error ("Initialization of allocatable component at %C is not allowed");
+       m = MATCH_ERROR;
+       goto cleanup;
+     }
+ 
    /* Check if we are parsing an enumeration and if the current enumerator
       variable has an initializer or not. If it does not have an
       initializer, the initialization value of the previous enumerator 
*************** 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);
      }
--- 1340,1348 ----
      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);
      }
*************** 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)
--- 2167,2190 ----
  	  && 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/intrinsic.h
===================================================================
*** gcc/fortran/intrinsic.h	(revision 117440)
--- 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/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 117440)
--- 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.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 117440)
--- 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
*** 1971,1976 ****
--- 1974,1980 ----
  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 117440)
--- 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,1809 ----
        gfc_conv_expr (&lse, expr);
  
        /* Use the scalar assignment.  */
!       rse.string_length = lse.string_length;
!       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)
--- 1898,1906 ----
      }
  
    /* Use the scalar assignment.  */
!   lse.string_length = rse.string_length;
!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
! 				 expr2->expr_type == EXPR_VARIABLE);
  
    /* 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);
--- 2981,2988 ----
      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);
  
--- 3035,3041 ----
  				    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);
--- 3410,3417 ----
          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 ****
--- 3595,3608 ----
  				 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 ****
--- 3687,3712 ----
        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/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 117440)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_default_initializer (gfc_typespec *t
*** 2406,2412 ****
    /* See if we have a default initializer.  */
    for (c = ts->derived->components; c; c = c->next)
      {
!       if (c->initializer && init == NULL)
          init = gfc_get_expr ();
      }
  
--- 2406,2412 ----
    /* See if we have a default initializer.  */
    for (c = ts->derived->components; c; c = c->next)
      {
!       if ((c->initializer || c->allocatable) && init == NULL)
          init = gfc_get_expr ();
      }
  
*************** gfc_default_initializer (gfc_typespec *t
*** 2430,2435 ****
--- 2430,2442 ----
  
        if (c->initializer)
          tail->expr = gfc_copy_expr (c->initializer);
+ 
+       if (c->allocatable)
+ 	{
+ 	  tail->expr = gfc_get_expr ();
+ 	  tail->expr->expr_type = EXPR_NULL;
+ 	  tail->expr->ts = c->ts;
+ 	}
      }
    return init;
  }
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 117440)
--- 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 *
*** 1555,1560 ****
--- 1556,1563 ----
  	MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
        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 ****
--- 1647,1655 ----
  	    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 ****
--- 1957,1963 ----
  
    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 117440)
--- gcc/fortran/trans-types.c	(working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1486,1497 ****
        /* Derived types in an interface body obtain their parent reference
  	 through the proc_name symbol.  */
        ns = derived->ns->parent ? derived->ns->parent
! 			       : derived->ns->proc_name->ns->parent;
  
        for (; ns; ns = ns->parent)
  	{
  	  for (dt = ns->derived_types; dt; dt = dt->next)
  	    {
  	      if (dt->derived->backend_decl == NULL
  		    && gfc_compare_derived_types (dt->derived, derived))
  		gfc_get_derived_type (dt->derived);
--- 1486,1500 ----
        /* Derived types in an interface body obtain their parent reference
  	 through the proc_name symbol.  */
        ns = derived->ns->parent ? derived->ns->parent
! 			       : derived->ns->proc_name->ns;
  
        for (; ns; ns = ns->parent)
  	{
  	  for (dt = ns->derived_types; dt; dt = dt->next)
  	    {
+ 	      if (dt->derived == derived)
+ 		continue;
+ 
  	      if (dt->derived->backend_decl == NULL
  		    && gfc_compare_derived_types (dt->derived, derived))
  		gfc_get_derived_type (dt->derived);
*************** 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.  */
--- 1553,1559 ----
           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 117440)
--- 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 117440)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_structure_cons (gfc_expr * expr)
*** 593,598 ****
--- 593,599 ----
    gfc_constructor *cons;
    gfc_component *comp;
    try t;
+   symbol_attribute a;
  
    t = SUCCESS;
    cons = expr->value.constructor;
*************** resolve_structure_cons (gfc_expr * expr)
*** 615,620 ****
--- 616,632 ----
  	  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.  */
  
        if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
*************** resolve_structure_cons (gfc_expr * expr)
*** 629,634 ****
--- 641,659 ----
  	  else
  	    t = gfc_convert_type (cons->expr, &comp->ts, 1);
  	}
+ 
+       if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ 	continue;
+ 
+       a = gfc_expr_attr (cons->expr);
+ 
+       if (!a.pointer && !a.target)
+ 	{
+ 	  t = FAILURE;
+ 	  gfc_error ("The element in the derived type constructor at %L, "
+ 		     "for pointer component '%s' should be a POINTER or "
+ 		     "a TARGET", &cons->expr->where, comp->name);
+ 	}
      }
  
    return t;
*************** find_sym_in_expr (gfc_symbol *sym, gfc_e
*** 3394,3400 ****
  
  /* 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)
--- 3419,3426 ----
  
  /* 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
*** 3518,3525 ****
          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;
      }
--- 3544,3550 ----
          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)
*** 4150,4155 ****
--- 4175,4187 ----
  	  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)
*** 5531,5537 ****
  	    }
  	}
  
!       if (c->pointer || c->as == NULL)
  	continue;
  
        for (i = 0; i < c->as->rank; i++)
--- 5563,5569 ----
  	    }
  	}
  
!       if (c->pointer || c->allocatable ||  c->as == NULL)
  	continue;
  
        for (i = 0; i < c->as->rank; i++)
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 5592,5607 ****
  	}
      }
  
!     /* Reject namelist arrays that are not constant shape.  */
!     for (nl = sym->namelist; nl; nl = nl->next)
!       {
! 	if (is_non_constant_shape_array (nl->sym))
! 	  {
! 	    gfc_error ("The array '%s' must have constant shape to be "
! 		       "a NAMELIST object at %L", nl->sym->name,
! 		       &sym->declared_at);
! 	    return FAILURE;
! 	  }
      }
  
    /* 14.1.2 A module or internal procedure represent local entities
--- 5624,5651 ----
  	}
      }
  
!   /* Reject namelist arrays that are not constant shape.  */
!   for (nl = sym->namelist; nl; nl = nl->next)
!     {
!       if (is_non_constant_shape_array (nl->sym))
! 	{
! 	  gfc_error ("The array '%s' must have constant shape to be "
! 		     "a NAMELIST object at %L", nl->sym->name,
! 		     &sym->declared_at);
! 	  return FAILURE;
! 	}
!     }
! 
!   /* Namelist objects cannot have allocatable components.  */
!   for (nl = sym->namelist; nl; nl = nl->next)
!     {
!       if (nl->sym->ts.type == BT_DERIVED
! 	    && nl->sym->ts.derived->attr.alloc_comp)
! 	{
! 	  gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
! 		     "components", nl->sym->name, &sym->declared_at);
! 	  return FAILURE;
! 	}
      }
  
    /* 14.1.2 A module or internal procedure represent local entities
*************** resolve_equivalence_derived (gfc_symbol 
*** 6356,6361 ****
--- 6400,6413 ----
        return FAILURE;
      }
  
+   /* Shall not have allocatable components. */
+   if (derived->attr.alloc_comp)
+     {
+       gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
+ 		 "components to be an EQUIVALENCE object",sym->name, &e->where);
+       return FAILURE;
+     }
+ 
    for (; c ; c = c->next)
      {
        d = c->ts.derived;
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 117440)
--- 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
*** 2560,2565 ****
--- 2563,2570 ----
  
    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
*** 2602,2614 ****
  	      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);
--- 2607,2624 ----
  	      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
*** 2960,2969 ****
--- 2970,2981 ----
    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
*** 3123,3129 ****
    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)
      {
--- 3135,3140 ----
*************** gfc_generate_function_code (gfc_namespac
*** 3138,3144 ****
        else
  	result = sym->result->backend_decl;
  
!       if (result == NULL_TREE)
  	warning (0, "Function return value not set");
        else
  	{
--- 3149,3166 ----
        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
*** 3149,3154 ****
--- 3171,3179 ----
  	  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 117440)
--- 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 117440)
--- 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 117440)
--- gcc/fortran/primary.c	(working copy)
*************** check_substring:
*** 1715,1721 ****
  symbol_attribute
  gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
  {
!   int dimension, pointer, target;
    symbol_attribute attr;
    gfc_ref *ref;
  
--- 1715,1721 ----
  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_
*** 1727,1732 ****
--- 1727,1733 ----
  
    dimension = attr.dimension;
    pointer = attr.pointer;
+   allocatable = attr.allocatable;
  
    target = attr.target;
    if (pointer)
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1747,1758 ****
  	    break;
  
  	  case AR_SECTION:
! 	    pointer = 0;
  	    dimension = 1;
  	    break;
  
  	  case AR_ELEMENT:
! 	    pointer = 0;
  	    break;
  
  	  case AR_UNKNOWN:
--- 1748,1759 ----
  	    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_
*** 1767,1784 ****
  	  *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;
--- 1768,1787 ----
  	  *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 117440)
--- 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 117440)
--- libgfortran/Makefile.in	(working copy)
*************** am__objects_30 = associated.lo abort.lo 
*** 169,180 ****
  	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 \
--- 169,180 ----
  	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 \
*************** intrinsics/ishftc.c \
*** 422,427 ****
--- 422,428 ----
  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
*** 2334,2339 ****
--- 2335,2343 ----
  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 117440)
--- 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_std.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_std.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_std.f90	(revision 0)
***************
*** 0 ****
--- 1,14 ----
+ ! { dg-do compile }
+ ! { dg-options "-std=f95" }
+ !
+ ! Check that we don't accept allocatable components for -std=f95 (PR 20541)
+ !
+ program main
+ 
+     type :: foo
+         integer, allocatable :: bar(:) ! { dg-error "ALLOCATABLE attribute" }
+ 
+         integer :: x ! Just to avoid "extra" error messages about empty type.
+     end type foo
+ 
+ end program main
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_constraint_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constraint_1.f90	(revision 0)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do compile }
+ ! Check that we don't allow IO or NAMELISTs with types with allocatable
+ ! components (PR 20541)
+ program main
+ 
+     type :: foo
+         integer, allocatable :: x(:)
+     end type foo
+ 
+     type :: bar
+         type(foo) :: x
+     end type bar
+ 
+     type(foo) :: a
+     type(bar) :: b
+     namelist /blah/ a ! { dg-error "cannot have ALLOCATABLE components" }
+ 
+     write (*, *) a  ! { dg-error "cannot have ALLOCATABLE components" }
+ 
+     read (*, *) b  ! { dg-error "cannot have ALLOCATABLE components" }
+ 
+ end program main
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,57 ----
+ ! { 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), z(2)
+   integer i, m(4)
+ 
+ ! Start with scalar and array element assignments in FORALL.
+ 
+   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 () 
+ 
+ ! Now simple assignments in WHERE.
+ 
+   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 ()
+ 
+ ! Check that temporaries and full array  alloctable component assignments
+ ! are correctly handled in FORALL.
+ 
+   x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/)
+   forall (i=1:2) y(i) = b ((/x(i)/))
+   forall (i=1:2) y(i) = y(3-i)      ! This needs a temporary.
+   forall (i=1:2) z(i) = y(i)
+   if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. &
+          (/(/5,6,7,8/),(/1,2,3,4/)/))) call abort ()
+ 
+ end
Index: gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_constraint_2.f90	(revision 0)
***************
*** 0 ****
--- 1,15 ----
+ ! { dg-do compile }
+ ! Check that equivalence with allocatable components isn't allowed (PR 20541)
+ program main
+ 
+     type :: foo
+         sequence
+         integer, allocatable :: x(:)
+     end type foo
+ 
+     type(foo) :: a
+     integer :: b
+ 
+     equivalence (a, b) ! { dg-error "cannot have ALLOCATABLE components" }
+ 
+ end program main
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/move_alloc.f90
===================================================================
*** gcc/testsuite/gfortran.dg/move_alloc.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/move_alloc.f90	(revision 0)
***************
*** 0 ****
--- 1,39 ----
+ ! { dg-do run }
+ ! Test the move_alloc intrinsic.
+ !
+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
+ !            and Paul Thomas  <pault@gcc.gnu.org>
+ !
+ program test_move_alloc
+ 
+     implicit none
+     integer, allocatable :: x(:), y(:), temp(:)
+     character(4), allocatable :: a(:), b(:)
+     integer :: i
+ 
+     allocate (x(2))
+     allocate (a(2))
+ 
+     x = [ 42, 77 ]
+ 
+     call move_alloc (x, y)
+     if (allocated(x)) call abort()
+     if (.not.allocated(y)) call abort()
+     if (any(y /= [ 42, 77 ])) call abort()
+ 
+     a = [ "abcd", "efgh" ]
+     call move_alloc (a, b)
+     if (allocated(a)) call abort()
+     if (.not.allocated(b)) call abort()
+     if (any(b /= [ "abcd", "efgh" ])) call abort()
+ 
+     ! Now one of the intended applications of move_alloc; resizing
+ 
+     call move_alloc (y, temp)
+     allocate (y(6), stat=i)
+     if (i /= 0) call abort()
+     y(1:2) = temp
+     y(3:) = 99
+     deallocate(temp)
+     if (any(y /= [ 42, 77, 99, 99, 99, 99 ])) call abort()
+ end program test_move_alloc
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,71 ----
+ ! { 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
+ 
+   call test_ab8 ()
+ 
+   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
+ 
+ ! Check that allocatable components are nullified after allocation.
+   subroutine test_ab8 ()
+     type(p_type)    :: p
+     integer :: ierr
+   
+     if (.not.allocated(p%basepv)) then 
+       allocate(p%basepv(1),stat=ierr)
+     endif
+     if (allocated (p%basepv) .neqv. .true.) call abort ()
+     if (allocated (p%basepv(1)%av) .neqv. .false.) call abort
+     if (p%basepv(1)%i .ne. 101) call abort ()
+ 
+   end subroutine test_ab8
+ 
+     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_assign_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_4.f90	(revision 0)
***************
*** 0 ****
--- 1,63 ----
+ ! { dg-do run }
+ ! Test assignments of nested derived types with character allocatable
+ ! components(PR 20541). Subroutine test_ab6 checks out a bug in a test
+ ! version of gfortran's allocatable arrays.
+ !
+ ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
+ !            and Paul Thomas  <pault@gcc.gnu.org>
+ !
+   type :: a
+     character(4), allocatable :: ch(:)
+   end type a
+ 
+   type :: b
+     type (a), allocatable :: at(:)
+   end type b
+ 
+   type(a) :: x(2)
+   type(b) :: y(2), z(2)
+ 
+   character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/)
+   character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/)
+ 
+   x(1) = a(chr1)
+ 
+  ! Check constructor with character array constructors.
+   x(2) = a((/"qrst","uvwx","yz12","3456"/))
+ 
+   y(1) = b((/x(1),x(2)/))
+   y(2) = b((/x(2),x(1)/))
+ 
+   y(2) = y(1)
+ 
+   if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. &
+           (/chr1, chr2/))) call abort ()
+ 
+   call test_ab6 ()
+ 
+ contains
+ 
+   subroutine test_ab6 ()
+ ! This subroutine tests the presence of a scalar derived type, intermediate
+ ! in a chain of derived types with allocatable components.
+ ! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
+ 
+     type b
+       type(a)  :: a
+     end type b
+ 
+     type c
+       type(b), allocatable :: b(:) 
+     end type c
+ 
+     type(c)    :: p
+     type(b)   :: bv
+ 
+     p = c((/b(a((/"Mary","Lamb"/)))/))
+     bv = p%b(1)
+ 
+     if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) call abort ()
+ 
+ end subroutine test_ab6
+ 
+ end
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_initializer_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_initializer_2.f90	(revision 0)
***************
*** 0 ****
--- 1,12 ----
+ ! { dg-do compile }
+ ! Check that default initializer for allocatable components isn't accepted (PR
+ ! 20541)
+ program main
+ 
+     type :: foo
+         integer, allocatable :: a(:) = [ 1 ] ! { dg-error "Initialization of allocatable" }
+ 
+         integer :: x ! Just to avoid "extra" error messages about empty type.
+     end type foo
+ 
+ end program main
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/derived_constructor_comps_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/derived_constructor_comps_2.f90	(revision 0)
***************
*** 0 ****
--- 1,15 ----
+ ! { dg-do compile }
+ ! Tests fix for PR29115, in which an ICE would be produced by 
+ ! non-pointer elements being supplied to the pointer components
+ ! in a derived type constructor.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   type :: homer
+     integer, pointer :: bart(:)
+   end type homer
+   type(homer) :: marge
+   integer :: duff_beer
+   marge = homer (duff_beer) ! { dg-error "should be a POINTER or a TARGET" }
+ 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" 38 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/forall_char_dependencies_1.f90	(revision 0)
***************
*** 0 ****
--- 1,13 ----
+ ! { dg-do compile }
+ ! Tests fix for PR29211, in which an ICE would be produced by FORALL assignments
+ ! with dependencies.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+ !
+   character(12), dimension(2) :: a, b
+   a= (/"abcdefghijkl","mnopqrstuvwx"/)
+ ! OK because it uses gfc_trans_assignment
+   forall (i=1:2) b(i) = a(i)
+ ! Was broken - gfc_trans_assign_need_temp had no handling of string lengths
+   forall (i=1:2) a(3-i) = a(i)
+ end
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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]