[Patch, fortran] [1/5] PR54730 ICE: confused by type-like fonctions: Move to the vec API.

[Patch, fortran] [1/5] PR54730 ICE: confused by type-like fonctions: Move to the vec API.

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 125 bytes --]

This packs symbol.c's 'changed_syms' and 'tentative_tbp' variables into a new
'gfc_change_set' structure using the vec API.


[-- Attachment #2: pr54730_v23-1.CL --]
[-- Type: text/plain, Size: 544 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* Make-lang.in (F95_PARSER_OBJS): Add dependency to vec.h
	* gfortran.h: Include vec.h
	(gfc_change_set): New struct.
	* symbol.c (tentative_tbp): Remove struct.
	(changed_syms, tentative_tbp_list): Remove variables.
	(change_set_var, changes): New variables.
	(save_symbol_data, gfc_get_sym_tree, gfc_undo_symbols,
	gfc_commit_symbols, gfc_commit_symbol,
	gfc_enforce_clean_symbol_state, gfc_get_typebound_proc):
	Use changes instead of changed_syms and tentative_tbp_list.



[-- Attachment #3: pr54730_v23-1.patch --]
[-- Type: text/x-diff, Size: 5233 bytes --]

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/gfortran.h b/gfortran.h
index 3b4b473..31b0d42 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,14 @@ typedef struct gfc_symbol
 }
 gfc_symbol;
 
+
+struct gfc_change_set
+{
+  vec<gfc_symbol *> syms;
+  vec<gfc_typebound_proc *> tbps;
+};
+
+
 /* This structure is used to keep track of symbols in common blocks.  */
 typedef struct gfc_common_head
 {
diff --git a/symbol.c b/symbol.c
index acfebc5..2c122d0 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 };
+static gfc_change_set *changes = &change_set_var;
 
 
 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
@@ -2720,8 +2709,7 @@ save_symbol_data (gfc_symbol *sym)
   sym->old_symbol = XCNEW (gfc_symbol);
   *(sym->old_symbol) = *sym;
 
-  sym->tlink = changed_syms;
-  changed_syms = sym;
+  changes->syms.safe_push (sym);
 }
 
 
@@ -2757,10 +2745,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;
@@ -2898,13 +2885,11 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 void
 gfc_undo_symbols (void)
 {
-  gfc_symbol *p, *q, *old;
-  tentative_tbp *tbp, *tbq;
+  gfc_symbol *p, *old;
+  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.  */
@@ -3011,18 +2996,10 @@ gfc_undo_symbols (void)
 
       free (p->old_symbol);
       p->old_symbol = NULL;
-      p->tlink = NULL;
     }
 
-  changed_syms = NULL;
-
-  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
-    {
-      tbq = tbp->next;
-      /* Procedure is already marked `error' by default.  */
-      free (tbp);
-    }
-  tentative_tbp_list = NULL;
+  changes->syms.truncate (0);
+  changes->tbps.truncate (0);
 }
 
 
@@ -3059,26 +3036,21 @@ 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)
+  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 +3061,15 @@ 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;
-          }
-    }
+  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;
 
@@ -3547,7 +3514,7 @@ gfc_save_all (gfc_namespace *ns)
 void
 gfc_enforce_clean_symbol_state(void)
 {
-  gcc_assert (changed_syms == NULL);
+  gcc_assert (changes->syms.is_empty ());
 }
 
 
@@ -4708,17 +4675,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;
 }

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

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 1881 bytes --]

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?


[-- Attachment #2: pr54730_v23.diff --]
[-- Type: text/x-diff, Size: 14048 bytes --]

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

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

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 133 bytes --]

This is a fix for what looks like a thinko.
The other patches don't depend on it, so it can well wait for 4.9 if
that is preferred.


[-- Attachment #2: pr54730_v23-3.CL --]
[-- Type: text/plain, Size: 113 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* symbol.c (restore_old_symbol): Fix thinko.


[-- Attachment #3: pr54730_v23-3.patch --]
[-- Type: text/x-diff, Size: 340 bytes --]

diff --git a/symbol.c b/symbol.c
index 4f1752d..e4dbb41 100644
--- a/symbol.c
+++ b/symbol.c
@@ -2895,7 +2895,8 @@ restore_old_symbol (gfc_symbol *p)
 
   if (p->value != old->value)
     {
-      gfc_free_expr (old->value);
+      gcc_checking_assert (old->value == NULL);
+      gfc_free_expr (p->value);
       p->value = NULL;
     }
 

[Patch, fortran] [4/5] PR54730 ICE: confused by type-like fonctions: Support multiple change sets.

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 290 bytes --]

A new field 'previous' is added to the 'gfc_change_set' structure so that it can
be used as a stack.
New procedures are added to use the new partial undoing feature, namely:
gfc_new_checkpoint, gfc_drop_last_checkpoint and gfc_restore_last_checkpoint.
They will be used in the next patch.


[-- Attachment #2: pr54730_v23-4.CL --]
[-- Type: text/plain, Size: 959 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* gfortran.h (struct gfc_change_set): New field 'previous'.
	(gfc_new_checkpoint, gfc_drop_last_checkpoint, gfc_restore_last_checkpoint):
	New prototypes.
	* symbol.c (change_set_var): Update initialization.
	(single_undo_checkpoint_p, gfc_new_checkpoint, free_change_set_data,
	pop_change_set, gfc_drop_last_checkpiont, enforce_single_undo_checkpoint):
	New functions.
	(save_symbol_data): Handle multiple change sets.  Make sure old_symbol field's
	previous value is not overwritten.  Clear gfc_new field.
	(restore_old_symbol): Restore previous old_symbol field.
	(gfc_restore_last_checkpoint): New function, using body renamed from
	gfc_undo_symbols.  Restore the previous change set as current one.
	(gfc_undo_symbols): New body.
	(gfc_commit_symbols, gfc_commit_symbol, gfc_enforce_clean_symbol_state):
	Call enforce_single_undo_checkpoint.
	(gfc_symbol_done_2): Free change set data.


[-- Attachment #3: pr54730_v23-4.patch --]
[-- Type: text/x-diff, Size: 6975 bytes --]

diff --git a/gfortran.h b/gfortran.h
index 31b0d42..7a18c6c 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -1281,6 +1281,7 @@ struct gfc_change_set
 {
   vec<gfc_symbol *> syms;
   vec<gfc_typebound_proc *> tbps;
+  gfc_change_set *previous;
 };
 
 
@@ -2641,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 e4dbb41..f040431 100644
--- a/symbol.c
+++ b/symbol.c
@@ -99,7 +99,7 @@ gfc_gsymbol *gfc_gsym_root = NULL;
 
 gfc_dt_list *gfc_derived_types;
 
-static gfc_change_set change_set_var = { vNULL, vNULL };
+static gfc_change_set change_set_var = { vNULL, vNULL, NULL };
 static gfc_change_set *changes = &change_set_var;
 
 
@@ -2697,17 +2697,49 @@ 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;
 
   changes->syms.safe_push (sym);
 }
@@ -2878,6 +2910,22 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 }
 
 
+/* 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
@@ -2932,17 +2980,88 @@ restore_old_symbol (gfc_symbol *p)
       p->formal = old->formal;
     }
 
-  free (p->old_symbol);
-  p->old_symbol = NULL;
+  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 in the current statement.
+/* 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;
   unsigned i;
@@ -3010,6 +3129,30 @@ gfc_undo_symbols (void)
 
   changes->syms.truncate (0);
   changes->tbps.truncate (0);
+
+  if (!single_undo_checkpoint_p ())
+    pop_change_set (changes);
+}
+
+
+/* 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.  */
+
+static void
+enforce_single_undo_checkpoint (void)
+{
+  gcc_checking_assert (single_undo_checkpoint_p ());
+}
+
+
+/* Undoes all the changes made to symbols in the current statement.  */
+
+void
+gfc_undo_symbols (void)
+{
+  enforce_single_undo_checkpoint ();
+  gfc_restore_last_checkpoint ();
 }
 
 
@@ -3050,6 +3193,8 @@ gfc_commit_symbols (void)
   gfc_typebound_proc *tbp;
   unsigned i;
 
+  enforce_single_undo_checkpoint ();
+
   FOR_EACH_VEC_ELT (changes->syms, i, p)
     {
       p->mark = 0;
@@ -3073,6 +3218,8 @@ gfc_commit_symbol (gfc_symbol *sym)
   gfc_symbol *p;
   unsigned i;
 
+  enforce_single_undo_checkpoint ();
+
   FOR_EACH_VEC_ELT (changes->syms, i, p)
     if (p == sym)
       {
@@ -3356,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);
 }
 
 
@@ -3524,6 +3673,7 @@ gfc_save_all (gfc_namespace *ns)
 void
 gfc_enforce_clean_symbol_state(void)
 {
+  enforce_single_undo_checkpoint ();
   gcc_assert (changes->syms.is_empty ());
 }
 

[Patch, fortran] [2/5] PR54730 ICE: confused by type-like fonctions: Extract restore_old_symbol.

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 28 bytes --]

The ChangeLog says it all.


[-- Attachment #2: pr54730_v23-2.CL --]
[-- Type: text/plain, Size: 163 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* symbol.c (gfc_undo_symbols): Move code...
	(restore_old_symbol): ... here as a new function.


[-- Attachment #3: pr54730_v23-2.patch --]
[-- Type: text/x-diff, Size: 2948 bytes --]

diff --git a/symbol.c b/symbol.c
index 2c122d0..4f1752d 100644
--- a/symbol.c
+++ b/symbol.c
@@ -2878,6 +2878,64 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 }
 
 
+/* 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)
+    {
+      gfc_free_expr (old->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;
+    }
+
+  free (p->old_symbol);
+  p->old_symbol = NULL;
+}
+
+
 /* Undoes all the changes made to symbols in the current statement.
    This subroutine is made simpler due to the fact that attributes are
    never removed once added.  */
@@ -2885,7 +2943,7 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 void
 gfc_undo_symbols (void)
 {
-  gfc_symbol *p, *old;
+  gfc_symbol *p;
   unsigned i;
 
   FOR_EACH_VEC_ELT (changes->syms, i, p)
@@ -2944,58 +3002,9 @@ 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;
-	}
-
-      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;
-	}
-
-      free (p->old_symbol);
-      p->old_symbol = NULL;
+	restore_old_symbol (p);
     }
 
   changes->syms.truncate (0);

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

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 29 bytes --]

This is the fix for the PR.


[-- Attachment #2: pr54730_v23-5.CL --]
[-- Type: text/plain, Size: 198 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* array.c (gfc_match_array_constructor): Set a checkpoint before matching 
	a typespec.  Drop it on success, restore it otherwise.

[-- Attachment #3: pr54730_v23-5.patch --]
[-- Type: text/x-diff, Size: 1343 bytes --]

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)
     {

[-- Attachment #4: pr54730-test.CL --]
[-- Type: text/plain, Size: 117 bytes --]

2013-02-15  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/54730
	* gfortran.dg/array_constructor_42.f90: New test.

[-- Attachment #5: array_constructor_42.f90 --]
[-- Type: text/x-fortran, Size: 513 bytes --]

! { dg-do compile }
!
! PR fortran/54730
! A symbol 'a' was created while attempting to parse a typespec in the array
! constructor.  That (invalid) symbol was kept until translation stage
! where it was leading to an ICE.
!
! Original testcase from Paul Kapinos <kapinos@rz.rwth-aachen.de>
!

  subroutine s
    implicit none
    intrinsic :: real
    real :: vec(1:2)
    vec = (/ real(a = 1), 1. /)
  end subroutine s

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

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

[Tobias Burnus]

Mikael Morin wrote:
> 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.
> [...]
> This makes backporting a bit more difficult unfortunately; I will submit the (yet nonexisting) backport
> patches separately.

I know that this PR is a 4.6/4.7/4.8 regression and that it presumably 
comes from a real-world code; still, given that one can relatively 
simple work around the issue and that the patch is not tiny (though not 
very complicated either), I wonder whether one should only fix it on the 
4.8 trunk.

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

It looks mostly okay.

However, I somehow do not like some of names of the new 
procedures/global vars. I find the new "single_undo_checkpoint_p" clear, 
but, without the context of this patch, I presumably had no idea what a 
"checkpoint" means when reading gfortran.h:

+void gfc_new_checkpoint (gfc_change_set &);
+void gfc_drop_last_checkpoint (void);
+void gfc_restore_last_checkpoint (void);

Similarly:

+static gfc_change_set change_set_var = { vNULL, vNULL, NULL };
+static gfc_change_set *changes = &change_set_var;

"changes" is a bit too vague for me (though it is not bad) – and 
"change_set_var" doesn't make it clear enough that it is simply a 
variable, which matches the empty default status.

BTW: Can you also change "static .... = {vNULL ...};" into "static const 
.... = {vNULL ...};" to make sure the value is not accidentally changed?


Regarding the naming, can you use a bit more speaking names? For 
instance – without claiming that the naming choice is best: 
"undo_changes" instead of "changes", "emtpy_undo_change_set_var" instead 
of "change_set_var", "gfc_new_undo_checkpoint" instead of 
"gfc_new_checkpoint". It can be also something different, but it should 
imply what they a good for.


To sum up: The patch is okay with the "const" added. I'd prefer some 
"speaking names", but if you cannot come up with one, the patch is also 
acceptable as is.

Tobias

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

[Mikael Morin]

Le 22/02/2013 16:23, Tobias Burnus a écrit :
> Mikael Morin wrote:
>> 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.
>> [...]
>> This makes backporting a bit more difficult unfortunately; I will
>> submit the (yet nonexisting) backport
>> patches separately.
>
> I know that this PR is a 4.6/4.7/4.8 regression and that it presumably
> comes from a real-world code; still, given that one can relatively
> simple work around the issue and that the patch is not tiny (though not
> very complicated either), I wonder whether one should only fix it on the
> 4.8 trunk.
>
Yes we have had two major versions with the bug after all.
Let's go for 4.8 only, that's less work for me. :-)

>> Bootstrap-asan'ed and regression tested on x86_64-unknown-linux-gnu.
>> OK for trunk?
>
> It looks mostly okay.
>
> However, I somehow do not like some of names of the new
> procedures/global vars. I find the new "single_undo_checkpoint_p" clear,
> but, without the context of this patch, I presumably had no idea what a
> "checkpoint" means when reading gfortran.h:
>
> +void gfc_new_checkpoint (gfc_change_set &);
> +void gfc_drop_last_checkpoint (void);
> +void gfc_restore_last_checkpoint (void);
>
I have tried to find a good balance between descriptiveness and 
verboseness.  Before settling on those names, I tried (reading my local 
dead branches):

gfc_register_undo_level/gfc_unregister_undo_level/?
gfc_push_undo_level/gfc_pop_undo_level/gfc_undo_one_level

Do you prefer any of them?  Otherwise I will just replace "checkpoint" 
by "undo_checkpoint" as you suggested.


> Similarly:
>
> +static gfc_change_set change_set_var = { vNULL, vNULL, NULL };
> +static gfc_change_set *changes = &change_set_var;
>
> "changes" is a bit too vague for me (though it is not bad) – and
> "change_set_var" doesn't make it clear enough that it is simply a
> variable, which matches the empty default status.
>
It's the default status, and it is empty at the beginning.  But it's not 
constant; changed symbols are added to it by default.

Regarding the name "changes", it is made necessary because the symbol 
changes and the tentative_tbp_list are packed together, thus the 
variable can't be called "changed_syms" any more.  If you don't mind 
seeing "changed_syms->syms" in the code we can keep the original name.
Otherwise I'm not very inspired.  Would you feel more comfortable with 
"latest_undo_changes"?

> Regarding the naming, can you use a bit more speaking names? For
> instance – without claiming that the naming choice is best:
> "undo_changes" instead of "changes", "emtpy_undo_change_set_var" instead
> of "change_set_var",
>
As said above, it's not always empty, so I will make it 
"default_undo_change_set_var" (and keep it non-const).  For the rest, I 
will add "undo_" before "change_set" and before "checkpoint".  Sounds good?

Mikael

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

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 886 bytes --]

Le 22/02/2013 16:23, Tobias Burnus a écrit :
> Regarding the naming, can you use a bit more speaking names? For
> instance – without claiming that the naming choice is best:
> "undo_changes" instead of "changes", "emtpy_undo_change_set_var" instead
> of "change_set_var", "gfc_new_undo_checkpoint" instead of
> "gfc_new_checkpoint". It can be also something different, but it should
> imply what they a good for.
>
I'll change:

gfc_change_set			-> gfc_undo_change_set
change_set_var			-> default_undo_chgset_var
changes				-> latest_undo_chgset
gfc_new_checkpoint		-> gfc_new_undo_checkpoint
gfc_drop_last_checkpoint	-> gfc_drop_last_undo_checkpoint
gfc_restore_last_checkpoint	-> gfc_restore_last_undo_checkpoint
free_change_set_data		-> free_undo_change_set_data
pop_change_set			-> pop_undo_change_set


I attach the corresponding patches.
Will test and commit tomorrow.

Mikael


[-- Attachment #2: pr54730_v29-1.patch --]
[-- Type: text/x-patch, Size: 6138 bytes --]

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/gfortran.h b/gfortran.h
index 44d5c91..d6176db 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,14 @@ typedef struct gfc_symbol
 }
 gfc_symbol;
 
+
+struct gfc_undo_change_set
+{
+  vec<gfc_symbol *> syms;
+  vec<gfc_typebound_proc *> tbps;
+};
+
+
 /* This structure is used to keep track of symbols in common blocks.  */
 typedef struct gfc_common_head
 {
diff --git a/symbol.c b/symbol.c
index acfebc5..ec721bf 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_undo_change_set default_undo_chgset_var = { vNULL, vNULL };
+static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
 
 
 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
@@ -2301,9 +2290,9 @@ done:
    Given the tricky nature of the Fortran grammar, we must be able to
    undo changes made to a symbol table if the current interpretation
    of a statement is found to be incorrect.  Whenever a symbol is
-   looked up, we make a copy of it and link to it.  All of these
-   symbols are kept in a singly linked list so that we can commit or
-   undo the changes at a later time.
+   looked up, we make a copy of it and link to it.  All of these symbols
+   are kept in a vector so that we can commit or undo the changes
+   at a later time.
 
    A symtree may point to a symbol node outside of its namespace.  In
    this case, that symbol has been used as a host associated variable
@@ -2720,8 +2709,7 @@ save_symbol_data (gfc_symbol *sym)
   sym->old_symbol = XCNEW (gfc_symbol);
   *(sym->old_symbol) = *sym;
 
-  sym->tlink = changed_syms;
-  changed_syms = sym;
+  latest_undo_chgset->syms.safe_push (sym);
 }
 
 
@@ -2757,10 +2745,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;
+      latest_undo_chgset->syms.safe_push (p);
 
       st = gfc_new_symtree (&ns->sym_root, name);
       st->n.sym = p;
@@ -2898,13 +2885,11 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 void
 gfc_undo_symbols (void)
 {
-  gfc_symbol *p, *q, *old;
-  tentative_tbp *tbp, *tbq;
+  gfc_symbol *p, *old;
+  unsigned i;
 
-  for (p = changed_syms; p; p = q)
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
     {
-      q = p->tlink;
-
       if (p->gfc_new)
 	{
 	  /* Symbol was new.  */
@@ -3011,18 +2996,10 @@ gfc_undo_symbols (void)
 
       free (p->old_symbol);
       p->old_symbol = NULL;
-      p->tlink = NULL;
     }
 
-  changed_syms = NULL;
-
-  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
-    {
-      tbq = tbp->next;
-      /* Procedure is already marked `error' by default.  */
-      free (tbp);
-    }
-  tentative_tbp_list = NULL;
+  latest_undo_chgset->syms.truncate (0);
+  latest_undo_chgset->tbps.truncate (0);
 }
 
 
@@ -3059,26 +3036,21 @@ 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)
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
     {
-      q = p->tlink;
-      p->tlink = NULL;
       p->mark = 0;
       p->gfc_new = 0;
       free_old_symbol (p);
     }
-  changed_syms = NULL;
+  latest_undo_chgset->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 (latest_undo_chgset->tbps, i, tbp)
+    tbp->error = 0;
+  latest_undo_chgset->tbps.truncate (0);
 }
 
 
@@ -3089,20 +3061,15 @@ 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;
-          }
-    }
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
+    if (p == sym)
+      {
+	latest_undo_chgset->syms.unordered_remove (i);
+	break;
+      }
 
-  sym->tlink = NULL;
   sym->mark = 0;
   sym->gfc_new = 0;
 
@@ -3547,7 +3514,7 @@ gfc_save_all (gfc_namespace *ns)
 void
 gfc_enforce_clean_symbol_state(void)
 {
-  gcc_assert (changed_syms == NULL);
+  gcc_assert (latest_undo_chgset->syms.is_empty ());
 }
 
 
@@ -4708,17 +4675,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;
+  latest_undo_chgset->tbps.safe_push (result);
 
   return result;
 }



[-- Attachment #3: pr54730_v29-2.patch --]
[-- Type: text/x-patch, Size: 2972 bytes --]

diff --git a/symbol.c b/symbol.c
index ec721bf..301e6e4 100644
--- a/symbol.c
+++ b/symbol.c
@@ -2878,6 +2878,64 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 }
 
 
+/* 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)
+    {
+      gfc_free_expr (old->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;
+    }
+
+  free (p->old_symbol);
+  p->old_symbol = NULL;
+}
+
+
 /* Undoes all the changes made to symbols in the current statement.
    This subroutine is made simpler due to the fact that attributes are
    never removed once added.  */
@@ -2885,7 +2943,7 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 void
 gfc_undo_symbols (void)
 {
-  gfc_symbol *p, *old;
+  gfc_symbol *p;
   unsigned i;
 
   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
@@ -2944,58 +3002,9 @@ 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;
-	}
-
-      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;
-	}
-
-      free (p->old_symbol);
-      p->old_symbol = NULL;
+	restore_old_symbol (p);
     }
 
   latest_undo_chgset->syms.truncate (0);



[-- Attachment #4: pr54730_v29-3.patch --]
[-- Type: text/x-patch, Size: 342 bytes --]

diff --git a/symbol.c b/symbol.c
index 301e6e4..b94a44a 100644
--- a/symbol.c
+++ b/symbol.c
@@ -2895,7 +2895,8 @@ restore_old_symbol (gfc_symbol *p)
 
   if (p->value != old->value)
     {
-      gfc_free_expr (old->value);
+      gcc_checking_assert (old->value == NULL);
+      gfc_free_expr (p->value);
       p->value = NULL;
     }
 



[-- Attachment #5: pr54730_v29-4.patch --]
[-- Type: text/x-patch, Size: 7401 bytes --]

diff --git a/gfortran.h b/gfortran.h
index d6176db..18bbf79 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -1281,6 +1281,7 @@ struct gfc_undo_change_set
 {
   vec<gfc_symbol *> syms;
   vec<gfc_typebound_proc *> tbps;
+  gfc_undo_change_set *previous;
 };
 
 
@@ -2641,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_undo_checkpoint (gfc_undo_change_set &);
+void gfc_drop_last_undo_checkpoint (void);
+void gfc_restore_last_undo_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 b94a44a..fea24a8 100644
--- a/symbol.c
+++ b/symbol.c
@@ -99,7 +99,7 @@ gfc_gsymbol *gfc_gsym_root = NULL;
 
 gfc_dt_list *gfc_derived_types;
 
-static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL };
+static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
 static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
 
 
@@ -2697,17 +2697,49 @@ 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 (latest_undo_chgset == &default_undo_chgset_var)
+    {
+      gcc_assert (latest_undo_chgset->previous == NULL);
+      return true;
+    }
+  else
+    {
+      gcc_assert (latest_undo_chgset->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 (latest_undo_chgset->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;
 
   latest_undo_chgset->syms.safe_push (sym);
 }
@@ -2878,6 +2910,22 @@ find_common_symtree (gfc_symtree *st, gfc_common_head *head)
 }
 
 
+/* 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_undo_checkpoint or gfc_drop_last_undo_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_undo_checkpoint (gfc_undo_change_set &chg_syms)
+{
+  chg_syms.syms = vNULL;
+  chg_syms.tbps = vNULL;
+  chg_syms.previous = latest_undo_chgset;
+  latest_undo_chgset = &chg_syms;
+}
+
+
 /* Restore previous state of symbol.  Just copy simple stuff.  */
   
 static void
@@ -2932,17 +2980,88 @@ restore_old_symbol (gfc_symbol *p)
       p->formal = old->formal;
     }
 
-  free (p->old_symbol);
-  p->old_symbol = NULL;
+  p->old_symbol = old->old_symbol;
+  free (old);
+}
+
+
+/* Frees the internal data of a gfc_undo_change_set structure.  Doesn't free the
+   structure itself.  */
+
+static void
+free_undo_change_set_data (gfc_undo_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_undo_change_set (gfc_undo_change_set *&cs)
+{
+  free_undo_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_undo_checkpoint (void)
+{
+  gfc_symbol *s, *t;
+  unsigned i, j;
+
+  FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
+    {
+      /* No need to loop in this case.  */
+      if (s->old_symbol == NULL)
+        continue;
+
+      /* Remove the duplicate symbols.  */
+      FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
+	if (t == s)
+	  {
+	    latest_undo_chgset->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;
+	  }
+    }
+
+  latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
+  latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
+
+  pop_undo_change_set (latest_undo_chgset);
 }
 
 
-/* Undoes all the changes made to symbols in the current statement.
+/* 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_undo_checkpoint (void)
 {
   gfc_symbol *p;
   unsigned i;
@@ -3010,6 +3129,30 @@ gfc_undo_symbols (void)
 
   latest_undo_chgset->syms.truncate (0);
   latest_undo_chgset->tbps.truncate (0);
+
+  if (!single_undo_checkpoint_p ())
+    pop_undo_change_set (latest_undo_chgset);
+}
+
+
+/* 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_undo_checkpoint or gfc_restore_last_undo_checkpoint.  */
+
+static void
+enforce_single_undo_checkpoint (void)
+{
+  gcc_checking_assert (single_undo_checkpoint_p ());
+}
+
+
+/* Undoes all the changes made to symbols in the current statement.  */
+
+void
+gfc_undo_symbols (void)
+{
+  enforce_single_undo_checkpoint ();
+  gfc_restore_last_undo_checkpoint ();
 }
 
 
@@ -3050,6 +3193,8 @@ gfc_commit_symbols (void)
   gfc_typebound_proc *tbp;
   unsigned i;
 
+  enforce_single_undo_checkpoint ();
+
   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
     {
       p->mark = 0;
@@ -3073,6 +3218,8 @@ gfc_commit_symbol (gfc_symbol *sym)
   gfc_symbol *p;
   unsigned i;
 
+  enforce_single_undo_checkpoint ();
+
   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
     if (p == sym)
       {
@@ -3356,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_undo_change_set_data (*latest_undo_chgset);
 }
 
 
@@ -3524,6 +3673,7 @@ gfc_save_all (gfc_namespace *ns)
 void
 gfc_enforce_clean_symbol_state(void)
 {
+  enforce_single_undo_checkpoint ();
   gcc_assert (latest_undo_chgset->syms.is_empty ());
 }
 



[-- Attachment #6: pr54730_v29-5.patch --]
[-- Type: text/x-patch, Size: 1375 bytes --]

diff --git a/array.c b/array.c
index 6787c05..6ee292c 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_undo_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_undo_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_undo_checkpoint ();
+	      goto cleanup;
+	    }
 
 	  if (ts.deferred)
 	    {
 	      gfc_error ("Type-spec at %L cannot contain a deferred "
 			 "type parameter", &where);
+	      gfc_restore_last_undo_checkpoint ();
 	      goto cleanup;
 	    }
 	}
     }
 
-  if (! seen_ts)
-    gfc_current_locus = where;
+  if (seen_ts)
+    gfc_drop_last_undo_checkpoint ();
+  else
+    {
+      gfc_restore_last_undo_checkpoint ();
+      gfc_current_locus = where;
+    }
 
   if (gfc_match (end_delim) == MATCH_YES)
     {