See attached patch.
Regression tested on x86_64. Two new test cases added.
This one was from a long time ago.
OK for mainline?
Regards,
Jerry
---
fortran: [PR47425] Array constructor fails with length type expr
Two separate problems are fixed here. The original test case is fixed
by the one-liner in trans-array.cc. Add check for INTEGER_CST. The
remaining problem starts with parsing and not keeping track of charlens
where some of the charlens are created and later left dangling. Code was
added to keep track of these and remove them as needed.
PR fortran/47425
gcc/fortran/ChangeLog:
* decl.cc (discard_pending_charlen): Use new helper
function.
(discard_pending_charlens): Likewise.
(build_struct): Likewise.
* gfortran.h (struct gfc_charlen): Add a namespace
pointer to track char len for undo.
(struct gfc_undo_change_set): Add cls
pointer to track charlens created during parsing.
(struct gfc_undo_change_set): Add vec<gfc_charlen *> cls.
(gfc_remove_saved_charlen): Declare new helper function.
* parse.cc (accept_statement): Adjust comment.
* symbol.cc (gfc_merge_new_implicit): Use new helper function
(free_undo_change_set_data): Release cls.
(gfc_drop_last_undo_checkpoint): Splice cls into parent
changeset.
(gfc_restore_last_undo_checkpoint): Remove and free charlens
tracked in cls.
(gfc_commit_symbols): Truncate cls.
(gfc_remove_saved_charlen): New function to remove
previously saved char len.
(gfc_free_namespace): Remove charlens from undo before freeing
to prevent double-free.
(gfc_enforce_clean_symbol_state): Clear cls instead of asserting
empty; non-tentative callers leave charlens in cls.
* trans-array.cc (trans_array_constructor): Add guard.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr47425-1.f90: New test.
* gfortran.dg/pr47425-2.f90: New test.
---commit e984c35b10271d5cf7dd1aed5d762566e4e04c4c
Author: Jerry DeLisle <[email protected]>
Date: Tue Jun 30 20:22:28 2026 -0700
fortran: [PR47425] Array constructor fails with length type expr
Two separate problems are fixed here. The original test case is fixed
by the one-liner in trans-array.cc. Add check for INTEGER_CST. The
remaining problem starts with parsing and not keeping track of charlens
where some of the charlens are created and later left dangling. Code was
added to keep track of these and remove them as needed.
PR fortran/47425
gcc/fortran/ChangeLog:
* decl.cc (discard_pending_charlen): Use new helper
function.
(discard_pending_charlens): Likewise.
(build_struct): Likewise.
* gfortran.h (struct gfc_charlen): Add a namespace
pointer to track char len for undo.
(struct gfc_undo_change_set): Add cls
pointer to track charlens created during parsing.
(struct gfc_undo_change_set): Add vec<gfc_charlen *> cls.
(gfc_remove_saved_charlen): Declare new helper function.
* parse.cc (accept_statement): Adjust comment.
* symbol.cc (gfc_merge_new_implicit): Use new helper function
(free_undo_change_set_data): Release cls.
(gfc_drop_last_undo_checkpoint): Splice cls into parent
changeset.
(gfc_restore_last_undo_checkpoint): Remove and free charlens
tracked in cls.
(gfc_commit_symbols): Truncate cls.
(gfc_remove_saved_charlen): New function to remove
previously saved char len.
(gfc_free_namespace): Remove charlens from undo before freeing
to prevent double-free.
(gfc_enforce_clean_symbol_state): Clear cls instead of asserting
empty; non-tentative callers leave charlens in cls.
* trans-array.cc (trans_array_constructor): Add guard.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr47425-1.f90: New test.
* gfortran.dg/pr47425-2.f90: New test.
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 6dad9d9791a..0b2414278cd 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -126,6 +126,7 @@ discard_pending_charlen (gfc_charlen *cl)
if (!cl || !gfc_current_ns || gfc_current_ns->cl_list != cl)
return;
+ gfc_remove_saved_charlen (cl);
gfc_current_ns->cl_list = cl->next;
gfc_free_expr (cl->length);
free (cl);
@@ -146,6 +147,7 @@ discard_pending_charlens (gfc_charlen *saved_cl)
gfc_charlen *cl = gfc_current_ns->cl_list;
gcc_assert (cl);
+ gfc_remove_saved_charlen (cl);
gfc_current_ns->cl_list = cl->next;
gfc_free_expr (cl->length);
free (cl);
@@ -2515,7 +2517,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
c->ts = current_ts;
if (c->ts.type == BT_CHARACTER)
- c->ts.u.cl = cl;
+ {
+ c->ts.u.cl = cl;
+ /* The component struct is not tracked by the symbol undo mechanism,
+ so free the charlen here to prevent a double-free. */
+ gfc_remove_saved_charlen (cl);
+ }
if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
&& (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 907a42a8734..ba08f728e65 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1213,6 +1213,7 @@ typedef struct gfc_charlen
{
struct gfc_expr *length;
struct gfc_charlen *next;
+ struct gfc_namespace *cl_ns; /* Namespace this charlen belongs to, for undo. */
bool length_from_typespec; /* Length from explicit array ctor typespec? */
tree backend_decl;
tree passed_length; /* Length argument explicitly passed. */
@@ -2211,6 +2212,7 @@ struct gfc_undo_change_set
{
vec<gfc_symbol *> syms;
vec<gfc_typebound_proc *> tbps;
+ vec<gfc_charlen *> cls;
gfc_undo_change_set *previous;
};
@@ -3923,6 +3925,7 @@ void gfc_commit_symbols (void);
void gfc_commit_symbol (gfc_symbol *);
gfc_charlen *gfc_new_charlen (gfc_namespace *, gfc_charlen *);
void gfc_free_namespace (gfc_namespace *&);
+void gfc_remove_saved_charlen (gfc_charlen *);
void gfc_symbol_init_2 (void);
void gfc_symbol_done_2 (void);
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 7b6cf525a80..c9b4fbf65ba 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -3269,9 +3269,7 @@ accept_statement (gfc_statement st)
}
-/* Undo anything tentative that has been built for the current statement,
- except if a gfc_charlen structure has been added to current namespace's
- list of gfc_charlen structure. */
+/* Undo anything tentative that has been built for the current statement. */
static void
reject_statement (void)
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 72ffa191954..94305af3b53 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -108,7 +108,7 @@ gfc_gsymbol *gfc_gsym_root = NULL;
gfc_symbol *gfc_derived_types;
-static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, vNULL, NULL };
static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
@@ -216,6 +216,11 @@ gfc_merge_new_implicit (gfc_typespec *ts)
gfc_current_ns->set_flag[i] = 1;
}
}
+
+ /* The charlen belongs to ns->default_type; remove it. */
+ if (ts->type == BT_CHARACTER && ts->u.cl)
+ gfc_remove_saved_charlen (ts->u.cl);
+
return true;
}
@@ -3872,6 +3877,7 @@ free_undo_change_set_data (gfc_undo_change_set &cs)
{
cs.syms.release ();
cs.tbps.release ();
+ cs.cls.release ();
}
@@ -3930,6 +3936,7 @@ gfc_drop_last_undo_checkpoint (void)
latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+ latest_undo_chgset->previous->cls.safe_splice (latest_undo_chgset->cls);
pop_undo_change_set (latest_undo_chgset);
}
@@ -4037,6 +4044,36 @@ gfc_restore_last_undo_checkpoint (void)
latest_undo_chgset->syms.truncate (0);
latest_undo_chgset->tbps.truncate (0);
+ /* Remove charlens added during this failed parse attempt. These are
+ zombie charlens whose length expressions may reference symtrees that
+ have just been freed above via delete_symbol_from_ns. */
+ {
+ gfc_charlen *cl;
+ unsigned i;
+
+ FOR_EACH_VEC_ELT_REVERSE (latest_undo_chgset->cls, i, cl)
+ {
+ gfc_namespace *ns = cl->cl_ns;
+ if (ns != NULL)
+ {
+ if (ns->cl_list == cl)
+ ns->cl_list = cl->next;
+ else
+ {
+ gfc_charlen *prev;
+ for (prev = ns->cl_list; prev && prev->next != cl;
+ prev = prev->next)
+ ;
+ if (prev)
+ prev->next = cl->next;
+ }
+ }
+ gfc_free_expr (cl->length);
+ free (cl);
+ }
+ latest_undo_chgset->cls.truncate (0);
+ }
+
if (!single_undo_checkpoint_p ())
pop_undo_change_set (latest_undo_chgset);
}
@@ -4117,6 +4154,9 @@ gfc_commit_symbols (void)
FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
tbp->error = 0;
latest_undo_chgset->tbps.truncate (0);
+
+ /* Charlens are committed to the namespace; just clear the tracking vector. */
+ latest_undo_chgset->cls.truncate (0);
}
@@ -4318,11 +4358,31 @@ gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
/* Put into namespace. */
cl->next = ns->cl_list;
ns->cl_list = cl;
+ cl->cl_ns = ns;
+
+ /* Track in undo mechanism so reject_statement can remove zombie charlens. */
+ latest_undo_chgset->cls.safe_push (cl);
return cl;
}
+/* Remove the charlen without freeing it. */
+
+void
+gfc_remove_saved_charlen (gfc_charlen *cl)
+{
+ gfc_charlen *tracked;
+ unsigned j;
+ FOR_EACH_VEC_ELT (latest_undo_chgset->cls, j, tracked)
+ if (tracked == cl)
+ {
+ latest_undo_chgset->cls.unordered_remove (j);
+ return;
+ }
+}
+
+
/* Free the charlen list from cl to end (end is not freed).
Free the whole list if end is NULL. */
@@ -4390,6 +4450,16 @@ gfc_free_namespace (gfc_namespace *&ns)
gfc_free_finalizer_list (ns->finalizers);
gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
+
+ /* Remove charlen before freeing. */
+ {
+ gfc_charlen *cl;
+ unsigned j;
+ FOR_EACH_VEC_ELT (latest_undo_chgset->cls, j, cl)
+ if (cl->cl_ns == ns)
+ latest_undo_chgset->cls.unordered_remove (j--);
+ }
+
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
@@ -4627,6 +4697,10 @@ gfc_enforce_clean_symbol_state(void)
{
enforce_single_undo_checkpoint ();
gcc_assert (latest_undo_chgset->syms.is_empty ());
+ /* Charlens may be accumulated by non-tentative contexts such as resolution
+ and translation. Clear them here so tentative parsing in the next
+ statement starts with a clean slate. */
+ latest_undo_chgset->cls.truncate (0);
}
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6ff5ac589fe..7a2dc073e67 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3134,7 +3134,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
if (nelem > 0)
{
tree size = constant_array_constructor_loop_size (loop);
- if (size && compare_tree_int (size, nelem) == 0)
+ if (size && compare_tree_int (size, nelem) == 0
+ && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST)
{
trans_constant_array_constructor (ss, type);
goto finish;
diff --git a/gcc/testsuite/gfortran.dg/pr47425-1.f90 b/gcc/testsuite/gfortran.dg/pr47425-1.f90
new file mode 100644
index 00000000000..7c16c9b01fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr47425-1.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! PR47425
+! Test that gfortran does not ICE on array constructors with a character
+! type-spec containing a function call.
+subroutine pr47425_const(L, s, e)
+ implicit none
+ character(*), intent(in) :: L
+ integer, intent(in) :: s, e
+ ! Constant character length: must compile cleanly.
+ if (any(L(s:e+1) == [character(5) :: 'that', 'those'])) then
+ write (*, *) 'match'
+ end if
+end subroutine pr47425_const
+
+subroutine pr47425_paramlen(s, e, n)
+ implicit none
+ integer, intent(in) :: s, e, n
+ ! Variable length from a plain integer dummy: must compile cleanly.
+ if (any(['that', 'thos'] == [character(n) :: 'that', 'thos'])) then
+ write (*, *) 'match'
+ end if
+end subroutine pr47425_paramlen
diff --git a/gcc/testsuite/gfortran.dg/pr47425-2.f90 b/gcc/testsuite/gfortran.dg/pr47425-2.f90
new file mode 100644
index 00000000000..fa59764f986
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr47425-2.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! PR47425 Test case from original report
+subroutine sub1(L,s,e)
+ implicit none
+ character(*) L
+ integer s,e
+ if(any(L(s:e+1) == [character(len(L(s:e))+1)::'that','those'])) then
+ end if
+end subroutine sub1
