From: Paul Thomas Date: Fri, 27 Mar 2026 10:50:39 +0000 (+0000) Subject: Fortran: Fix ICE with allocation of scalar pointer entity [PR114021] X-Git-Tag: basepoints/gcc-17~501 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=e3cd8908019f4c023e6494fcd4a5acb60f98ed63;p=thirdparty%2Fgcc.git Fortran: Fix ICE with allocation of scalar pointer entity [PR114021] 2026-03-27 Paul Thomas 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 32d12600a19..e1b49b0ba0d 100644 --- 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 c02b258e844..a67248f7afa 100644 --- 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 4d2ca182f80..49f8cd8d7ac 100644 --- 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 index 00000000000..49ee2755077 --- /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 +! +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