Hello All, Thanks to Harald for pointing out this low hanging fruit to me.
The original ICE has changed to one that is easily identified and fixed: dereferencing a NULL pointer in trans_allocate. This is fixed in the third chunk. In this case, a symtree is now provided by a modified version of gfc_get_unique symtree, which is the content of the first chunk. Also, deallocation of non-variable, pointer source allocatable components has been suppressed in the second chunk. The resulting behaviour of the testcase has been tested against that of other brands, since it wasn't evident to me from reading the F2018 standard that the deep copy of the allocatable component is correct. Regtested on FC43/x86_64 - OK for mainline? Paul
Change.Logs
Description: Binary data
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-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..aa28979e374
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114021.f90
@@ -0,0 +1,51 @@
+! { 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.
+!
+! 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
+
+ use m1
+ call s1
+ w%x1 = [1.0,2.0]
+ if (c /= 1) stop 1
+ w%x1 = [3.0,4.0]
+ call s2
+ if (c /= 2) stop 2
+ if (.not.allocated (w%x1) .or. any (abs (w%x1 - [3.0,4.0]) > 1e-6)) stop 4
+ if (allocated (w%x1)) deallocate (w%x1)
+end
