https://gcc.gnu.org/g:31f66a843429269ee9cdc6ce69ba3ff698773a35
commit r17-3155-g31f66a843429269ee9cdc6ce69ba3ff698773a35 Author: Jerry DeLisle <[email protected]> Date: Sat Aug 8 08:59:16 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: --- gcc/fortran/decl.cc | 9 +++- gcc/fortran/gfortran.h | 3 ++ gcc/fortran/parse.cc | 4 +- gcc/fortran/symbol.cc | 76 ++++++++++++++++++++++++++++++++- gcc/fortran/trans-array.cc | 3 +- gcc/testsuite/gfortran.dg/pr47425-1.f90 | 22 ++++++++++ gcc/testsuite/gfortran.dg/pr47425-2.f90 | 9 ++++ 7 files changed, 120 insertions(+), 6 deletions(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 7c10ee5e5726..5bd1e3de2d94 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 cb08a6098284..5bd8dd50c1c9 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1223,6 +1223,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. */ @@ -2224,6 +2225,7 @@ struct gfc_undo_change_set { vec<gfc_symbol *> syms; vec<gfc_typebound_proc *> tbps; + vec<gfc_charlen *> cls; gfc_undo_change_set *previous; }; @@ -3937,6 +3939,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 59ef6bb2c2a6..47b443c4a5fb 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -3284,9 +3284,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 1349fe3a2fb3..36e1262fff5a 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 91fa43b26831..7d23515e5d86 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -2677,7 +2677,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 000000000000..7c16c9b01fe5 --- /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 000000000000..fa59764f986c --- /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
