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

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;
 }