[Patch, fortran] PR64578 - [OOP] Seg-fault and ICE with unlimited polymorphic array pointer function

[Paul Richard Thomas]

Applied as 'obvious' in revision 219802.

2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/64578
    * trans-expr.c (gfc_trans_pointer_assignment): Make sure that
    before reinitializing rse, to add the rse.pre to block before
    creating 'ptrtemp'.
    * trans-intrinsic.c (gfc_conv_associated): Deal with the class
    data being a descriptor.

2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/64578
    * gfortran.dg/unlimited_polymorphic_21.f90: New test

Cheers

Paul

-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx
-------------- next part --------------
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 219801)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 7075,7080 ****
--- 7075,7081 ----
  		rse.expr = gfc_class_data_get (rse.expr);
  	      else
  		{
+ 		  gfc_add_block_to_block (&block, &rse.pre);
  		  tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
  		  gfc_add_modify (&lse.pre, tmp, rse.expr);
  
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 7146,7151 ****
--- 7147,7153 ----
  	    }
  	  else
  	    {
+ 	      gfc_add_block_to_block (&block, &rse.pre);
  	      tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
  	      gfc_add_modify (&lse.pre, tmp, rse.expr);
  
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 219800)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_associated (gfc_se *se, gfc_exp
*** 6554,6560 ****
--- 6554,6564 ----
  	    arg1se.expr = build_fold_indirect_ref_loc (input_location,
  						       arg1se.expr);
    	  if (arg1->expr->ts.type == BT_CLASS)
+ 	    {
  	      tmp2 = gfc_class_data_get (arg1se.expr);
+ 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+ 		tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ 	    }
  	  else
  	    tmp2 = arg1se.expr;
          }
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90	(working copy)
***************
*** 0 ****
--- 1,35 ----
+ ! { dg-do run }
+ ! Tests the fix for PR64578.
+ !
+ ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+ !
+   type foo
+      real, allocatable :: component(:)
+   end type
+   type (foo), target :: f
+   class(*), pointer :: ptr(:)
+   allocate(f%component(1),source=[0.99])
+   call associate_pointer(f,ptr)
+   select type (ptr)
+     type is (real)
+       if (abs (ptr(1) - 0.99) > 1e-5) call abort
+   end select
+   ptr => return_pointer(f)  ! runtime segmentation fault
+   if (associated(return_pointer(f)) .neqv. .true.) call abort
+   select type (ptr)
+     type is (real)
+       if (abs (ptr(1) - 0.99) > 1e-5) call abort
+   end select
+ contains
+   subroutine associate_pointer(this, item)
+     class(foo), target :: this
+     class(*), pointer :: item(:)
+     item => this%component
+   end subroutine
+   function return_pointer(this)
+     class(foo), target :: this
+     class(*), pointer :: return_pointer(:)
+     return_pointer => this%component
+   end function
+ end
+