[PATCH] fortran: Restore interface to its previous state on error [PR48776]

[Mikael Morin <mikael@gcc.gnu.org>]

Hello,

this fixes an old error-recovery bug.
Tested on x86_64-pc-linux-gnu.

OK for master?

-- >8 --

Keep memory of the content of the current interface body being parsed
and restore it to its previous state if it has been modified at the time
a parse attempt fails.

This fixes memory errors and random segmentation faults caused by
dangling symbol pointers kept in interfaces' linked lists of symbols.
If a parsing attempt fails and symbols are freed, they should also be
removed from the current interface linked list.

As the list of symbol is a linked list, and parsing only adds new
symbols to the head of the list, all that is needed to track the
previous content of the list is a pointer to its previous head.
This adds such a pointer, and the restoration of the list of symbols
to that pointer on error.

	PR fortran/48776

gcc/fortran/ChangeLog:

	* gfortran.h (gfc_drop_interface_elements_before): New prototype.
	(gfc_current_interface_head): Return a reference to the pointer.
	* interface.cc (gfc_current_interface_head): Ditto.
	(free_interface_elements_until): New function, generalizing
	gfc_free_interface.
	(gfc_free_interface): Use free_interface_elements_until.
	(gfc_drop_interface_elements_before): New function.
	* parse.cc
	(current_interface_ptr, previous_interface_head): New static variables.
	(current_interface_valid_p, get_current_interface_ptr): New functions.
	(decode_statement): Initialize previous_interface_head.
	(reject_statement): Restore current interface pointer to point to
	previous_interface_head.

gcc/testsuite/ChangeLog:

	* gfortran.dg/interface_procedure_1.f90: New test.
---
 gcc/fortran/gfortran.h                        |  3 +-
 gcc/fortran/interface.cc                      | 43 ++++++++++++---
 gcc/fortran/parse.cc                          | 54 +++++++++++++++++++
 .../gfortran.dg/interface_procedure_1.f90     | 23 ++++++++
 4 files changed, 115 insertions(+), 8 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/interface_procedure_1.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fd47000a88e..0fabe7badde 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3824,6 +3824,7 @@ bool gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *, mpz_t *);
 
 /* interface.cc -- FIXME: some of these should be in symbol.cc */
 void gfc_free_interface (gfc_interface *);
+void gfc_drop_interface_elements_before (gfc_interface **, gfc_interface *);
 bool gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 bool gfc_compare_types (gfc_typespec *, gfc_typespec *);
 bool gfc_check_dummy_characteristics (gfc_symbol *, gfc_symbol *,
@@ -3843,7 +3844,7 @@ void gfc_free_formal_arglist (gfc_formal_arglist *);
 bool gfc_extend_assign (gfc_code *, gfc_namespace *);
 bool gfc_check_new_interface (gfc_interface *, gfc_symbol *, locus);
 bool gfc_add_interface (gfc_symbol *);
-gfc_interface *gfc_current_interface_head (void);
+gfc_interface *&gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
 bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index ea82056e9e3..c01df0460d7 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -78,18 +78,47 @@ along with GCC; see the file COPYING3.  If not see
 gfc_interface_info current_interface;
 
 
+/* Free the leading members of the gfc_interface linked list given in INTR
+   up to the END element (exclusive: the END element is not freed).
+   If END is not nullptr, it is assumed that END is in the linked list starting
+   with INTR.  */
+
+static void
+free_interface_elements_until (gfc_interface *intr, gfc_interface *end)
+{
+  gfc_interface *next;
+
+  for (; intr != end; intr = next)
+    {
+      next = intr->next;
+      free (intr);
+    }
+}
+
+
 /* Free a singly linked list of gfc_interface structures.  */
 
 void
 gfc_free_interface (gfc_interface *intr)
 {
-  gfc_interface *next;
+  free_interface_elements_until (intr, nullptr);
+}
 
-  for (; intr; intr = next)
-    {
-      next = intr->next;
-      free (intr);
-    }
+
+/* Update the interface pointer given by IFC_PTR to make it point to TAIL.
+   It is expected that TAIL (if non-null) is in the list pointed to by
+   IFC_PTR, hence the tail of it.  The members of the list before TAIL are
+   freed before the pointer reassignment.  */
+
+void
+gfc_drop_interface_elements_before (gfc_interface **ifc_ptr,
+				    gfc_interface *tail)
+{
+  if (ifc_ptr == nullptr)
+    return;
+
+  free_interface_elements_until (*ifc_ptr, tail);
+  *ifc_ptr = tail;
 }
 
 
@@ -4953,7 +4982,7 @@ gfc_add_interface (gfc_symbol *new_sym)
 }
 
 
-gfc_interface *
+gfc_interface *&
 gfc_current_interface_head (void)
 {
   switch (current_interface.type)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index e797402b59f..8f09ddf753c 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -37,6 +37,13 @@ gfc_st_label *gfc_statement_label;
 static locus label_locus;
 static jmp_buf eof_buf;
 
+/* Respectively pointer and content of the current interface body being parsed
+   as they were at the beginning of decode_statement.  Used to restore the
+   interface to its previous state in case a parsed statement is rejected after
+   some symbols have been added to the interface.  */
+static gfc_interface **current_interface_ptr = nullptr;
+static gfc_interface *previous_interface_head = nullptr;
+
 gfc_state_data *gfc_state_stack;
 static bool last_was_use_stmt = false;
 bool in_exec_part;
@@ -291,6 +298,46 @@ end_of_block:
   return ST_GET_FCN_CHARACTERISTICS;
 }
 
+
+/* Tells whether gfc_get_current_interface_head can be used safely.  */
+
+static bool
+current_interface_valid_p ()
+{
+  switch (current_interface.type)
+    {
+    case INTERFACE_INTRINSIC_OP:
+      return current_interface.ns != nullptr;
+
+    case INTERFACE_GENERIC:
+    case INTERFACE_DTIO:
+      return current_interface.sym != nullptr;
+
+    case INTERFACE_USER_OP:
+      return current_interface.uop != nullptr;
+
+    default:
+      return false;
+    }
+}
+
+
+/* Return a pointer to the interface currently being parsed, or nullptr if
+   we are not currently parsing an interface body.  */
+
+static gfc_interface **
+get_current_interface_ptr ()
+{
+  if (current_interface_valid_p ())
+    {
+      gfc_interface *& ifc_ptr = gfc_current_interface_head ();
+      return &ifc_ptr;
+    }
+  else
+    return nullptr;
+}
+
+
 static bool in_specification_block;
 
 /* This is the primary 'decode_statement'.  */
@@ -307,6 +354,11 @@ decode_statement (void)
   gfc_clear_error ();	/* Clear any pending errors.  */
   gfc_clear_warning ();	/* Clear any pending warnings.  */
 
+  current_interface_ptr = get_current_interface_ptr ();
+  previous_interface_head = current_interface_ptr == nullptr
+			    ? nullptr
+			    : *current_interface_ptr;
+
   gfc_matching_function = false;
 
   if (gfc_match_eos () == MATCH_YES)
@@ -3042,6 +3094,8 @@ reject_statement (void)
 {
   gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
   gfc_current_ns->equiv = gfc_current_ns->old_equiv;
+  gfc_drop_interface_elements_before (current_interface_ptr,
+				      previous_interface_head);
 
   gfc_reject_data (gfc_current_ns);
 
diff --git a/gcc/testsuite/gfortran.dg/interface_procedure_1.f90 b/gcc/testsuite/gfortran.dg/interface_procedure_1.f90
new file mode 100644
index 00000000000..6a58b6a7bcc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_procedure_1.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-additional-options "-std=f95" }
+!
+! PR fortran/48776
+! The following used to generate a segmentation fault in the front-end,
+! because a pointer to the get1 symbol was remaining in the get interface
+! after the procedure statement was rejected and the symbol freed.
+
+  interface get
+    procedure get1  ! { dg-error "Fortran 2003: PROCEDURE statement" }
+  end interface
+
+  integer :: h
+  call set1 (get (h))  ! { dg-error "no specific function for the generic 'get'" }
+contains
+  subroutine set1 (a)
+    integer, intent(in) :: a
+  end subroutine
+
+  integer function get1 (s)
+    integer :: s
+  end function
+end
-- 
2.40.1