re PR fortran/69011 ([OOP] ICE in gfc_advance_chain for ALLOCATE with SOURCE)

gcc/testsuite/ChangeLog:

2015-12-29  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/69011
	* gfortran.dg/allocate_with_source_16.f90: New test.


gcc/fortran/ChangeLog:

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.

From-SVN: r231992

4 files changed, 102 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index eeb79d9..668a043 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 72416d4..3c6fae1 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5377,7 +5377,20 @@ gfc_trans_allocate (gfc_code * code)
 	      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 @@ gfc_trans_allocate (gfc_code * code)
 	     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))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0cc0603..65ec5c5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
new file mode 100644
index 0000000..cb5f16f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
@@ -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