Fortran: Fix ICE with allocation of scalar pointer entity [PR114021]

2026-03-27  Paul Thomas  <pault@gcc.gnu.org>

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.

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 32d12600a19f7a9e241f335277801d2b64d29df7..e1b49b0ba0da92901cf86e5aa2eced494750aa94 100644 (file)
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -3206,7 +3206,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 c02b258e8444d1732f91bb00daebae36d9ca52be..a67248f7afa51b473aa4d8fbdf2239a80f274529 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11756,6 +11756,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 4d2ca182f808d87401f6b600e6891eb6f0118a66..49f8cd8d7ac4f70c75958a66f04c8f4b73e2c87a 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6923,6 +6923,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
          && (code->expr3->ts.u.derived->attr.alloc_comp
              || code->expr3->ts.u.derived->attr.pdt_type)
          && !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,
@@ -7086,11 +7087,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 (file)
index 0000000..49ee275
--- /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  <kargl@gcc.gnu.org>
+!
+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