[Patch, fortran] [0/5] PR54730 ICE: confused by type-like fonctions

[Mikael Morin <mikael dot morin at sfr dot fr>]

Hello, this is a fix for cases like:

program main
  implicit none
  intrinsic :: real
  print *,(/ real(a = 1) /)
end

where `real(a = 1)' is initially parsed as a typespec, creating
a symbol for 'a' along the way.  The match fails, and then it is parsed
as a constructor element and accepted that way.  However, accepting the
statement implies accepting all the symbols created so far including 'a',
which is wrong and leads to the ICE.

To handle correctly this, we have to remove 'a' before proceeding with
the second parse attempt.  However, we can't use gfc_undo_symbols, as
it would also remove 'b' in the following case.
  b = (/ real(a = 1) /)
The fix proposed here implements a partial undo framework.  It packs the
changed_syms and tentative_tbp variables into a single 'gfc_change_set'
struct, and makes it possible to have more than one of those structs,
organised as a stack.  That change makes the current linked list
implementation using in-symbol 'tlink' pointer impractical as it prevents
the same symbol from being in more than one changeset.  I don't really know
whether that is a true limitation, but have decided to lift it anyway by
registering the symbols in a vector instead.  This makes backporting a bit
more difficult unfortunately; I will submit the (yet nonexisting) backport
patches separately.


The work is divided as follows:
1/5: Pack the changed_syms and tentative_tbp variables in a 'gfc_change_set'
     struct and move to the vec API.
2/5: New function restore_old_symbol, extracted from gfc_undo_symbols.
3/5: Fix restore_old_symbol
4/5: Add support for more than one 'gfc_change_set' variable.
5/5: Fix gfc_match_array_constructor using the just introduced functions.

The patches are attached to the follow-up mails; the full diff is also provided
here.

Bootstrap-asan'ed and regression tested on x86_64-unknown-linux-gnu.
OK for trunk?

diff --git a/Make-lang.in b/Make-lang.in
index 3584dd8..8c9e7ea 100644
--- a/Make-lang.in
+++ b/Make-lang.in
@@ -327,7 +327,7 @@ $(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \
 		fortran/intrinsic.h fortran/match.h fortran/constructor.h \
 		fortran/parse.h fortran/arith.h fortran/target-memory.h \
 		$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
-		dumpfile.h $(TREE_H) dumpfile.h $(GGC_H) \
+		dumpfile.h $(TREE_H) dumpfile.h $(GGC_H) $(VEC_H) \
 		$(FLAGS_H) $(DIAGNOSTIC_H) errors.h $(FUNCTION_H) \
 		fortran/iso-c-binding.def fortran/iso-fortran-env.def
 fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h
diff --git a/array.c b/array.c
index 6787c05..b4a028b 100644
--- a/array.c
+++ b/array.c
@@ -1046,6 +1046,7 @@ match
 gfc_match_array_constructor (gfc_expr **result)
 {
   gfc_constructor_base head, new_cons;
+  gfc_change_set changed_syms;
   gfc_expr *expr;
   gfc_typespec ts;
   locus where;
@@ -1074,6 +1075,7 @@ gfc_match_array_constructor (gfc_expr **result)
 
   /* Try to match an optional "type-spec ::"  */
   gfc_clear_ts (&ts);
+  gfc_new_checkpoint (changed_syms);
   if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
     {
       seen_ts = (gfc_match (" ::") == MATCH_YES);
@@ -1082,19 +1084,28 @@ gfc_match_array_constructor (gfc_expr **result)
 	{
 	  if (gfc_notify_std (GFC_STD_F2003, "Array constructor "
 			      "including type specification at %C") == FAILURE)
-	    goto cleanup;
+	    {
+	      gfc_restore_last_checkpoint ();
+	      goto cleanup;
+	    }
 
 	  if (ts.deferred)
 	    {
 	      gfc_error ("Type-spec at %L cannot contain a deferred "
 			 "type parameter", &where);
+	      gfc_restore_last_checkpoint ();
 	      goto cleanup;
 	    }
 	}
     }
 
-  if (! seen_ts)
-    gfc_current_locus = where;
+  if (seen_ts)
+    gfc_drop_last_checkpoint ();
+  else
+    {
+      gfc_restore_last_checkpoint ();
+      gfc_current_locus = where;
+    }
 
   if (gfc_match (end_delim) == MATCH_YES)
     {
diff --git a/gfortran.h b/gfortran.h
index 3b4b473..7a18c6c 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -39,6 +39,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "intl.h"
 #include "input.h"
 #include "splay-tree.h"
+#include "vec.h"
 
 /* Major control parameters.  */
 
@@ -1275,6 +1276,15 @@ typedef struct gfc_symbol
 }
 gfc_symbol;
 
+
+struct gfc_change_set
+{
+  vec<gfc_symbol *> syms;
+  vec<gfc_typebound_proc *> tbps;
+  gfc_change_set *previous;
+};
+
+
 /* This structure is used to keep track of symbols in common blocks.  */
 typedef struct gfc_common_head
 {
@@ -2632,6 +2642,9 @@ int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
 int gfc_get_ha_symbol (const char *, gfc_symbol **);
 int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
 
+void gfc_new_checkpoint (gfc_change_set &);
+void gfc_drop_last_checkpoint (void);
+void gfc_restore_last_checkpoint (void);
 void gfc_undo_symbols (void);
 void gfc_commit_symbols (void);
 void gfc_commit_symbol (gfc_symbol *);
diff --git a/symbol.c b/symbol.c
index acfebc5..f040431 100644
--- a/symbol.c
+++ b/symbol.c
@@ -97,21 +97,10 @@ gfc_namespace *gfc_global_ns_list;
 
 gfc_gsymbol *gfc_gsym_root = NULL;
 
-static gfc_symbol *changed_syms = NULL;
-
 gfc_dt_list *gfc_derived_types;
 
-
-/* List of tentative typebound-procedures.  */
-
-typedef struct tentative_tbp
-{
-  gfc_typebound_proc *proc;
-  struct tentative_tbp *next;
-}
-tentative_tbp;
-
-static tentative_tbp *tentative_tbp_list = NULL;
+static gfc_change_set change_set_var = { vNULL, vNULL, NULL };
+static gfc_change_set *changes = &change_set_var;
 
 
 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
@@ -2708,20 +2697,51 @@ gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
 }
 
 
+/* Tells whether there is only one set of changes in the stack.  */
+
+static bool
+single_undo_checkpoint_p (void)
+{
+  if (changes == &change_set_var)
+    {
+      gcc_assert (changes->previous == NULL);
+      return true;
+    }
+  else
+    {
+      gcc_assert (changes->previous != NULL);
+      return false;
+    }
+}
+
 /* Save symbol with the information necessary to back it out.  */
 
 static void
 save_symbol_data (gfc_symbol *sym)
 {
+  gfc_symbol *s;
+  unsigned i;
 
-  if (sym->gfc_new || sym->old_symbol != NULL)
+  if (!single_undo_checkpoint_p ())
+    {
+      /* If there is more than one change set, look for the symbol in the
+         current one.  If it is found there, we can reuse it.  */
+      FOR_EACH_VEC_ELT (changes->syms, i, s)
+	if (s == sym)
+	  {
+	    gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
+	    return;
+	  }
+    }
+  else if (sym->gfc_new || sym->old_symbol != NULL)
     return;
 
-  sym->old_symbol = XCNEW (gfc_symbol);
-  *(sym->old_symbol) = *sym;
+  s = XCNEW (gfc_symbol);
+  *s = *sym;
+  sym->old_symbol = s;
+  sym->gfc_new = 0;
 
-  sym->tlink = changed_syms;
-  changed_syms = sym;
+  changes->syms.safe_push (sym);
 }
 
 
@@ -2757,10 +2777,9 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
 
       /* Add to the list of tentative symbols.  */
       p->old_symbol = NULL;
-      p->tlink = changed_syms;
       p->mark = 1;
       p->gfc_new = 1;
-      changed_syms = p;
+      changes->syms.safe_push (p);
 
       st = gfc_new_symtree (&ns->sym_root, name);
       st->n.sym = p;
@@ -2891,20 +2910,164 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 }
 
 
-/* Undoes all the changes made to symbols in the current statement.
+/* Clear the given storage, and make it the current change set for registering
+   changed symbols.  Its contents are freed after a call to
+   gfc_restore_last_checkpoint or gfc_drop_last_checkpoint, but it is up to the
+   caller to free the storage itself.  It is usually a local variable, so there
+   is nothing to do anyway.  */
+
+void
+gfc_new_checkpoint (gfc_change_set &chg_syms)
+{
+  chg_syms.syms = vNULL;
+  chg_syms.tbps = vNULL;
+  chg_syms.previous = changes;
+  changes = &chg_syms;
+}
+
+
+/* Restore previous state of symbol.  Just copy simple stuff.  */
+  
+static void
+restore_old_symbol (gfc_symbol *p)
+{
+  gfc_symbol *old;
+
+  p->mark = 0;
+  old = p->old_symbol;
+
+  p->ts.type = old->ts.type;
+  p->ts.kind = old->ts.kind;
+
+  p->attr = old->attr;
+
+  if (p->value != old->value)
+    {
+      gcc_checking_assert (old->value == NULL);
+      gfc_free_expr (p->value);
+      p->value = NULL;
+    }
+
+  if (p->as != old->as)
+    {
+      if (p->as)
+	gfc_free_array_spec (p->as);
+      p->as = old->as;
+    }
+
+  p->generic = old->generic;
+  p->component_access = old->component_access;
+
+  if (p->namelist != NULL && old->namelist == NULL)
+    {
+      gfc_free_namelist (p->namelist);
+      p->namelist = NULL;
+    }
+  else
+    {
+      if (p->namelist_tail != old->namelist_tail)
+	{
+	  gfc_free_namelist (old->namelist_tail->next);
+	  old->namelist_tail->next = NULL;
+	}
+    }
+
+  p->namelist_tail = old->namelist_tail;
+
+  if (p->formal != old->formal)
+    {
+      gfc_free_formal_arglist (p->formal);
+      p->formal = old->formal;
+    }
+
+  p->old_symbol = old->old_symbol;
+  free (old);
+}
+
+
+/* Frees the internal data of a gfc_change_set structure.  Doesn't free the
+   structure itself.  */
+
+static void
+free_change_set_data (gfc_change_set &cs)
+{
+  cs.syms.release ();
+  cs.tbps.release ();
+}
+
+
+/* Given a change set pointer, free its target's contents and update it with
+   the address of the previous change set.  Note that only the contents are
+   freed, not the target itself (the contents' container).  It is not a problem
+   as the latter will be a local variable usually.  */
+
+static void
+pop_change_set (gfc_change_set *&cs)
+{
+  free_change_set_data (*cs);
+  cs = cs->previous;
+}
+
+
+static void free_old_symbol (gfc_symbol *sym);
+
+
+/* Merges the current change set into the previous one.  The changes themselves
+   are left untouched; only one checkpoint is forgotten.  */
+
+void
+gfc_drop_last_checkpoint (void)
+{
+  gfc_symbol *s, *t;
+  unsigned i, j;
+
+  FOR_EACH_VEC_ELT (changes->syms, i, s)
+    {
+      /* No need to loop in this case.  */
+      if (s->old_symbol == NULL)
+        continue;
+
+      /* Remove the duplicate symbols.  */
+      FOR_EACH_VEC_ELT (changes->previous->syms, j, t)
+	if (t == s)
+	  {
+	    changes->previous->syms.unordered_remove (j);
+
+	    /* S->OLD_SYMBOL is the backup symbol for S as it was at the
+	       last checkpoint.  We drop that checkpoint, so S->OLD_SYMBOL
+	       shall contain from now on the backup symbol for S as it was
+	       at the checkpoint before.  */
+	    if (s->old_symbol->gfc_new)
+	      {
+		gcc_assert (s->old_symbol->old_symbol == NULL);
+		s->gfc_new = s->old_symbol->gfc_new;
+		free_old_symbol (s);
+	      }
+	    else
+	      restore_old_symbol (s->old_symbol);
+	    break;
+	  }
+    }
+
+  changes->previous->syms.safe_splice (changes->syms);
+  changes->previous->tbps.safe_splice (changes->tbps);
+
+  pop_change_set (changes);
+}
+
+
+/* Undoes all the changes made to symbols since the previous checkpoint.
    This subroutine is made simpler due to the fact that attributes are
    never removed once added.  */
 
 void
-gfc_undo_symbols (void)
+gfc_restore_last_checkpoint (void)
 {
-  gfc_symbol *p, *q, *old;
-  tentative_tbp *tbp, *tbq;
+  gfc_symbol *p;
+  unsigned i;
 
-  for (p = changed_syms; p; p = q)
+  FOR_EACH_VEC_ELT (changes->syms, i, p)
     {
-      q = p->tlink;
-
       if (p->gfc_new)
 	{
 	  /* Symbol was new.  */
@@ -2959,70 +3122,37 @@ gfc_undo_symbols (void)
 	    gfc_delete_symtree (&p->ns->sym_root, p->name);
 
 	  gfc_release_symbol (p);
-	  continue;
-	}
-
-      /* Restore previous state of symbol.  Just copy simple stuff.  */
-      p->mark = 0;
-      old = p->old_symbol;
-
-      p->ts.type = old->ts.type;
-      p->ts.kind = old->ts.kind;
-
-      p->attr = old->attr;
-
-      if (p->value != old->value)
-	{
-	  gfc_free_expr (old->value);
-	  p->value = NULL;
 	}
+      else
+	restore_old_symbol (p);
+    }
 
-      if (p->as != old->as)
-	{
-	  if (p->as)
-	    gfc_free_array_spec (p->as);
-	  p->as = old->as;
-	}
+  changes->syms.truncate (0);
+  changes->tbps.truncate (0);
 
-      p->generic = old->generic;
-      p->component_access = old->component_access;
+  if (!single_undo_checkpoint_p ())
+    pop_change_set (changes);
+}
 
-      if (p->namelist != NULL && old->namelist == NULL)
-	{
-	  gfc_free_namelist (p->namelist);
-	  p->namelist = NULL;
-	}
-      else
-	{
-	  if (p->namelist_tail != old->namelist_tail)
-	    {
-	      gfc_free_namelist (old->namelist_tail->next);
-	      old->namelist_tail->next = NULL;
-	    }
-	}
 
-      p->namelist_tail = old->namelist_tail;
+/* Makes sure that there is only one set of changes; in other words we haven't
+   forgotten to pair a call to gfc_new_checkpoint with a call to either
+   gfc_drop_last_checkpoint or gfc_restore_last_checkpoint.  */
 
-      if (p->formal != old->formal)
-	{
-	  gfc_free_formal_arglist (p->formal);
-	  p->formal = old->formal;
-	}
+static void
+enforce_single_undo_checkpoint (void)
+{
+  gcc_checking_assert (single_undo_checkpoint_p ());
+}
 
-      free (p->old_symbol);
-      p->old_symbol = NULL;
-      p->tlink = NULL;
-    }
 
-  changed_syms = NULL;
+/* Undoes all the changes made to symbols in the current statement.  */
 
-  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
-    {
-      tbq = tbp->next;
-      /* Procedure is already marked `error' by default.  */
-      free (tbp);
-    }
-  tentative_tbp_list = NULL;
+void
+gfc_undo_symbols (void)
+{
+  enforce_single_undo_checkpoint ();
+  gfc_restore_last_checkpoint ();
 }
 
 
@@ -3059,26 +3189,23 @@ free_old_symbol (gfc_symbol *sym)
 void
 gfc_commit_symbols (void)
 {
-  gfc_symbol *p, *q;
-  tentative_tbp *tbp, *tbq;
+  gfc_symbol *p;
+  gfc_typebound_proc *tbp;
+  unsigned i;
 
-  for (p = changed_syms; p; p = q)
+  enforce_single_undo_checkpoint ();
+
+  FOR_EACH_VEC_ELT (changes->syms, i, p)
     {
-      q = p->tlink;
-      p->tlink = NULL;
       p->mark = 0;
       p->gfc_new = 0;
       free_old_symbol (p);
     }
-  changed_syms = NULL;
+  changes->syms.truncate (0);
 
-  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
-    {
-      tbq = tbp->next;
-      tbp->proc->error = 0;
-      free (tbp);
-    }
-  tentative_tbp_list = NULL;
+  FOR_EACH_VEC_ELT (changes->tbps, i, tbp)
+    tbp->error = 0;
+  changes->tbps.truncate (0);
 }
 
 
@@ -3089,20 +3216,17 @@ void
 gfc_commit_symbol (gfc_symbol *sym)
 {
   gfc_symbol *p;
+  unsigned i;
 
-  if (changed_syms == sym)
-    changed_syms = sym->tlink;
-  else
-    {
-      for (p = changed_syms; p; p = p->tlink)
-        if (p->tlink == sym)
-          {
-            p->tlink = sym->tlink;
-            break;
-          }
-    }
+  enforce_single_undo_checkpoint ();
+
+  FOR_EACH_VEC_ELT (changes->syms, i, p)
+    if (p == sym)
+      {
+	changes->syms.unordered_remove (i);
+	break;
+      }
 
-  sym->tlink = NULL;
   sym->mark = 0;
   sym->gfc_new = 0;
 
@@ -3379,10 +3503,12 @@ gfc_symbol_init_2 (void)
 void
 gfc_symbol_done_2 (void)
 {
-
   gfc_free_namespace (gfc_current_ns);
   gfc_current_ns = NULL;
   gfc_free_dt_list ();
+
+  enforce_single_undo_checkpoint ();
+  free_change_set_data (*changes);
 }
 
 
@@ -3547,7 +3673,8 @@ gfc_save_all (gfc_namespace *ns)
 void
 gfc_enforce_clean_symbol_state(void)
 {
-  gcc_assert (changed_syms == NULL);
+  enforce_single_undo_checkpoint ();
+  gcc_assert (changes->syms.is_empty ());
 }
 
 
@@ -4708,17 +4835,13 @@ gfc_typebound_proc*
 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
 {
   gfc_typebound_proc *result;
-  tentative_tbp *list_node;
 
   result = XCNEW (gfc_typebound_proc);
   if (tb0)
     *result = *tb0;
   result->error = 1;
 
-  list_node = XCNEW (tentative_tbp);
-  list_node->next = tentative_tbp_list;
-  list_node->proc = result;
-  tentative_tbp_list = list_node;
+  changes->tbps.safe_push (result);
 
   return result;
 }