This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran 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]

PR20541 - allocatable components of derived types (TR15581)


We have a longstanding PR for the implementation of TR15581. Erik Edelmann started work on this a few months back and I have added my 10 cents worth. Being sharply aware that I depart on vacation next week and that Erik is on a beach somewhere, I took the liberty of posting the most up to date version on Bugzilla - http://gcc.gnu.org/bugzilla/show_bug.cgi?id=20541 and have attached it here as well.

There is still a lot to be done to get this patch into submittable condition but it would be as well that we expose it for perusal now, in the hope that some of you will apply it and try it out. Being a 2000+ line patch, review is not going to be easy, so it would be as well that everybody gets involved in testing it to destruction. It would be really nice if somebody would apply valgrind, or similar, to check that we really are not leaking memory.

Let me try to indicate the present status:

(i) Erik has done a tremendous job on the basics - the testcase TR15581_basics.f90 reflects this. We worked together to produce the core functions in trans-array.c that do the deallocating, the nullifying and the copying of these beasts.
(ii) Subsequently we have iterated between us on a solution for assignments in all their various shapes and forms. forall and where assignements have yet to be tested but basic sit-up-and-beg assignment is working correctly.
(iii) Constructors with allocatable components is the latest and wobbliest addition - I believe it to be OK except for a memory leak that occurs when an array valued function is used as the source for the array. The TODO indicates how this will be fixed. It also has no error checking, so that providing a scalar does bad things.
(iv) The three testcases reflect each of the previous three points. The most important remaining, specific feature is the intrinsic subroutine move_alloc; this will appear in the submitted version of the patch.
(v) Documentation - this will have to be done in the next weeks.
(vi) The testcases will have to be further refined and expanded.
(vii) The error checking and constraints will need to be thoroughly sorted out.
(viii) Most of the iso_varying_string testsuite runs - I believe that there are some non-standard features in this that cause 3 out of 33 cases(vst28, 30 & 31.f95) to fail. These non-standard features are all associated with references zero length strings. Checking that out of bounds references do not occur, for this specific case, removes these failures. Still, other compilers survive them, so I guess that we will have to figure out how to do likewise. The remaining failure(vst16.f95) is IO related and we have not even started to investigate it.


Well there it is! I hope that Erik will forgive me for exposing the baby in his absence.......

Cheers

Paul

Index: gcc/testsuite/gfortran.dg/tr15581_basics.f90
===================================================================
*** gcc/testsuite/gfortran.dg/tr15581_basics.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/tr15581_basics.f90	(revision 0)
***************
*** 0 ****
--- 1,139 ----
+ ! { 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
+ !
+ module alloc_m
+ 
+     implicit none
+ 
+     type :: alloc1
+         real, allocatable :: x(:)
+     end type alloc1
+ 
+ end module alloc_m
+ 
+ 
+ program alloc
+ 
+     use alloc_m
+ 
+     implicit none
+ 
+     type :: alloc2
+         type(alloc1), allocatable :: a1(:)
+         integer, allocatable :: a2(:)
+     end type alloc2
+ 
+     type(alloc2) :: b
+     integer :: i
+     type(alloc2), allocatable :: c(:)
+ 
+     if (allocated(b%a2) .OR. allocated(b%a1)) then
+         write (0, *) 'main - 1'
+         call abort()
+     end if
+ 
+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+     call allocate_alloc2(b)
+     call check_alloc2(b)
+ 
+     do i = 1, size(b%a1)
+         ! 1 call to _gfortran_deallocate
+         deallocate(b%a1(i)%x)
+     end do
+ 
+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+     call allocate_alloc2(b)
+ 
+     call check_alloc2(return_alloc2())
+     ! 3 calls to _gfortran_deallocate (function result)
+ 
+     allocate(c(1))
+     ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy)
+     call allocate_alloc2(c(1))
+     ! 4 calls to _gfortran_deallocate
+     deallocate(c)
+ 
+     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
+ 
+ contains
+ 
+     subroutine allocate_alloc2(b)
+         type(alloc2), intent(out) :: b
+         integer :: i
+ 
+         if (allocated(b%a2) .OR. allocated(b%a1)) then
+             write (0, *) 'allocate_alloc2 - 1'
+             call abort()
+         end if
+ 
+         allocate (b%a2(3))
+         b%a2 = [ 1, 2, 3 ]
+ 
+         allocate (b%a1(3))
+ 
+         do i = 1, 3
+             if (allocated(b%a1(i)%x)) then
+                 write (0, *) 'allocate_alloc2 - 2', i
+                 call abort()
+             end if
+             allocate (b%a1(i)%x(3))
+             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
+         end do
+ 
+     end subroutine allocate_alloc2
+ 
+ 
+     type(alloc2) function return_alloc2() result(b)
+         if (allocated(b%a2) .OR. allocated(b%a1)) then
+             write (0, *) 'return_alloc2 - 1'
+             call abort()
+         end if
+ 
+         allocate (b%a2(3))
+         b%a2 = [ 1, 2, 3 ]
+ 
+         allocate (b%a1(3))
+ 
+         do i = 1, 3
+             if (allocated(b%a1(i)%x)) then
+                 write (0, *) 'return_alloc2 - 2', i
+                 call abort()
+             end if
+             allocate (b%a1(i)%x(3))
+             b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ]
+         end do
+     end function return_alloc2
+ 
+ 
+     subroutine check_alloc2(b)
+         type(alloc2), intent(in) :: b
+ 
+         if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then
+             write (0, *) 'check_alloc2 - 1'
+             call abort()
+         end if
+         if (any(b%a2 /= [ 1, 2, 3 ])) then
+             write (0, *) 'check_alloc2 - 2'
+             call abort()
+         end if
+         do i = 1, 3
+             if (.NOT.allocated(b%a1(i)%x)) then
+                 write (0, *) 'check_alloc2 - 3', i
+                 call abort()
+             end if
+             if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then
+                 write (0, *) 'check_alloc2 - 4', i
+                 call abort()
+             end if
+         end do
+     end subroutine check_alloc2
+ 
+ end program alloc
+ ! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
+ ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/tr15581_assign.f90
===================================================================
*** gcc/testsuite/gfortran.dg/tr15581_assign.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/tr15581_assign.f90	(revision 0)
***************
*** 0 ****
--- 1,51 ----
+   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)
+ 
+ ! 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
\ No newline at end of file
Index: gcc/testsuite/gfortran.dg/tr15581_constructor.f90
===================================================================
*** gcc/testsuite/gfortran.dg/tr15581_constructor.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/tr15581_constructor.f90	(revision 0)
***************
*** 0 ****
--- 1,29 ----
+ ! { dg-do run}
+ !
+ ! Check some basic functionality of constructors of structures with
+ ! allocatable components.
+ !
+ program tr15581_constructor
+   type :: mytype
+     integer, allocatable :: a(:, :)
+   end type mytype
+   type (mytype) :: x
+   integer :: y(0:1, -1:0) = reshape ((/42, 99, 55, 77/), (/2,2/))
+   x = mytype (y)
+   call foo (x, y)
+   x = mytype (reshape ((/42, 99, 55, 77/), (/2,2/)))
+   call foo (x, reshape ((/42, 99, 55, 77/), (/2,2/)))
+   x = mytype (bar (y))
+   call foo (x, y**3)
+ contains
+   subroutine foo (x, y)
+     type(mytype) :: x
+     integer y(:,:)
+     if (any (x%a .ne. y)) call abort ()
+   end subroutine foo
+   function bar (x)
+     integer, dimension(:,:) :: x
+     integer, dimension(size(x, 1), size(x, 2)) :: bar
+     bar = x**3
+   end function bar
+ end program
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 115377)
--- 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/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 115377)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 3316,3321 ****
--- 3316,3327 ----
    tmp = gfc_conv_descriptor_offset (se->expr);
    gfc_add_modify_expr (&se->pre, tmp, offset);
  
+   if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+     {
+       tmp = 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
*** 3456,3461 ****
--- 3462,3470 ----
          }
        break;
  
+     case EXPR_NULL:
+       return gfc_build_null_descriptor (type);
+ 
      default:
        gcc_unreachable ();
      }
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 4532,4537 ****
--- 4541,4557 ----
    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 = deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
+       gfc_add_expr_to_block (&se->post, tmp);
+     }
+ 
    if (g77)
      {
        desc = se->expr;
*************** tree
*** 4580,4600 ****
  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;
  }
  
  
--- 4600,4864 ----
  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);
!    nelems = gfc_conv_descriptor_stride (decl, idx);
!    tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
!    return gfc_evaluate_now (tmp, block);
! }
! 
! 
! /* 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;
! 
!   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.  */
! 	  nelems = get_full_array_size (&fnblock, decl, rank);
! 
! 	  /* Set the result to -1 if already deallocated, so that the
! 	     loop does not run.  */
! 	  tmp = gfc_conv_descriptor_data_get (decl);
! 	  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
! 			build_int_cst (TREE_TYPE (tmp), 0));
! 	  tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
! 			nelems, gfc_index_zero_node);
! 	  tmp = build2 (MINUS_EXPR, gfc_array_index_type,
! 			   tmp, gfc_index_one_node);
! 	}
!       else
! 	{
! 	  /*  Otherwise use the TYPE_DOMAIN information.  */
! 	  tmp =  array_type_nelts (TREE_TYPE (decl));
! 	  tmp = fold_convert (gfc_array_index_type, tmp);
! 	}
! 
!       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);
!       tmp = gfc_build_array_ref (var, index);
! 
!       if (purpose == COPY_ALLOC_COMP)
!         tmp = structure_alloc_comps (der_type, tmp,
! 				     gfc_build_array_ref (dest, index),
! 				     0, purpose);
!       else
!         tmp = structure_alloc_comps (der_type, tmp, NULL_TREE, 0, 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);
!       return gfc_finish_block (&fnblock);
!     }
! 
!   /* Otherwise, deallocate the components or recursively call self to
!      dealocate the components of components. */
!   for (c = der_type->components; c; c = c->next)
!     {
!       cdecl = c->backend_decl;
!       ctype = TREE_TYPE (cdecl);
! 
!       switch (purpose)
! 	{
! 	case DEALLOCATE_ALLOC_COMP:
! 	  if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
! 	    {
! 	      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 (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
! 	    {
! 	      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;
! 
! 	  comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
! 	  dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
! 
! 	  if (c->allocatable)
! 	    {
! 	      tree size;
! 	      tree args;
! 	      nelems = get_full_array_size (&fnblock, comp, c->as->rank);
! 	      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
! 				  TYPE_SIZE_UNIT (gfc_get_element_type (ctype)));
! 
! 	      /* 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 (comp)),
! 		          tmp));
! 	      gfc_conv_descriptor_data_set (&fnblock, dcmp, tmp);
! 
! 	      /* We know the temporary and the value will be the same length,
! 		 so can use memcpy.  */
! 	      tmp = gfc_conv_descriptor_data_get (dcmp);
! 	      args = gfc_chainon_list (NULL_TREE, tmp);
! 	      tmp = gfc_conv_descriptor_data_get (comp);
! 	      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 (&fnblock, tmp);
! 	    }
! 
!           if (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)
! 	    {
! 	      rank = c->as ? c->as->rank : 0;
! 	      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
! 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
! 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
! 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);
  }
  
  
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4608,4623 ****
    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))
--- 4872,4889 ----
    tree descriptor;
    stmtblock_t fnblock;
    locus loc;
+   int rank;
  
    /* Make sure the frontend gets these right.  */
!   if (!(sym->attr.pointer || sym->attr.allocatable
! 	|| (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)))
!     fatal_error ("Possible frontend bug: Deferred array size without pointer"
! 		 "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))
*************** gfc_trans_deferred_array (gfc_symbol * s
*** 4647,4668 ****
  
    /* 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);
--- 4913,4953 ----
  
    /* Get the descriptor type.  */
    type = TREE_TYPE (sym->backend_decl);
!     
!   if (sym->ts.type == BT_DERIVED
! 	&& sym->ts.derived->attr.alloc_comp
! 	&& !(sym->attr.pointer || sym->attr.allocatable))
!     {
!       rank = sym->as ? sym->as->rank : 0;
!       tmp = 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.  */
+   if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp
+       && !(sym->attr.function || sym->attr.result))
+     {
+       int rank;
+       rank = sym->as ? sym->as->rank : 0;
+       tmp = deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
+       gfc_add_expr_to_block (&fnblock, tmp);
+     }
+ 
    if (sym->attr.allocatable)
      {
        tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 115377)
--- gcc/fortran/trans-expr.c	(working copy)
*************** Software Foundation, 51 Franklin Street,
*** 42,48 ****
  #include "trans-stmt.h"
  #include "dependency.h"
  
! static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
  static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
  						 gfc_expr *);
  
--- 42,48 ----
  #include "trans-stmt.h"
  #include "dependency.h"
  
! static tree gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr);
  static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
  						 gfc_expr *);
  
*************** gfc_conv_aliased_arg (gfc_se * parmse, g
*** 1702,1708 ****
  
    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);
--- 1702,1708 ----
  
    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
*** 1787,1793 ****
  
    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.  */
--- 1787,1793 ----
  
    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
*** 1859,1868 ****
    gfc_ss *argss;
    gfc_ss_info *info;
    int byref;
    tree type;
    tree var;
    tree len;
!   tree stringargs;
    gfc_formal_arglist *formal;
    int has_alternate_specifier = 0;
    bool need_interface_mapping;
--- 1859,1869 ----
    gfc_ss *argss;
    gfc_ss_info *info;
    int byref;
+   int parm_kind;
    tree type;
    tree var;
    tree len;
!   tree stringargs;
    gfc_formal_arglist *formal;
    int has_alternate_specifier = 0;
    bool need_interface_mapping;
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1872,1877 ****
--- 1873,1879 ----
    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
*** 1914,1919 ****
--- 1916,1922 ----
      {
        e = arg->expr;
        fsym = formal ? formal->sym : NULL;
+       parm_kind = MISSING;
        if (e == NULL)
  	{
  
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1942,1947 ****
--- 1945,1951 ----
  	  /* 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
*** 1952,1963 ****
--- 1956,1969 ----
  	  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
*** 2013,2018 ****
--- 2019,2064 ----
        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 = 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_FUNCTION)
+ 	    /* Don't deallocate function results until they have been used.  */
+ 	    gfc_add_expr_to_block (&se->post, tmp);
+ 	  else
+ 	    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
*** 2586,2592 ****
  
    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);
--- 2632,2638 ----
  
    gfc_conv_expr (&rse, expr);
  
!   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, false, false);
    gfc_add_expr_to_block (&body, tmp);
  
    gcc_assert (rse.ss == gfc_ss_terminator);
*************** gfc_trans_subarray_assign (tree dest, gf
*** 2610,2621 ****
  /* Assign a single component of a derived type constructor.  */
  
  static tree
! gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
  {
    gfc_se se;
    gfc_ss *rss;
    stmtblock_t block;
    tree tmp;
  
    gfc_start_block (&block);
    if (cm->pointer)
--- 2656,2671 ----
  /* Assign a single component of a derived type constructor.  */
  
  static tree
! gfc_trans_subcomponent_assign (gfc_se * outer_se, tree dest,
! 			       gfc_component * cm, gfc_expr * expr)
  {
    gfc_se se;
+   gfc_se lse;
    gfc_ss *rss;
    stmtblock_t block;
    tree tmp;
+   tree offset;
+   int n;
  
    gfc_start_block (&block);
    if (cm->pointer)
*************** gfc_trans_subcomponent_assign (tree dest
*** 2650,2669 ****
      }
    else if (cm->dimension)
      {
!       tmp = gfc_trans_subarray_assign (dest, cm, expr);
!       gfc_add_expr_to_block (&block, tmp);
      }
    else if (expr->ts.type == BT_DERIVED)
      {
        /* Nested derived type.  */
!       tmp = gfc_trans_structure_assign (dest, expr);
        gfc_add_expr_to_block (&block, tmp);
      }
    else
      {
        /* Scalar component.  */
-       gfc_se lse;
- 
        gfc_init_se (&se, NULL);
        gfc_init_se (&lse, NULL);
  
--- 2700,2774 ----
      }
    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)
! 	{
!           gfc_init_se (&se, NULL);
! 	  gfc_init_se (&lse, NULL);
! 
! 	  se.want_pointer = 0;
! 	  gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
! 	  if (cm->ts.type == BT_CHARACTER)
! 	    lse.string_length = cm->ts.cl->backend_decl;
! 	  lse.expr = dest;
! 	  if (expr->expr_type == EXPR_FUNCTION)
! 	    {
! 	      /* Null the data pointer so that the memory does not get freed.  The
! 	         this has to go to the head of the se.post block.
! 		 FIXME: The data needs to be freed in the next scope up or, better
! 		 still, the copy should not be done in the assignment.
! 		 NOTE: outer_se is provided expressly to fix this. We need to add
! 		 a pointer to outer_se->pre, to assign the data field to it in this
! 		 scope and to free the data in outer_se->post.  */
! 	      stmtblock_t tmp_block;
! 	      gfc_init_block (&tmp_block);
! 	      gfc_add_block_to_block (&tmp_block, &se.post);
! 	      gfc_conv_descriptor_data_set (&se.post, se.expr, null_pointer_node);
! 	      gfc_add_block_to_block (&se.post, &tmp_block);
! 	    }
! 
! 	  tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
! 	  gfc_add_expr_to_block (&block, tmp);
! 
! 	  /* 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);
! 	  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]));
! 	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
! 	      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)
      {
        /* Nested derived type.  */
!       tmp = gfc_trans_structure_assign (outer_se, dest, expr);
        gfc_add_expr_to_block (&block, tmp);
      }
    else
      {
        /* Scalar component.  */
        gfc_init_se (&se, NULL);
        gfc_init_se (&lse, NULL);
  
*************** gfc_trans_subcomponent_assign (tree dest
*** 2671,2677 ****
        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);
--- 2776,2782 ----
        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, false, false);
        gfc_add_expr_to_block (&block, tmp);
      }
    return gfc_finish_block (&block);
*************** gfc_trans_subcomponent_assign (tree dest
*** 2680,2686 ****
  /* Assign a derived type constructor to a variable.  */
  
  static tree
! gfc_trans_structure_assign (tree dest, gfc_expr * expr)
  {
    gfc_constructor *c;
    gfc_component *cm;
--- 2785,2791 ----
  /* Assign a derived type constructor to a variable.  */
  
  static tree
! gfc_trans_structure_assign (gfc_se * outer_se, tree dest, gfc_expr * expr)
  {
    gfc_constructor *c;
    gfc_component *cm;
*************** gfc_trans_structure_assign (tree dest, g
*** 2698,2704 ****
  
        field = cm->backend_decl;
        tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
!       tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
        gfc_add_expr_to_block (&block, tmp);
      }
    return gfc_finish_block (&block);
--- 2803,2809 ----
  
        field = cm->backend_decl;
        tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
!       tmp = gfc_trans_subcomponent_assign (outer_se, tmp, cm, c->expr);
        gfc_add_expr_to_block (&block, tmp);
      }
    return gfc_finish_block (&block);
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 2725,2731 ****
      {
        /* Create a temporary variable and fill it in.  */
        se->expr = gfc_create_var (type, expr->ts.derived->name);
!       tmp = gfc_trans_structure_assign (se->expr, expr);
        gfc_add_expr_to_block (&se->pre, tmp);
        return;
      }
--- 2830,2836 ----
      {
        /* Create a temporary variable and fill it in.  */
        se->expr = gfc_create_var (type, expr->ts.derived->name);
!       tmp = gfc_trans_structure_assign (se, se->expr, expr);
        gfc_add_expr_to_block (&se->pre, tmp);
        return;
      }
*************** gfc_conv_string_parameter (gfc_se * se)
*** 3032,3057 ****
     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);
! 
!       gfc_conv_string_parameter (lse);
!       gfc_conv_string_parameter (rse);
! 
!       gfc_add_block_to_block (&block, &lse->pre);
!       gfc_add_block_to_block (&block, &rse->pre);
! 
!       gfc_trans_string_copy (&block, lse->string_length, lse->expr,
! 			     rse->string_length, rse->expr);
!     }
    else
      {
        gfc_add_block_to_block (&block, &lse->pre);
--- 3137,3209 ----
     strings.  */
  
  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_conv_string_parameter (lse);
!       gfc_conv_string_parameter (rse);
! 
!       gfc_add_block_to_block (&block, &lse->pre);
!       gfc_add_block_to_block (&block, &rse->pre);
! 
!       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 = 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, as long as 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 = 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 = 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, 
*** 3246,3252 ****
    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)
--- 3398,3406 ----
    else
      gfc_conv_expr (&lse, expr1);
  
!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
! 				 loop.temp_ss != NULL,
! 				 expr2->expr_type != EXPR_FUNCTION);
    gfc_add_expr_to_block (&body, tmp);
  
    if (lss == gfc_ss_terminator)
*************** gfc_trans_assignment (gfc_expr * expr1, 
*** 3279,3287 ****
  	  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);
  
--- 3433,3442 ----
  	  gcc_assert (lse.ss == gfc_ss_terminator
  		      && rse.ss == gfc_ss_terminator);
  
! 	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
  	  gfc_add_expr_to_block (&body, tmp);
  	}
+ 
        /* Generate the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &body);
  
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 115377)
--- 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 115377)
--- gcc/fortran/decl.c	(working copy)
*************** build_struct (const char *name, gfc_char
*** 963,976 ****
  
    /* 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;
  	}
      }
--- 963,993 ----
  
    /* 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;
  	}
      }
*************** match_attr_spec (void)
*** 2128,2138 ****
  	  && 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)
--- 2145,2168 ----
  	  && d != DECL_DIMENSION && d != DECL_POINTER
  	  && d != DECL_COLON && d != DECL_NONE)
  	{
! 	  if (d == DECL_ALLOCATABLE)
! 	    {
! 	      if (gfc_notify_std (GFC_STD_F2003, 
! 				   "In the selected standard, the ALLOCATABLE "
! 				   "attribute at %C is not allowed in a TYPE "
! 				   "definition") == FAILURE)         
! 		{
! 		  m = MATCH_ERROR;
! 		  goto cleanup;
! 		}
!             }
!           else
! 	    {
! 	      gfc_error ("Attribute at %L is not allowed in a TYPE definition",
! 			  &seen_at[d]);
! 	      m = MATCH_ERROR;
! 	      goto cleanup;
! 	    }
  	}
  
        if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 115377)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_trans_dummy_array_bias (gfc_sym
*** 43,48 ****
--- 43,55 ----
  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 nullify_alloc_comp (gfc_symbol *, tree, int);
+ 
+ tree deallocate_alloc_comp (gfc_symbol *, tree, int);
+ 
+ tree 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 115377)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 522,527 ****
--- 522,530 ----
    /* 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
*** 639,645 ****
    const char *name;
    gfc_typespec ts;
  
!   int pointer, dimension;
    gfc_array_spec *as;
  
    tree backend_decl;
--- 642,648 ----
    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
*** 1958,1963 ****
--- 1961,1967 ----
  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 115377)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** generate_loop_for_temp_to_lhs (gfc_expr 
*** 1795,1801 ****
        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)
--- 1795,1801 ----
        gfc_conv_expr (&lse, expr);
  
        /* Use the scalar assignment.  */
!       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
  
        /* Form the mask expression according to the mask tree list.  */
        if (wheremask)
*************** generate_loop_for_rhs_to_temp (gfc_expr 
*** 1890,1896 ****
      }
  
    /* 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)
--- 1890,1896 ----
      }
  
    /* Use the scalar assignment.  */
!   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, false, false);
  
    /* Form the mask expression according to the mask tree list.  */
    if (wheremask)
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 2971,2977 ****
      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);
--- 2971,2978 ----
      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,
*** 3024,3030 ****
  				    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);
  
--- 3025,3031 ----
  				    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
*** 3399,3406 ****
          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);
--- 3400,3407 ----
          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_deallocate (gfc_code * code)
*** 3668,3673 ****
--- 3669,3680 ----
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
  
+       if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+         {
+ 	  tmp = 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 115377)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_expr_set_symbols_referenced (gfc_exp
*** 2535,2537 ****
--- 2535,2569 ----
            break;
          }
  }
+ 
+ 
+ /* 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.)  */
+ 
+ gfc_expr *
+ gfc_expr_to_initialize (gfc_expr * e)
+ {
+   gfc_expr *result;
+   gfc_ref *ref;
+   int i;
+ 
+   result = gfc_copy_expr (e);
+ 
+   /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
+   for (ref = result->ref; ref; ref = ref->next)
+     if (ref->type == REF_ARRAY && ref->next == NULL)
+       {
+         ref->u.ar.type = AR_FULL;
+ 
+         for (i = 0; i < ref->u.ar.dimen; i++)
+           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+ 
+         result->rank = ref->u.ar.dimen; 
+         break;
+       }
+ 
+   return result;
+ }
+ 
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 115377)
--- 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,1472 ----
      minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
      minit ("CRAY_POINTER", AB_CRAY_POINTER),
      minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+     minit ("ALLOC_COMP", AB_ALLOC_COMP),
      minit (NULL, -1)
  };
  
*************** mio_symbol_attribute (symbol_attribute *
*** 1556,1561 ****
--- 1558,1566 ----
        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 ****
--- 1649,1657 ----
  	    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 ****
--- 1959,1965 ----
  
    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 115377)
--- gcc/fortran/trans-types.c	(working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 1532,1538 ****
           required.  */
        if (c->dimension)
  	{
! 	  if (c->pointer)
  	    {
  	      /* Pointers to arrays aren't actually pointer types.  The
  	         descriptors are separate, but the data is common.  */
--- 1532,1538 ----
           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 115377)
--- 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 115377)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_deallocate_expr (gfc_expr * e)
*** 3214,3249 ****
  }
  
  
- /* 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)
- {
-   gfc_expr *result;
-   gfc_ref *ref;
-   int i;
- 
-   result = gfc_copy_expr (e);
- 
-   /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
-   for (ref = result->ref; ref; ref = ref->next)
-     if (ref->type == REF_ARRAY && ref->next == NULL)
-       {
-         ref->u.ar.type = AR_FULL;
- 
-         for (i = 0; i < ref->u.ar.dimen; i++)
-           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
- 
-         result->rank = ref->u.ar.dimen; 
-         break;
-       }
- 
-   return result;
- }
- 
- 
  /* Resolve the expression in an ALLOCATE statement, doing the additional
     checks to see whether the expression is OK or not.  The expression must
     have a trailing array reference that gives the size of the array.  */
--- 3214,3219 ----
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3324,3332 ****
          init_st = gfc_get_code ();
          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;
      }
--- 3294,3301 ----
          init_st = gfc_get_code ();
          init_st->loc = code->loc;
          init_st->op = EXEC_ASSIGN;
!         init_st->expr = gfc_expr_to_initialize (e);
! 	init_st->expr2 = init_e;
          init_st->next = code->next;
          code->next = init_st;
      }
*************** resolve_fl_derived (gfc_symbol *sym)
*** 5305,5311 ****
  	  return FAILURE;
  	}
  
!       if (c->pointer || c->as == NULL)
  	continue;
  
        for (i = 0; i < c->as->rank; i++)
--- 5274,5280 ----
  	  return FAILURE;
  	}
  
!       if (c->pointer || c->allocatable ||  c->as == NULL)
  	continue;
  
        for (i = 0; i < c->as->rank; i++)
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c	(revision 115377)
--- gcc/fortran/trans-decl.c	(working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 945,950 ****
--- 945,953 ----
  	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
*** 2587,2599 ****
  	      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);
--- 2590,2608 ----
  	      break;
  
  	    case AS_DEFERRED:
! 	      if (!(sym->ts.type == BT_DERIVED
! 		      && sym->ts.derived->attr.alloc_comp))
! 		fnbody = gfc_trans_deferred_array (sym, fnbody);
  	      break;
  
  	    default:
  	      gcc_unreachable ();
  	    }
+ 	  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ 	    fnbody = gfc_trans_deferred_array (sym, fnbody);
  	}
+       else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.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
*** 2829,2838 ****
--- 2838,2849 ----
    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
*** 2992,2998 ****
    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)
      {
--- 3003,3008 ----
*************** gfc_generate_function_code (gfc_namespac
*** 3007,3013 ****
        else
  	result = sym->result->backend_decl;
  
!       if (result == NULL_TREE)
  	warning (0, "Function return value not set");
        else
  	{
--- 3017,3034 ----
        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 = 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
*** 3018,3023 ****
--- 3039,3047 ----
  	  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 115377)
--- gcc/fortran/parse.c	(working copy)
*************** parse_derived (void)
*** 1500,1505 ****
--- 1500,1506 ----
    gfc_statement st;
    gfc_component *c;
    gfc_state_data s;
+   gfc_symbol *sym;
  
    error_flag = 0;
  
*************** parse_derived (void)
*** 1610,1615 ****
--- 1611,1628 ----
  	  }
        }
  
+   /* 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 115377)
--- gcc/fortran/check.c	(working copy)
*************** gfc_check_all_any (gfc_expr * mask, gfc_
*** 461,473 ****
  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,
--- 461,476 ----
  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,
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 115377)
--- gcc/fortran/primary.c	(working copy)
*************** check_substring:
*** 1711,1717 ****
  symbol_attribute
  gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
  {
!   int dimension, pointer, target;
    symbol_attribute attr;
    gfc_ref *ref;
  
--- 1711,1717 ----
  symbol_attribute
  gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
  {
!   int dimension, pointer, allocatable, target;
    symbol_attribute attr;
    gfc_ref *ref;
  
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1723,1728 ****
--- 1723,1729 ----
  
    dimension = attr.dimension;
    pointer = attr.pointer;
+   allocatable = attr.allocatable;
  
    target = attr.target;
    if (pointer)
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1743,1754 ****
  	    break;
  
  	  case AR_SECTION:
! 	    pointer = 0;
  	    dimension = 1;
  	    break;
  
  	  case AR_ELEMENT:
! 	    pointer = 0;
  	    break;
  
  	  case AR_UNKNOWN:
--- 1744,1755 ----
  	    break;
  
  	  case AR_SECTION:
! 	    allocatable = pointer = 0;
  	    dimension = 1;
  	    break;
  
  	  case AR_ELEMENT:
! 	    allocatable = pointer = 0;
  	    break;
  
  	  case AR_UNKNOWN:
*************** gfc_variable_attr (gfc_expr * expr, gfc_
*** 1763,1780 ****
  	  *ts = ref->u.c.component->ts;
  
  	pointer = ref->u.c.component->pointer;
  	if (pointer)
  	  target = 1;
  
  	break;
  
        case REF_SUBSTRING:
! 	pointer = 0;
  	break;
        }
  
    attr.dimension = dimension;
    attr.pointer = pointer;
    attr.target = target;
  
    return attr;
--- 1764,1783 ----
  	  *ts = ref->u.c.component->ts;
  
  	pointer = ref->u.c.component->pointer;
+ 	allocatable = ref->u.c.component->allocatable;
  	if (pointer)
  	  target = 1;
  
  	break;
  
        case REF_SUBSTRING:
! 	allocatable = pointer = 0;
  	break;
        }
  
    attr.dimension = dimension;
    attr.pointer = pointer;
+   attr.allocatable = allocatable;
    attr.target = target;
  
    return attr;

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