Fortran: Fix ICE on invalid CLASS component in derived type [PR106946]

When a CLASS component declaration inside a derived type has a syntax
error (for example, a missing comma), gfc_build_class_symbol creates a
CLASS container symbol outside the undo mechanism.  Error recovery then
frees the referenced type but leaves the CLASS container orphaned with
dangling pointers, leading to an ICE during later resolution.

Fix this by removing CLASS components created during a failed data
declaration from the derived type component chain, deleting their
namespace symtree entries only when they are still present, releasing
the CLASS container symbol, and freeing the component itself.  Also
expand the regression coverage to exercise allocatable and pointer CLASS
declarations, including a valid component followed by a bad one.

gcc/fortran/ChangeLog:

	PR fortran/106946
	* decl.cc (gfc_match_data_decl): Remove CLASS components added by a
	failed declaration in a derived type, and guard symtree deletion.
	* gfortran.h (gfc_free_component, gfc_delete_symtree): Declare.
	* symbol.cc (gfc_free_component): New function.
	(free_components): Use it.
	(gfc_delete_symtree): Make non-static.

gcc/testsuite/ChangeLog:

	PR fortran/106946
	* gfortran.dg/pr106946.f90: Cover allocatable and pointer CLASS
	declarations, including a valid component followed by a bad one.

Signed-off-by: Christopher Albert <albert@tugraz.at>

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 8b659a3f36abd422f31620aec33090affe86672e..b74ee97157c16e2eac7ebe74cf6829d8ba73d7bf 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -6819,12 +6819,28 @@ gfc_match_data_decl (void)
   gfc_symbol *sym;
   match m;
   int elem;
+  gfc_component *comp_tail = NULL;
 
   type_param_spec_list = NULL;
   decl_type_param_list = NULL;
 
   num_idents_on_line = 0;
 
+  /* Record the last component before we start, so that we can roll back
+     any components added during this statement on error.  PR106946.
+     Must be set before any 'goto cleanup' with m == MATCH_ERROR.  */
+  if (gfc_comp_struct (gfc_current_state ()))
+    {
+      gfc_symbol *block = gfc_current_block ();
+      if (block)
+       {
+         comp_tail = block->components;
+         if (comp_tail)
+           while (comp_tail->next)
+             comp_tail = comp_tail->next;
+       }
+    }
+
   m = gfc_match_decl_type_spec (&current_ts, 0);
   if (m != MATCH_YES)
     return m;
@@ -6944,6 +6960,49 @@ ok:
   gfc_free_data_all (gfc_current_ns);
 
 cleanup:
+  /* If we failed inside a derived type definition, remove any CLASS
+     components that were added during this failed statement.  For CLASS
+     components, gfc_build_class_symbol creates an extra container symbol in
+     the namespace outside the normal undo machinery.  When reject_statement
+     later calls gfc_undo_symbols, the declaration state is rolled back but
+     that helper symbol survives and leaves the component dangling.  Ordinary
+     components do not create that extra helper symbol, so leave them in
+     place for the usual follow-up diagnostics.  PR106946.  */
+  if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
+    {
+      gfc_symbol *block = gfc_current_block ();
+      if (block)
+       {
+         gfc_component **prev;
+         if (comp_tail)
+           prev = &comp_tail->next;
+         else
+           prev = &block->components;
+
+         while (*prev)
+           {
+             gfc_component *c = *prev;
+             if (c->ts.type == BT_CLASS && c->ts.u.derived
+                 && c->ts.u.derived->attr.is_class)
+               {
+                 /* Unlink this CLASS component.  */
+                 *prev = c->next;
+
+                 /* Remove the CLASS container from the namespace.  */
+                 gfc_symbol *fclass = c->ts.u.derived;
+                 if (gfc_find_symtree (fclass->ns->sym_root, fclass->name))
+                   gfc_delete_symtree (&fclass->ns->sym_root, fclass->name);
+                 gfc_release_symbol (fclass);
+
+                 /* Free the component structure.  */
+                 gfc_free_component (c);
+               }
+             else
+               prev = &c->next;
+           }
+       }
+    }
+
   if (saved_kind_expr)
     gfc_free_expr (saved_kind_expr);
   if (type_param_spec_list)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index bbf3968eacbb5d89c7f6528732406a184cb4a213..b0ce54e1c2107c23a6cc6b31bfd8f3ec0f9d7401 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3779,6 +3779,7 @@ bool gfc_missing_attr (symbol_attribute *, locus *);
 bool gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *);
 int gfc_copy_dummy_sym (gfc_symbol **, gfc_symbol *, int);
 bool gfc_add_component (gfc_symbol *, const char *, gfc_component **);
+void gfc_free_component (gfc_component *);
 gfc_symbol *gfc_use_derived (gfc_symbol *);
 gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool,
                                    gfc_ref **);
@@ -3793,6 +3794,7 @@ gfc_st_label *gfc_rebind_label (gfc_st_label *, int);
 
 gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
 gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
+void gfc_delete_symtree (gfc_symtree **, const char *);
 gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
 gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
 gfc_user_op *gfc_get_uop (const char *);

diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 9edfb8e9eebd82dffb2908670036c64956b54e08..32d12600a19f7a9e241f335277801d2b64d29df7 100644 (file)
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -2734,6 +2734,21 @@ gfc_find_component (gfc_symbol *sym, const char *name,
 /* Given a symbol, free all of the component structures and everything
    they point to.  */
 
+void
+gfc_free_component (gfc_component *p)
+{
+  gfc_free_array_spec (p->as);
+  gfc_free_expr (p->initializer);
+  if (p->kind_expr)
+    gfc_free_expr (p->kind_expr);
+  if (p->param_list)
+    gfc_free_actual_arglist (p->param_list);
+  free (p->tb);
+  p->tb = NULL;
+  free (p);
+}
+
+
 static void
 free_components (gfc_component *p)
 {
@@ -2742,16 +2757,7 @@ free_components (gfc_component *p)
   for (; p; p = q)
     {
       q = p->next;
-
-      gfc_free_array_spec (p->as);
-      gfc_free_expr (p->initializer);
-      if (p->kind_expr)
-       gfc_free_expr (p->kind_expr);
-      if (p->param_list)
-       gfc_free_actual_arglist (p->param_list);
-      free (p->tb);
-      p->tb = NULL;
-      free (p);
+      gfc_free_component (p);
     }
 }
 
@@ -3147,7 +3153,7 @@ gfc_new_symtree (gfc_symtree **root, const char *name)
 
 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
 
-static void
+void
 gfc_delete_symtree (gfc_symtree **root, const char *name)
 {
   gfc_symtree st, *st0;

diff --git a/gcc/testsuite/gfortran.dg/pr106946.f90 b/gcc/testsuite/gfortran.dg/pr106946.f90
new file mode 100644 (file)
index 0000000..d7c5348
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr106946.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! PR fortran/106946
+! ICE in resolve_component on invalid CLASS declaration with missing comma.
+!
+! The bad declarations below should diagnose and continue without leaving
+! behind dangling CLASS container symbols in the surrounding namespace.
+
+program p
+  type :: u
+  end type
+
+  type :: v
+  end type
+
+  type :: w
+  end type
+
+  type :: t1
+    class(u), allocatable :: a b  ! { dg-error "Syntax error in data declaration" }
+  end type
+
+  type :: t2
+    class(v), pointer :: p q  ! { dg-error "Syntax error in data declaration" }
+  end type
+
+  type :: t3
+    class(w), allocatable :: ok
+    class(w), allocatable :: x y  ! { dg-error "Syntax error in data declaration" }
+  end type
+end