===================================================================
@@ -1,3 +1,10 @@
+2015-12-29 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/69011
+ * trans-stmt.c (gfc_trans_allocate): Unwrap a NOP_EXPR to make sure
+ the actual type of the source=-expr is used when it is of class type.
+ Furthermore prevent an ICE.
+
2015-12-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/68196
===================================================================
@@ -5377,7 +5377,20 @@
if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
- gfc_conv_expr_reference (&se, code->expr3);
+ {
+ gfc_conv_expr_reference (&se, code->expr3);
+
+ /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
+ NOP_EXPR, which prevents gfortran from getting the vptr
+ from the source=-expression. Remove the NOP_EXPR and go
+ with the POINTER_PLUS_EXPR in this case. */
+ if (code->expr3->ts.type == BT_CLASS
+ && TREE_CODE (se.expr) == NOP_EXPR
+ && TREE_CODE (TREE_OPERAND (se.expr, 0))
+ == POINTER_PLUS_EXPR)
+ //&& ! GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+ se.expr = TREE_OPERAND (se.expr, 0);
+ }
/* Create a temp variable only for component refs to prevent
having to go through the full deref-chain each time and to
simplfy computation of array properties. */
@@ -5494,7 +5507,6 @@
expr3 may be a temporary array declaration, therefore check for
GFC_CLASS_TYPE_P before trying to get the _vptr component. */
if (tmp != NULL_TREE
- && TREE_CODE (tmp) != POINTER_PLUS_EXPR
&& (e3_is == E3_DESC
|| (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
&& (VAR_P (tmp) || !code->expr3->ref))
===================================================================
@@ -1,3 +1,8 @@
+2015-12-29 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ PR fortran/69011
+ * gfortran.dg/allocate_with_source_16.f90: New test.
+
2015-12-28 Uros Bizjak <ubizjak@gmail.com>
* gcc.target/i386/*.c: Remove extra braces from target selectors.
===================================================================
@@ -0,0 +1,76 @@
+! { dg-do run }
+! Test the fix for pr69011, preventing an ICE and making sure
+! that the correct dynamic type is used.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+! Andre Vehreschild <vehre@gcc.gnu.org>
+!
+
+module m1
+implicit none
+private
+public :: basetype
+
+type:: basetype
+ integer :: i
+ contains
+endtype basetype
+
+abstract interface
+endinterface
+
+endmodule m1
+
+module m2
+use m1, only : basetype
+implicit none
+integer, parameter :: I_P = 4
+
+private
+public :: factory, exttype
+
+type, extends(basetype) :: exttype
+ integer :: i2
+ contains
+endtype exttype
+
+type :: factory
+ integer(I_P) :: steps=-1
+ contains
+ procedure, pass(self), public :: construct
+endtype factory
+contains
+
+ function construct(self, previous)
+ class(basetype), intent(INOUT) :: previous(1:)
+ class(factory), intent(IN) :: self
+ class(basetype), pointer :: construct
+ allocate(construct, source=previous(self%steps))
+ endfunction construct
+endmodule m2
+
+ use m2
+ use m1
+ class(factory), allocatable :: c1
+ class(exttype), allocatable :: prev(:)
+ class(basetype), pointer :: d
+
+ allocate(c1)
+ allocate(prev(2))
+ prev(:)%i = [ 2, 3]
+ prev(:)%i2 = [ 5, 6]
+ c1%steps= 1
+ d=> c1%construct(prev)
+
+ if (.not. associated(d) ) call abort()
+ select type (d)
+ class is (exttype)
+ if (d%i2 /= 5) call abort()
+ class default
+ call abort()
+ end select
+ if (d%i /= 2) call abort()
+ deallocate(c1)
+ deallocate(prev)
+ deallocate(d)
+end