Fortran: Fix a gimplifier ICE/wrong result with finalization [PR36337]

2024-03-29  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/36337
	PR fortran/110987
	PR fortran/113885
	* trans-expr.cc (gfc_trans_assignment_1): Place finalization
	block before rhs post block for elemental rhs.
	* trans.cc (gfc_finalize_tree_expr): Check directly if a type
	has no components, rather than the zero components attribute.
	Treat elemental zero component expressions in the same way as
	scalars.

gcc/testsuite/
	PR fortran/113885
	* gfortran.dg/finalize_54.f90: New test.
	* gfortran.dg/finalize_55.f90: New test.

gcc/testsuite/
	PR fortran/110987
	* gfortran.dg/finalize_56.f90: New test.

(cherry picked from commit 3c793f0)

Author: Paul Thomas

gcc/fortran/trans-expr.cc

@@ -12182,11 +12182,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
 
-  /* Add the post blocks to the body.  */
-  if (!l_is_temp)
+  /* Add the post blocks to the body.  Scalar finalization must appear before
+     the post block in case any dellocations are done.  */
+  if (rse.finalblock.head
+      && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
+			 && gfc_expr_attr (expr2).elemental)))
     {
-      gfc_add_block_to_block (&rse.finalblock, &rse.post);
       gfc_add_block_to_block (&body, &rse.finalblock);
+      gfc_add_block_to_block (&body, &rse.post);
     }
   else
     gfc_add_block_to_block (&body, &rse.post);

gcc/fortran/trans.cc

@@ -1527,7 +1527,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
     }
   else if (derived && gfc_is_finalizable (derived, NULL))
     {
-      if (derived->attr.zero_comp && !rank)
+      if (!derived->components && (!rank || attr.elemental))
 	{
 	  /* Any attempt to assign zero length entities, causes the gimplifier
 	     all manner of problems. Instead, a variable is created to act as
@@ -1578,7 +1578,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 					      final_fndecl);
   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
     {
-      if (is_class)
+      if (is_class || attr.elemental)
 	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
       else
 	{
@@ -1588,7 +1588,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
 	}
     }
 
-  if (derived && derived->attr.zero_comp)
+  if (derived && !derived->components)
     {
       /* All the conditions below break down for zero length derived types.  */
       tmp = build_call_expr_loc (input_location, final_fndecl, 3,

gcc/testsuite/gfortran.dg/finalize_54.f90

@@ -0,0 +1,47 @@
+! { dg-do compile }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but, with a component, gfortran
+! gave wrong results.
+! Contributed by David Binderman  <dcb314@hotmail.com>
+!
+module types
+  type t
+   contains
+     final :: finalize
+  end type t
+contains
+  pure subroutine finalize(x)
+    type(t), intent(inout) :: x
+  end subroutine finalize
+end module types
+
+subroutine test1(x)
+  use types
+  interface
+     elemental function elem(x)
+       use types
+       type(t), intent(in) :: x
+       type(t) :: elem
+     end function elem
+  end interface
+  type(t) :: x(:)
+  x = elem(x)
+end subroutine test1
+
+subroutine test2(x)
+  use types
+  interface
+     elemental function elem(x)
+       use types
+       type(t), intent(in) :: x
+       type(t) :: elem
+     end function elem
+     elemental function elem2(x, y)
+       use types
+       type(t), intent(in) :: x, y
+       type(t) :: elem2
+     end function elem2
+  end interface
+  type(t) :: x(:)
+  x = elem2(elem(x), elem(x))
+end subroutine test2

gcc/testsuite/gfortran.dg/finalize_55.f90

@@ -0,0 +1,89 @@
+! { dg-do run }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but this version gave wrong
+! results.
+! Contributed by David Binderman  <dcb314@hotmail.com>
+!
+module types
+  type t
+     integer :: i
+   contains
+     final :: finalize
+  end type t
+  integer :: ctr = 0
+contains
+  impure elemental subroutine finalize(x)
+    type(t), intent(inout) :: x
+    ctr = ctr + 1
+  end subroutine finalize
+end module types
+
+impure elemental function elem(x)
+  use types
+  type(t), intent(in) :: x
+  type(t) :: elem
+  elem%i = x%i + 1
+end function elem
+
+impure elemental function elem2(x, y)
+  use types
+  type(t), intent(in) :: x, y
+  type(t) :: elem2
+  elem2%i = x%i + y%i
+end function elem2
+
+subroutine test1(x)
+  use types
+  interface
+     impure elemental function elem(x)
+       use types
+       type(t), intent(in) :: x
+       type(t) :: elem
+     end function elem
+  end interface
+  type(t) :: x(:)
+  type(t), allocatable :: y(:)
+  y = x
+  x = elem(y)
+end subroutine test1
+
+subroutine test2(x)
+  use types
+  interface
+     impure elemental function elem(x)
+       use types
+       type(t), intent(in) :: x
+       type(t) :: elem
+     end function elem
+     impure elemental function elem2(x, y)
+       use types
+       type(t), intent(in) :: x, y
+       type(t) :: elem2
+     end function elem2
+  end interface
+  type(t) :: x(:)
+  type(t), allocatable :: y(:)
+  y = x
+  x = elem2(elem(y), elem(y))
+end subroutine test2
+
+program test113885
+  use types
+  interface
+    subroutine test1(x)
+      use types
+      type(t) :: x(:)
+    end subroutine
+    subroutine test2(x)
+      use types
+      type(t) :: x(:)
+    end subroutine
+  end interface
+  type(t) :: x(2) = [t(1),t(2)]
+  call test1 (x)
+  if (any (x%i .ne. [2,3])) stop 1
+  if (ctr .ne. 6) stop 2
+  call test2 (x)
+  if (any (x%i .ne. [6,8])) stop 3
+  if (ctr .ne. 16) stop 4
+end

gcc/testsuite/gfortran.dg/finalize_56.f90

@@ -0,0 +1,168 @@
+! { dg-do run }
+! Test the fix for PR110987
+! Segfaulted in runtime, as shown below.
+! Contributed by Kirill Chankin  <chilikin.k@gmail.com>
+! and John Haiducek  <jhaiduce@gmail.com> (comment 5)
+!
+MODULE original_mod
+  IMPLICIT NONE
+
+  TYPE T1_POINTER
+    CLASS(T1), POINTER :: T1
+  END TYPE
+
+  TYPE T1
+    INTEGER N_NEXT
+    CLASS(T1_POINTER), ALLOCATABLE :: NEXT(:)
+  CONTAINS
+    FINAL :: T1_DESTRUCTOR
+    PROCEDURE :: SET_N_NEXT => T1_SET_N_NEXT
+    PROCEDURE :: GET_NEXT => T1_GET_NEXT
+  END TYPE
+
+  INTERFACE T1
+    PROCEDURE T1_CONSTRUCTOR
+  END INTERFACE
+
+  TYPE, EXTENDS(T1) :: T2
+    REAL X
+  CONTAINS
+  END TYPE
+
+  INTERFACE T2
+    PROCEDURE T2_CONSTRUCTOR
+  END INTERFACE
+
+  TYPE, EXTENDS(T1) :: T3
+  CONTAINS
+    FINAL :: T3_DESTRUCTOR
+  END TYPE
+
+  INTERFACE T3
+    PROCEDURE T3_CONSTRUCTOR
+  END INTERFACE
+
+  INTEGER :: COUNTS = 0
+
+CONTAINS
+
+  TYPE(T1) FUNCTION T1_CONSTRUCTOR() RESULT(L)
+    IMPLICIT NONE
+    L%N_NEXT = 0
+  END FUNCTION
+
+  SUBROUTINE T1_DESTRUCTOR(SELF)
+    IMPLICIT NONE
+    TYPE(T1), INTENT(INOUT) :: SELF
+    IF (ALLOCATED(SELF%NEXT)) THEN
+      DEALLOCATE(SELF%NEXT)
+    ENDIF
+  END SUBROUTINE
+
+  SUBROUTINE T3_DESTRUCTOR(SELF)
+    IMPLICIT NONE
+    TYPE(T3), INTENT(IN) :: SELF
+    if (.NOT.ALLOCATED (SELF%NEXT)) COUNTS = COUNTS + 1
+  END SUBROUTINE
+
+  SUBROUTINE T1_SET_N_NEXT(SELF, N_NEXT)
+    IMPLICIT NONE
+    CLASS(T1), INTENT(INOUT) :: SELF
+    INTEGER, INTENT(IN) :: N_NEXT
+    INTEGER I
+    SELF%N_NEXT = N_NEXT
+    ALLOCATE(SELF%NEXT(N_NEXT))
+    DO I = 1, N_NEXT
+      NULLIFY(SELF%NEXT(I)%T1)
+    ENDDO
+  END SUBROUTINE
+
+  FUNCTION T1_GET_NEXT(SELF) RESULT(NEXT)
+    IMPLICIT NONE
+    CLASS(T1), TARGET, INTENT(IN) :: SELF
+    CLASS(T1), POINTER :: NEXT
+    CLASS(T1), POINTER :: L
+    INTEGER I
+    IF (SELF%N_NEXT .GE. 1) THEN
+      NEXT => SELF%NEXT(1)%T1
+      RETURN
+    ENDIF
+    NULLIFY(NEXT)
+  END FUNCTION
+
+  TYPE(T2) FUNCTION T2_CONSTRUCTOR() RESULT(L)
+    IMPLICIT NONE
+    L%T1 = T1()
+    CALL L%T1%SET_N_NEXT(1)
+  END FUNCTION
+
+  TYPE(T3) FUNCTION T3_CONSTRUCTOR() RESULT(L)
+    IMPLICIT NONE
+    L%T1 = T1()
+  END FUNCTION
+
+END MODULE original_mod
+
+module comment5_mod
+  type::parent
+     character(:), allocatable::name
+  end type parent
+  type, extends(parent)::child
+   contains
+     final::child_finalize
+  end type child
+  interface child
+     module procedure new_child
+  end interface child
+  integer :: counts = 0
+
+contains
+
+  type(child) function new_child(name)
+    character(*)::name
+    new_child%name=name
+  end function new_child
+
+  subroutine child_finalize(this)
+    type(child), intent(in)::this
+    counts = counts + 1
+  end subroutine child_finalize
+end module comment5_mod
+
+PROGRAM TEST_PROGRAM
+  call original
+  call comment5
+contains
+  subroutine original
+    USE original_mod
+    IMPLICIT NONE
+    TYPE(T1), TARGET :: X1
+    TYPE(T2), TARGET :: X2
+    TYPE(T3), TARGET :: X3
+    CLASS(T1), POINTER :: L
+    X1 = T1()
+    X2 = T2()
+    X2%NEXT(1)%T1 => X1
+    X3 = T3()
+    CALL X3%SET_N_NEXT(1)
+    X3%NEXT(1)%T1 => X2
+    L => X3
+    DO WHILE (.TRUE.)
+      L => L%GET_NEXT()                 ! Used to segfault here in runtime
+      IF (.NOT. ASSOCIATED(L)) EXIT
+      COUNTS = COUNTS + 1
+    ENDDO
+! Two for T3 finalization and two for associated 'L's
+    IF (COUNTS .NE. 4) STOP 1
+  end subroutine original
+
+  subroutine comment5
+    use comment5_mod, only: child, counts
+    implicit none
+    type(child)::kid
+    kid = child("Name")
+    if (.not.allocated (kid%name)) stop 2
+    if (kid%name .ne. "Name") stop 3
+    if (counts .ne. 2) stop 4
+  end subroutine comment5
+END PROGRAM