Fortran: Fix ICE in gfc_trans_create_temp_array from bad type [PR93678]

2024-04-25  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/93678
	* trans-expr.cc (gfc_conv_procedure_call): Use the interface,
	where possible, to obtain the type of character procedure
	pointers of class entities.

gcc/testsuite/
	PR fortran/93678
	* gfortran.dg/pr93678.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 605434f4ddb7fdf1b2f3d6d99fe951f162843019..072adf3fe77e9fdb7dac151cc3ad840ffab396a9 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7879,8 +7879,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
        {
          gcc_assert (se->loop && info);
 
-         /* Set the type of the array.  */
-         tmp = gfc_typenode_for_spec (&comp->ts);
+         /* Set the type of the array. vtable charlens are not always reliable.
+            Use the interface, if possible.  */
+         if (comp->ts.type == BT_CHARACTER
+             && expr->symtree->n.sym->ts.type == BT_CLASS
+             && comp->ts.interface && comp->ts.interface->result)
+           tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
+         else
+           tmp = gfc_typenode_for_spec (&comp->ts);
          gcc_assert (se->ss->dimen == se->loop->dimen);
 
          /* Evaluate the bounds of the result, if known.  */

diff --git a/gcc/testsuite/gfortran.dg/pr93678.f90 b/gcc/testsuite/gfortran.dg/pr93678.f90
new file mode 100644 (file)
index 0000000..403bedd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr93678.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test the fix for PR93678 in which the charlen for the 'unpackbytes'
+! vtable field was incomplete and caused the ICE as indicated.
+! Contributed by Luis Kornblueh  <mail.luis@web.de>
+!
+! The testcase was reduced by various gfortran regulars.
+module mo_a
+  implicit none
+  type t_b
+    integer :: i
+  contains
+    procedure :: unpackbytes => b_unpackbytes
+  end type t_b
+contains
+  function b_unpackbytes (me) result (res)
+    class(t_b), intent(inout) :: me
+    character                 :: res(1)
+    res = char (me%i)
+  end function b_unpackbytes
+  subroutine b_unpackint (me, c)
+    class(t_b), intent(inout) :: me
+    character, intent(in) :: c
+!   print *, b_unpackbytes (me) ! ok
+    if (any (me% unpackbytes () .ne. c)) stop 1 ! ICEd here
+  end subroutine b_unpackint
+end module mo_a
+
+  use mo_a
+  class(t_b), allocatable :: z
+  allocate (z, source = t_b(97))
+  call b_unpackint (z, "a")
+end