[gcc r15-11479] Fortran: Fix ICE with allocation of scalar pointer entity [PR114021]

https://gcc.gnu.org/g:ca85bd3e8a1f44ac61800e3f4ec4e93356e9065a

commit r15-11479-gca85bd3e8a1f44ac61800e3f4ec4e93356e9065a
Author: Paul Thomas <[email protected]>
Date:   Fri Mar 27 10:50:39 2026 +0000

    Fortran: Fix ICE with allocation of scalar pointer entity [PR114021]
    
    2026-03-27  Paul Thomas  <[email protected]>
    
    gcc/fortran
            PR fortran/114021
            * symbol.cc (gfc_get_unique_symtree): If the namespace argument
            is NULL, allocate a new symtree and provide it with the unique
            name.
            * trans-expr.cc (trans_scalar_assign): In the deep copy of a
            derived type with allocatable components, fix the rhs value if
            it is not a constant or a variable.
            * trans-stmt.cc (gfc_trans_allocate): Do not deallocate
            allocatable components of a source that is not a variable and
            is a pointer. If the DECL_NAME or its IDENTIFIER_POINTER are
            null,use gfc_get_unique_symtree with NULL namespace to obtain a
            symtree for the assignment.
    
    gcc/testsuite/
            PR fortran/114021
            * gfortran.dg/pr114021.f90: New test.
    
    (cherry picked from commit e3cd8908019f4c023e6494fcd4a5acb60f98ed63)

Diff:
---
 gcc/fortran/symbol.cc                  | 10 +++++-
 gcc/fortran/trans-expr.cc              |  2 ++
 gcc/fortran/trans-stmt.cc              | 12 +++++--
 gcc/testsuite/gfortran.dg/pr114021.f90 | 64 ++++++++++++++++++++++++++++++++++
 4 files changed, 84 insertions(+), 4 deletions(-)

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index a862eb2abb06..98dcec566b56 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -3090,7 +3090,15 @@ gfc_get_unique_symtree (gfc_namespace *ns)
   static int serial = 0;
 
   sprintf (name, "@%d", serial++);
-  return gfc_new_symtree (&ns->sym_root, name);
+  if (ns)
+    return gfc_new_symtree (&ns->sym_root, name);
+  else
+    {
+      /* Some uses need a symtree that is cleaned up locally.  */
+      gfc_symtree *st = XCNEW (gfc_symtree);
+      st->name = gfc_get_string ("%s", name);
+      return st;
+    }
 }
 
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 58bd7197122d..0080d3248bec 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11601,6 +11601,8 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
       /* Are the rhs and the lhs the same?  */
       if (deep_copy)
 	{
+	  if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
+	    rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
 	  cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
 				  gfc_build_addr_expr (NULL_TREE, lse->expr),
 				  gfc_build_addr_expr (NULL_TREE, rse->expr));
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 37f8acaea3f6..56dfa169fac2 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6777,6 +6777,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	  && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
 	  && code->expr3->ts.u.derived->attr.alloc_comp
 	  && !code->expr3->must_finalize
+	  && !gfc_expr_attr (code->expr3).pointer
 	  && !code->ext.alloc.expr3_not_explicit)
 	{
 	  tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
@@ -6940,11 +6941,16 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
 	  /* Build a temporary symtree and symbol.  Do not add it to the current
 	     namespace to prevent accidentaly modifying a colliding
 	     symbol's as.  */
-	  newsym = XCNEW (gfc_symtree);
 	  /* The name of the symtree should be unique, because gfc_create_var ()
 	     took care about generating the identifier.  */
-	  newsym->name
-	    = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3)));
+	  if (DECL_NAME (expr3) && IDENTIFIER_POINTER (DECL_NAME (expr3)))
+	    {
+	      const char *name = IDENTIFIER_POINTER (DECL_NAME (expr3));
+	      newsym = XCNEW (gfc_symtree);
+	      newsym->name = gfc_get_string ("%s", name);
+	    }
+	  else
+	    newsym = gfc_get_unique_symtree (NULL);
 	  newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
 	  /* The backend_decl is known.  It is expr3, which is inserted
 	     here.  */
diff --git a/gcc/testsuite/gfortran.dg/pr114021.f90 b/gcc/testsuite/gfortran.dg/pr114021.f90
new file mode 100644
index 000000000000..49ee27550776
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114021.f90
@@ -0,0 +1,64 @@
+! { dg-do run }
+!
+! Test the fix for PR114021 in which the ALLOCATE statement caused an ICE.
+! The test checks that f() is called once per allocation, that the result
+! of the allocation is correct and that a deep copy of w%x1 has been effected
+! in 's2' without freeing it. 's3' is a variant, which produced no fewer than
+! three calls to f() in the course of the assignment and the deep copy of
+! the allocatable component.
+!
+! Contributed by Steve Kargl  <[email protected]>
+!
+module m1
+   type y
+      integer, allocatable:: x1(:)
+   end type
+   type(y), target :: w
+   integer :: c = 0
+contains
+   function f()
+      type(y), pointer :: f
+      f => w
+      c = c + 1
+   end function
+end
+
+subroutine s1
+   use m1
+   type(y), allocatable :: x
+   allocate(x, source = f())
+   if ((c /= 1) .or. (allocated (x%x1))) stop 1
+end
+
+subroutine s2
+   use m1
+   type(y), pointer :: x
+   allocate(x, source = f())
+   if ((c /= 2) .or. (.not.allocated (x%x1))) stop 2
+   if (any (abs (x%x1 - [3.0,4.0]) > 1e-6)) stop 3
+   x%x1 = [5.0,6.0]
+   if (allocated (x%x1)) deallocate (x%x1)
+   if (associated (x)) deallocate (x)
+end
+
+subroutine s3
+  use m1
+  implicit none
+  type(y), allocatable :: x
+  allocate (x)
+  x = f()
+  if (any (abs (x%x1 - [3.0,4.0]) > 1e-6)) stop 4
+end
+
+   use m1
+   call s1
+   w%x1 = [1.0,2.0]
+   if (c /= 1) stop 5
+   w%x1 = [3.0,4.0]
+   call s2
+   if (c /= 2) stop 6
+   call s3
+   if (c /= 3) stop 7
+   if (.not.allocated (w%x1) .or. any (abs (w%x1 - [3.0,4.0]) > 1e-6)) stop 8
+   if (allocated (w%x1)) deallocate (w%x1)
+end