Re: [Patch, fortran] PR90218 - [PDT] ICE: tree check: expected array_type, have record_type in gfc_conv_array_initializer, at fortran/trans-array.c:6071

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0b0d50263e9..46b5c0f7726 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2248,6 +2248,11 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
 	    {
 	      /* Scalar values.  */
 	      gfc_init_se (&se, NULL);
+	      if (c->expr->ts.type == BT_DERIVED
+		  && c->expr->ts.u.derived->attr.pdt_type
+		  && c->expr->expr_type == EXPR_STRUCTURE)
+		c->expr->must_finalize = 1;
+
 	      gfc_trans_array_ctor_element (&body, desc, *poffset,
 					    &se, c->expr);
 
@@ -3088,6 +3093,10 @@ trans_array_constructor (gfc_ss * ss, locus * where)
   finalize_required = expr->must_finalize;
   if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
     finalize_required = true;
+
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type)
+   finalize_required = true;
+
   gfc_trans_array_constructor_value (&outer_loop->pre,
 				     finalize_required ? &finalblock : NULL,
 				     type, desc, c, &offset, &offsetvar,
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index d7189f48c6b..8f6819d2f77 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1711,12 +1711,16 @@ gfc_get_symbol_decl (gfc_symbol * sym)
      declaration of the entity and memory allocated/deallocated.  */
   if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
       && sym->param_list != NULL
-      && gfc_current_ns == sym->ns
+      && (gfc_current_ns == sym->ns
+	  || (gfc_current_ns == sym->ns->parent
+	      && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
       && !(sym->attr.use_assoc || sym->attr.dummy))
     gfc_defer_symbol_init (sym);
 
   if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp)
-      && gfc_current_ns == sym->ns
+      && (gfc_current_ns == sym->ns
+	  || (gfc_current_ns == sym->ns->parent
+	      && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
       && !(sym->attr.use_assoc || sym->attr.dummy))
     gfc_defer_symbol_init (sym);
 
@@ -4596,25 +4600,37 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc,
 }
 
 
-/* Initialize a PDT, when all the components have an initializer.  */
-static void
-gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc)
+/* Initialize a PDT, either when the symbol has a value or when all the
+   components have an initializer.  */
+static tree
+gfc_init_default_pdt (gfc_symbol *sym, bool dealloc)
 {
-  /* Allowed in the case where all the components have initializers and
-     there are no LEN components.  */
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
+  stmtblock_t block;
+  tree tmp;
+  gfc_component *c;
+
+  if (sym->value && sym->value->symtree
+      && sym->value->symtree->n.sym
+      && !sym->value->symtree->n.sym->attr.artificial)
     {
-      gfc_component *c = sym->ts.u.derived->components;
-      if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE)
-	return;
-      for (; c; c = c->next)
-	if (c->attr.pdt_len || !c->initializer)
-	  return;
+      tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym),
+				  sym->value, false, false, true);
+      return tmp;
     }
-  else
-    return;
-  gfc_init_default_dt (sym, block, dealloc, true);
-  return;
+
+  if (!dealloc || !sym->value)
+    return NULL_TREE;
+
+  /* Allowed in the case where all the components have initializers and
+     there are no LEN components.  */
+  c = sym->ts.u.derived->components;
+  for (; c; c = c->next)
+    if (c->attr.pdt_len || !c->initializer)
+      return NULL_TREE;
+
+  gfc_init_block (&block);
+  gfc_init_default_dt (sym, &block, dealloc, true);
+  return gfc_finish_block (&block);
 }
 
 
@@ -4998,9 +5014,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	{
 	  is_pdt_type = true;
 	  gfc_init_block (&tmpblock);
+
 	  if (!sym->attr.dummy && !sym->attr.pointer)
 	    {
-	      if (!sym->attr.allocatable)
+	      tmp = gfc_init_default_pdt (sym, true);
+	      if (!sym->attr.allocatable && tmp == NULL_TREE)
 		{
 		  tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
 					       sym->backend_decl,
@@ -5008,9 +5026,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 					       sym->param_list);
 		  gfc_add_expr_to_block (&tmpblock, tmp);
 		}
-
-	      if (is_pdt_type)
-		gfc_init_default_pdt (sym, &tmpblock, true);
+	      else if (tmp != NULL_TREE)
+		gfc_add_expr_to_block (&tmpblock, tmp);
 
 	      if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp)
 		tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6ed34619c32..fc82ac11234 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9609,6 +9609,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 }
 
 
+static stmtblock_t *final_block;
 static tree
 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
 				 gfc_expr * expr)
@@ -9680,6 +9681,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
   gfc_add_expr_to_block (&block, tmp);
   gfc_add_block_to_block (&block, &se.post);
 
+  if (final_block && expr->expr_type == EXPR_ARRAY)
+    {
+      tree data_ptr;
+      data_ptr = gfc_conv_descriptor_data_get (dest);
+      gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
+    }
+
   if (expr->expr_type != EXPR_VARIABLE)
     gfc_conv_descriptor_data_set (&block, se.expr,
 				  null_pointer_node);
@@ -10385,6 +10393,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 
   if (!init)
     {
+      if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type
+	  && expr->must_finalize)
+	final_block = &se->finalblock;
+
       /* Create a temporary variable and fill it in.  */
       se->expr = gfc_create_var (type, expr->ts.u.derived->name);
       /* The symtree in expr is NULL, if the code to generate is for
@@ -10392,6 +10404,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
 					se->want_coarray);
       gfc_add_expr_to_block (&se->pre, tmp);
+      final_block = NULL;
       return;
     }
 
@@ -13291,6 +13304,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Deallocate the lhs parameterized components if required.  */
       if (dealloc
 	  && !expr1->symtree->n.sym->attr.associate_var
+	  && expr2->expr_type != EXPR_ARRAY
 	  && ((expr1->ts.type == BT_DERIVED
 	       && expr1->ts.u.derived
 	       && expr1->ts.u.derived->attr.pdt_type)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 42606845cc7..3433738c373 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6926,7 +6926,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
       if ((code->expr3->ts.type == BT_DERIVED
 	   || code->expr3->ts.type == BT_CLASS)
 	  && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
-	  && code->expr3->ts.u.derived->attr.alloc_comp
+	  && (code->expr3->ts.u.derived->attr.alloc_comp
+	      || code->expr3->ts.u.derived->attr.pdt_type)
 	  && !code->expr3->must_finalize
 	  && !code->ext.alloc.expr3_not_explicit)
 	{
@@ -7975,7 +7976,7 @@ gfc_trans_deallocate (gfc_code *code)
 				       se.expr, expr->rank);
 
       if (tmp)
-	gfc_add_expr_to_block (&block, tmp);
+	gfc_add_expr_to_block (&se.pre, tmp);
 
       if (flag_coarray == GFC_FCOARRAY_LIB
 	  || flag_coarray == GFC_FCOARRAY_SINGLE)
diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
index 84d74f8eae5..16b40fe6576 100644
--- a/gcc/testsuite/gfortran.dg/pdt_79.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -54,8 +54,8 @@ contains
       if (mt%k /= 4) stop 3
       if (mt%j /= 42) stop 4
     end associate
-  end subroutine
+  end subroutine                ! { dg-warning ".mapped_tensor. is used uninitialized" }
 
 end
-! { dg-final { scan-tree-dump-times "mapped_tensor.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_80.f03 b/gcc/testsuite/gfortran.dg/pdt_80.f03
new file mode 100644
index 00000000000..229d20317a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_80.f03
@@ -0,0 +1,63 @@
+! { dg-do run )
+!
+! Contributed by Arseny Solokha  <[email protected]>
+!
+  type :: foo(a)
+    integer,len :: a
+    integer :: vals(a)
+  end type
+  type :: bar(b)
+    integer,len :: b
+    type(foo(2)) :: array(b)
+  end type
+
+  type :: barbar(b)
+    integer,len :: b
+    type(foo(2)), allocatable :: array(:)
+  end type
+
+
+  type(barbar(2)) :: var2
+  type(bar(2)) :: var = bar(2)([foo(2)([1,2]),foo(2)([3,4])])    ! Values were not set
+
+  if (any (var%array%vals(1) /= [1,3])) stop 1
+  if (any (var%array%vals(2) /= [2,4])) stop 2
+
+  var = bar(2)([foo(2)(-[1,2]),foo(2)(-[3,4])])                  ! Was OK but 16bytes/2 blocks lost
+
+  var%array = [foo(2)([5,6]),foo(2)([7,8])]                      ! Was an invalid free here
+                                                                 ! also 16bytes/2 blocks lost
+  if (any (var%array%vals(1) /= [5,7])) stop 3
+  if (any (var%array%vals(2) /= [6,8])) stop 4
+
+  var2 = barbar(2)([foo(2)([1,2]),foo(2)([3,4])])                ! 16bytes/2 blocks lost
+
+  if (any (var2%array%vals(1) /= [1,3])) stop 5
+  if (any (var2%array%vals(2) /= [2,4])) stop 6
+  if (allocated (var2%array)) deallocate (var2%array)            ! Caused gimplifier problems
+
+  call foobar
+
+contains
+  subroutine foobar
+  type(barbar(2)) :: var_s2
+  type(bar(2)) :: var_s = bar(2)([foo(2)([1,2]),foo(2)([3,4])])  ! Values were not set
+
+  if (any (var_s%array%vals(1) /= [1,3])) stop 1
+  if (any (var_s%array%vals(2) /= [2,4])) stop 2
+
+  var_s = bar(2)([foo(2)(-[1,2]),foo(2)(-[3,4])])                ! Was OK but 16bytes/2 blocks lost
+
+  var_s%array = [foo(2)([5,6]),foo(2)([7,8])]                    ! Was an invalid free here
+                                                                 ! also 16bytes/2 blocks lost
+  if (any (var_s%array%vals(1) /= [5,7])) stop 3
+  if (any (var_s%array%vals(2) /= [6,8])) stop 4
+
+  var_s2 = barbar(2)([foo(2)([1,2]),foo(2)([3,4])])              ! 16bytes/2 blocks lost
+
+  if (any (var_s2%array%vals(1) /= [1,3])) stop 5
+  if (any (var_s2%array%vals(2) /= [2,4])) stop 6
+  if (allocated (var_s2%array)) deallocate (var_s2%array)        ! Caused gimplifier problems
+  end
+
+end                                                              ! 160bytes/1 block was lost here