[Patch, fortran] COMMON block error recovery: PR 67758 (second pass)

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

Hello,

Dominique noticed that the test coming with the preceding PR67758 patch 
[1] was failing if compiled as free form.
[1] https://gcc.gnu.org/ml/gcc-patches/2015-10/msg00301.html

The problem is again an inconsistent state, but this time between the 
in_common attribute and the common_block pointer.
So, here is another iteration, hopefully fixing the remaining problems.
The changes are:
   - adding a symbol to a common block list in gfc_match_common is 
delayed after the call to gfc_add_in_common.
   - gfc_restore_latest_undo_checkpoint is changed to check the 
common_block pointer directly instead of the in_common attribute.
Both of these changes fix the testcase independently, but with some 
regressions, so there is additionally:
   - gfc_restore_old_symbol is changed to also restore the 
common-related pointers.  This is done using a new function created to 
factor the related memory management.
   - In gfc_restore_last_undo_checkpoint, when a symbol has been 
removed from the common block linked list, its common_next pointer is 
cleared.

Regression tested on x86_64-linux.  OK for trunk?

Mikael


2015-10-06  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/67758
	* gfortran.h (gfc_symbol): Expand comment.
	* match.c (gfc_match_common): Delay adding the symbol to
	the common_block after the gfc_add_in_common call.
	* symbol.c (gfc_free_symbol): Move common block memory handling...
	(gfc_set_symbol_common_block): ... here as a new function.
	(restore_old_symbol): Restore common block fields.
	(gfc_restore_last_undo_checkpoint):
	Check the common_block pointer instead of the in_common attribute.
	When a symbol has been removed from the common block linked list,
	clear its common_next pointer.

2015-10-06  Mikael Morin  <mikael@gcc.gnu.org>

	PR fortran/67758
	* gfortran.dg/common_25.f90: New file.

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9c0084b..b2894cc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1411,8 +1411,12 @@ typedef struct gfc_symbol
 
   struct gfc_symbol *common_next;	/* Links for COMMON syms */
 
-  /* This is in fact a gfc_common_head but it is only used for pointer
-     comparisons to check if symbols are in the same common block.  */
+  /* This is only used for pointer comparisons to check if symbols
+     are in the same common block.
+     In opposition to common_block, the common_head pointer takes into account
+     equivalences: if A is in a common block C and A and B are in equivalence,
+     then both A and B have common_head pointing to C, while A's common_block
+     points to C and B's is NULL.  */
   struct gfc_common_head* common_head;
 
   /* Make sure setup code for dummy arguments is generated in the correct
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 29437c3..74f26b7 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4365,16 +4365,6 @@ gfc_match_common (void)
 		goto cleanup;
 	    }
 
-	  sym->common_block = t;
-	  sym->common_block->refs++;
-
-	  if (tail != NULL)
-	    tail->common_next = sym;
-	  else
-	    *head = sym;
-
-	  tail = sym;
-
 	  /* Deal with an optional array specification after the
 	     symbol name.  */
 	  m = gfc_match_array_spec (&as, true, true);
@@ -4409,6 +4399,16 @@ gfc_match_common (void)
 	     if any, and continue matching.  */
 	  gfc_add_in_common (&sym->attr, sym->name, NULL);
 
+	  sym->common_block = t;
+	  sym->common_block->refs++;
+
+	  if (tail != NULL)
+	    tail->common_next = sym;
+	  else
+	    *head = sym;
+
+	  tail = sym;
+
 	  sym->common_head = t;
 
 	  /* Check to see if the symbol is already in an equivalence group.
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 35a3496..a9a0dc0 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2585,6 +2585,25 @@ gfc_find_uop (const char *name, gfc_namespace *ns)
 }
 
 
+/* Update a symbol's common_block field, and take care of the associated
+   memory management.  */
+
+static void
+set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
+{
+  if (sym->common_block == common_block)
+    return;
+
+  if (sym->common_block && sym->common_block->name[0] != '\0')
+    {
+      sym->common_block->refs--;
+      if (sym->common_block->refs == 0)
+	free (sym->common_block);
+    }
+  sym->common_block = common_block;
+}
+
+
 /* Remove a gfc_symbol structure and everything it points to.  */
 
 void
@@ -2612,12 +2631,7 @@ gfc_free_symbol (gfc_symbol *sym)
 
   gfc_free_namespace (sym->f2k_derived);
 
-  if (sym->common_block && sym->common_block->name[0] != '\0')
-    { 
-      sym->common_block->refs--; 
-      if (sym->common_block->refs == 0)
-	free (sym->common_block);
-    }
+  set_symbol_common_block (sym, NULL);
 
   free (sym);
 }
@@ -3090,6 +3104,9 @@ restore_old_symbol (gfc_symbol *p)
       p->formal = old->formal;
     }
 
+  set_symbol_common_block (p, old->common_block);
+  p->common_head = old->common_head;
+
   p->old_symbol = old->old_symbol;
   free (old);
 }
@@ -3178,15 +3195,13 @@ gfc_restore_last_undo_checkpoint (void)
 
   FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
     {
-      /* Symbol was new. Or was old and just put in common */
-      if ((p->gfc_new
-	   || (p->attr.in_common && !p->old_symbol->attr.in_common ))
-	  && p->attr.in_common && p->common_block && p->common_block->head)
+      /* Symbol in a common block was new. Or was old and just put in common */
+      if (p->common_block
+	  && (p->gfc_new || !p->old_symbol->common_block))
 	{
 	  /* If the symbol was added to any common block, it
 	     needs to be removed to stop the resolver looking
 	     for a (possibly) dead symbol.  */
-
 	  if (p->common_block->head == p && !p->common_next)
 	    {
 	      gfc_symtree st, *st0;
@@ -3218,6 +3233,7 @@ gfc_restore_last_undo_checkpoint (void)
 	      gcc_assert(cparent->common_next == p);
 	      cparent->common_next = csym->common_next;
 	    }
+	  p->common_next = NULL;
 	}
       if (p->gfc_new)
 	{


! { dg-do compile }
! PR fortran/67758
!
! Check the absence of ICE after emitting the error message
!
! This test is  the free form variant of common_24.f.

      REAL :: X
      COMMON /FMCOM / X(80 000 000)  ! { dg-error "Expected another dimension" }
      CALL T(XX(A))
      COMMON /FMCOM / XX(80 000 000) ! { dg-error "Expected another dimension" }
      END