Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]

2024-05-13  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/113363
	* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
	that the correct element size is used.
	* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
	that ss and ss->loop be present for the finalization of class
	array function results.
	(trans_class_assignment): Use free and malloc, rather than
	realloc, for character expressions assigned to unlimited poly
	entities.
	* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
	the assignment of an unlimited polymorphic 'source'.

gcc/testsuite/
	PR fortran/113363
	* gfortran.dg/pr113363.f90: New test.

1 files changed, 86 insertions, 0 deletions

diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90
new file mode 100644
index 0000000..99d4f20
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113363.f90
@@ -0,0 +1,86 @@
+! { dg-do run }
+! Test the fix for comment 1 in PR113363, which failed as in comments below.
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+program p
+  implicit none
+  class(*), allocatable :: x(:), y
+  character(*), parameter :: arr(2) = ["hello ","bye   "], &
+                             sca = "Have a nice day"
+  character(10) :: const
+
+! Bug was detected in polymorphic array function results
+  allocate(x, source = foo ())
+  call check1 (x, arr)              ! Wrong output "6 hello e"
+  deallocate (x)
+  x = foo ()
+  call check1 (x, arr)              ! Wrong output "0  "
+  associate (var => foo ())         ! OK after r14-9489-g3fd46d859cda10
+    call check1 (var, arr)          ! Now OK - outputs: "6 hello bye   "
+  end associate
+
+! Check scalar function results     ! All OK
+  allocate (y, source = bar())
+  call check2 (y, sca)
+  deallocate (y)
+  y = bar ()
+  call check2 (y, sca)
+  deallocate (y)
+  associate (var => bar ())
+    call check2 (var, sca)
+  end associate
+
+! Finally variable expressions...
+  allocate (y, source = x(1))       ! Gave zero length here
+  call check2 (y, "hello")
+  y = x(2)                          ! Segfaulted here
+  call check2 (y, "bye   ")
+  associate (var => x(2))           ! Gave zero length here
+    call check2 (var, "bye   ")
+  end associate
+
+! ...and constant expressions       ! All OK
+  deallocate(y)
+  allocate (y, source = "abcde")
+  call check2 (y, "abcde")
+  const = "hijklmnopq"
+  y = const
+  call check2 (y, "hijklmnopq")
+  associate (var => "mnopq")
+    call check2 (var, "mnopq")
+  end associate
+  deallocate (x, y)
+
+contains
+
+  function foo() result(res)
+    class(*), allocatable :: res(:)
+    res = arr
+  end function foo
+
+  function bar() result(res)
+    class(*), allocatable :: res
+    res = sca
+  end function bar
+
+  subroutine check1 (x, carg)
+    class(*), intent(in) :: x(:)
+    character(*) :: carg(:)
+    select type (x)
+    type is (character(*))
+      if (any (x .ne. carg)) stop 1
+    class default
+       stop 2
+    end select
+  end subroutine check1
+
+  subroutine check2 (x, carg)
+    class(*), intent(in) :: x
+    character(*) :: carg
+    select type (x)
+    type is (character(*))
+      if (x .ne. carg) stop 3
+    class default
+       stop 4
+    end select
+  end subroutine check2
+end