Re: [Patch, Fortran, 66035, v2] [5/6 Regression] gfortran ICE segfault

[Andre Vehreschild <vehre at gmx dot de>]

Hi Mikael,

> > @@ -7030,7 +7053,8 @@ gfc_trans_subcomponent_assign (tree dest,
> > gfc_component * cm, gfc_expr * expr, gfc_add_expr_to_block (&block, tmp);
> >      }
> >    else if (init && (cm->attr.allocatable
> > -	   || (cm->ts.type == BT_CLASS && CLASS_DATA
> > (cm)->attr.allocatable)))
> > +	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
> > +	       && expr->ts.type != BT_CLASS)))
> >      {
> >        /* Take care about non-array allocatable components here.  The
> > alloc_* routine below is motivated by the alloc_scalar_allocatable_for_
> > @@ -7074,6 +7098,14 @@ gfc_trans_subcomponent_assign (tree dest,
> > gfc_component * cm, gfc_expr * expr, tmp = gfc_build_memcpy_call (tmp,
> > se.expr, size); gfc_add_expr_to_block (&block, tmp);
> >  	}
> > +      else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_CLASS)
> > +	{
> > +	  tmp = gfc_copy_class_to_class (se.expr, dest, integer_one_node,
> > +				   CLASS_DATA
> > (cm)->attr.unlimited_polymorphic);
> > +	  gfc_add_expr_to_block (&block, tmp);
> > +	  gfc_add_modify (&block, gfc_class_vptr_get (dest),
> > +			  gfc_class_vptr_get (se.expr));
> > +	}
> >        else
> >  	gfc_add_modify (&block, tmp,
> >  			fold_convert (TREE_TYPE (tmp), se.expr));
> But this hunk is canceled by the one before, isn't it?
> I mean, If the condition here is true, the condition before was false?

You are absolutely right. The second hunk is dead code and removed in the
attached patch. That must have been the first attempt to address the issue and
later on I did not perceive that it was useless. Sorry for that.

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index adc5c0a..bab1cce 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6902,6 +6902,29 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 				       TREE_TYPE (tmp), tmp,
 				       fold_convert (TREE_TYPE (tmp), size));
     }
+  else if (cm->ts.type == BT_CLASS)
+    {
+      gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
+      if (expr2->ts.type == BT_DERIVED)
+	{
+	  tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
+	  size = TYPE_SIZE_UNIT (tmp);
+	}
+      else
+	{
+	  gfc_expr *e2vtab;
+	  gfc_se se;
+	  e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
+	  gfc_add_vptr_component (e2vtab);
+	  gfc_add_size_component (e2vtab);
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, e2vtab);
+	  gfc_add_block_to_block (block, &se.pre);
+	  size = fold_convert (size_type_node, se.expr);
+	  gfc_free_expr (e2vtab);
+	}
+      size_in_bytes = size;
+    }
   else
     {
       /* Otherwise use the length in bytes of the rhs.  */
@@ -7029,7 +7052,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
       gfc_add_expr_to_block (&block, tmp);
     }
   else if (init && (cm->attr.allocatable
-	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable)))
+	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
+	       && expr->ts.type != BT_CLASS)))
     {
       /* Take care about non-array allocatable components here.  The alloc_*
 	 routine below is motivated by the alloc_scalar_allocatable_for_
diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_13.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_13.f03
new file mode 100644
index 0000000..c74e325
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/structure_constructor_13.f03
@@ -0,0 +1,28 @@
+! { dg-do run }
+!
+! Contributed by Melven Roehrig-Zoellner  <Melven.Roehrig-Zoellner@DLR.de>
+! PR fortran/66035
+
+program test_pr66035
+  type t
+  end type t
+  type w
+    class(t), allocatable :: c
+  end type w
+
+  type(t) :: o
+
+  call test(o)
+contains
+  subroutine test(o)
+    class(t), intent(inout) :: o
+    type(w), dimension(:), allocatable :: list
+
+    select type (o)
+      class is (t)
+        list = [w(o)] ! This caused an ICE
+      class default
+        call abort()
+    end select
+  end subroutine
+end program