[Patch, fortran] PR93678 - [11/12/13/14 Regression] ICE with TRANSFER and typebound procedures

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 569 bytes --]

Hi there,

This regression turned out to be low hanging fruit, although it has taken
four years to reach it :-(

The ChangeLog says it all. OK for mainline and backporting after a suitable
delay?

Paul

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

2024-04-24  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.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 2047 bytes --]

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 605434f4ddb..072adf3fe77 100644
--- 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
index 00000000000..403bedd0c4f
--- /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