This patch fixes PRs 93924/5. It is another 'obvious' patch, whose
consequences are very limited.

I am trying to slip in as many small ready-to-go patches as I can before we
go too far into stage 4. It would be nice to have the patch for PR98573
(posted 23rd Jan) OK'd before the end of the week.

Cheers

Paul

Fortran: Fix ICE due to elemental procedure pointers [PR93924/5].

2021-01-27  Paul Thomas  <pa...@gcc.gnu.org>

gcc/fortran
PR fortran/93924
PR fortran/93925
* trans-expr.c (gfc_conv_procedure_call): Suppress the call to
gfc_conv_intrinsic_to_class for unlimited polymorphic procedure
pointers.
(gfc_trans_assignment_1): Similarly suppress class assignment
for class valued procedure pointers.

gcc/testsuite/
PR fortran/93924
PR fortran/93925
* gfortran.dg/proc_ptr_52.f90 : New test.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7150e48bc93..b0c8d577ca5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5772,7 +5772,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     CLASS_DATA (fsym)->attr.class_pointer
 				     || CLASS_DATA (fsym)->attr.allocatable);
 	}
-      else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
+      else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
+	       && gfc_expr_attr (e).flavor != FL_PROCEDURE)
 	{
 	  /* The intrinsic type needs to be converted to a temporary
 	     CLASS object for the unlimited polymorphic formal.  */
@@ -11068,7 +11069,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 		       || gfc_is_class_array_ref (expr1, NULL)
 		       || gfc_is_class_scalar_expr (expr1)
 		       || gfc_is_class_array_ref (expr2, NULL)
-		       || gfc_is_class_scalar_expr (expr2));
+		       || gfc_is_class_scalar_expr (expr2))
+		   && lhs_attr.flavor != FL_PROCEDURE;

   realloc_flag = flag_realloc_lhs
 		 && gfc_is_reallocatable_lhs (expr1)
! { dg-do run }
!
! Test the fix for PRs93924 & 93925.
!
! Contributed by Martin Stein  <ms...@gmx.net>
!
module cs

implicit none

integer, target :: integer_target

abstract interface
   function classStar_map_ifc(x) result(y)
      class(*), pointer            :: y
      class(*), target, intent(in) :: x
   end function classStar_map_ifc
end interface

contains

   function fun(x) result(y)
      class(*), pointer            :: y
      class(*), target, intent(in) :: x
      select type (x)
      type is (integer)
         integer_target = x        ! Deals with dangling target.
         y => integer_target
      class default
         y => null()
      end select
   end function fun

   function apply(f, x) result(y)
      procedure(classStar_map_ifc) :: f
      integer, intent(in) :: x
      integer :: y
      class(*), pointer :: p
      y = 0                        ! Get rid of 'y' undefined warning
      p => f (x)
      select type (p)
      type is (integer)
         y = p
      end select
   end function apply

   function selector() result(f)
      procedure(classStar_map_ifc), pointer :: f
      f => fun
   end function selector

end module cs


program classStar_map

use cs
implicit none

integer :: x, y
procedure(classStar_map_ifc), pointer :: f

x = 123654
f => selector ()               ! Fixed by second chunk in patch
y = apply (f, x)               ! Fixed by first chunk in patch
if (x .ne. y) stop 1

x = 2 * x
y = apply (fun, x)             ! PR93925; fixed as above
if (x .ne. y) stop 2

end program classStar_map

Reply via email to