Fortran: Add DECL_EXPR for variable length assoc name [PR117901]

2024-12-11  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/117901
	* trans-stmt.cc (trans_associate_var): A variable character
	length array associate name must generate a DECL expression for
	the data pointer type.

gcc/testsuite/
	PR fortran/117901
	* gfortran.dg/pr117901.f90: New test.

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 80a9502a8a413e859136a609192bd7dfbe2ff4e5..ae3266fb867f553b4004dc657af5f8798cd6dcef 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2065,6 +2065,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
                  || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
 
+      if (sym->ts.type == BT_CHARACTER)
+       {
+         /* Emit a DECL_EXPR for the variable sized array type in so the
+            gimplification of its type sizes works correctly.  */
+         tree arraytype;
+         tmp = TREE_TYPE (sym->backend_decl);
+         arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (tmp));
+         if (! TYPE_NAME (arraytype))
+           TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
+                                               NULL_TREE, arraytype);
+         gfc_add_expr_to_block (&se.pre, build1 (DECL_EXPR,
+                                arraytype, TYPE_NAME (arraytype)));
+       }
+
       if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
        {
          if (INDIRECT_REF_P (se.expr))

diff --git a/gcc/testsuite/gfortran.dg/pr117901.f90 b/gcc/testsuite/gfortran.dg/pr117901.f90
new file mode 100644 (file)
index 0000000..b5c3a4f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117901.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! { dg-options "-O3" }
+!
+! Test the fix for pr117901, in which the variable length character in
+! the SELECT TYPE construct caused an ICE in make_ssa_name_fn. This is
+! a much reduced testcase, extracted from class_transformational_1.f90.
+! Note that it does not have references to transformational functions
+! of class objects!
+!
+Module class_tests
+contains
+  subroutine class_rebar (arg)
+    class(*), allocatable :: arg(:)
+    call class_bar (arg)
+  end
+  subroutine class_bar(x)
+    class(*), intent(in) :: x(..)
+    integer :: checksum
+    select rank (x)
+      rank (1)
+        select type (x)
+          type is (character(*))
+            checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2)))
+            print *, checksum
+        end select
+      rank (2)
+      rank (3)
+      end select
+  end
+end module class_tests