re PR fortran/44212 ([OOP] ICE when defining a pointer component before defining…

re PR fortran/44212 ([OOP] ICE when defining a pointer component before defining the class and calling a TBP then)

2010-05-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44212
	* match.c (gfc_match_select_type): On error jump back out of the local
	namespace.
	* parse.c (parse_derived): Defer creation of vtab symbols to resolution
	stage, more precisely to ...
	* resolve.c (resolve_fl_derived): ... this place.


2010-05-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44212
	* gfortran.dg/class_22.f03: New.

From-SVN: r159745

gcc/fortran/ChangeLog

 2010-05-22  Janus Weil  <janus@gcc.gnu.org>
 
+	PR fortran/44212
+	* match.c (gfc_match_select_type): On error jump back out of the local
+	namespace.
+	* parse.c (parse_derived): Defer creation of vtab symbols to resolution
+	stage, more precisely to ...
+	* resolve.c (resolve_fl_derived): ... this place.
+
+2010-05-22  Janus Weil  <janus@gcc.gnu.org>
+
 	PR fortran/44213
 	* resolve.c (ensure_not_abstract): Allow abstract types with
 	non-abstract ancestors.

gcc/fortran/match.c

@@ -4319,7 +4319,10 @@ gfc_match_select_type (void)
       expr1 = gfc_get_expr();
       expr1->expr_type = EXPR_VARIABLE;
       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
-	return MATCH_ERROR;
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
       if (expr2->ts.type == BT_UNKNOWN)
 	expr1->symtree->n.sym->attr.untyped = 1;
       else
@@ -4331,19 +4334,20 @@ gfc_match_select_type (void)
     {
       m = gfc_match (" %e ", &expr1);
       if (m != MATCH_YES)
-	return m;
+	goto cleanup;
     }
 
   m = gfc_match (" )%t");
   if (m != MATCH_YES)
-    return m;
+    goto cleanup;
 
   /* Check for F03:C811.  */
   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
     {
       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
 		 "use associate-name=>");
-      return MATCH_ERROR;
+      m = MATCH_ERROR;
+      goto cleanup;
     }
 
   new_st.op = EXEC_SELECT_TYPE;
@@ -4354,6 +4358,10 @@ gfc_match_select_type (void)
   select_type_push (expr1->symtree->n.sym);
 
   return MATCH_YES;
+  
+cleanup:
+  gfc_current_ns = gfc_current_ns->parent;
+  return m;
 }
 
 

gcc/fortran/parse.c

@@ -2110,22 +2110,6 @@ endType:
 	  || c->attr.access == ACCESS_PRIVATE
 	  || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
 	sym->attr.private_comp = 1;
-
-     /* Fix up incomplete CLASS components.  */
-     if (c->ts.type == BT_CLASS)
-	{
-	  gfc_component *data;
-	  gfc_component *vptr;
-	  gfc_symbol *vtab;
-	  data = gfc_find_component (c->ts.u.derived, "$data", true, true);
-	  vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
-	  if (vptr->ts.u.derived == NULL)
-	    {
-	      vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
-	      gcc_assert (vtab);
-	      vptr->ts.u.derived = vtab->ts.u.derived;
-	    }
-	}
     }
 
   if (!seen_component)

gcc/fortran/resolve.c

@@ -10577,6 +10577,22 @@ resolve_fl_derived (gfc_symbol *sym)
   int i;
 
   super_type = gfc_get_derived_super_type (sym);
+  
+  if (sym->attr.is_class && sym->ts.u.derived == NULL)
+    {
+      /* Fix up incomplete CLASS symbols.  */
+      gfc_component *data;
+      gfc_component *vptr;
+      gfc_symbol *vtab;
+      data = gfc_find_component (sym, "$data", true, true);
+      vptr = gfc_find_component (sym, "$vptr", true, true);
+      if (vptr->ts.u.derived == NULL)
+	{
+	  vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
+	  gcc_assert (vtab);
+	  vptr->ts.u.derived = vtab->ts.u.derived;
+	}
+    }
 
   /* F2008, C432. */
   if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp)

gcc/testsuite/ChangeLog

+2010-05-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44212
+	* gfortran.dg/class_22.f03: New.
+
 2010-05-22  Iain Sandoe  <iains@gcc.gnu.org>
 
 	PR lto/44238

gcc/testsuite/gfortran.dg/class_22.f03

+! { dg-do compile }
+!
+! PR 44212: [OOP] ICE when defining a pointer component before defining the class and calling a TBP then
+!
+! Contributed by Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
+
+module ice_module
+
+  type :: B_type
+     class(A_type),pointer :: A_comp
+  end type B_type
+
+  type :: A_type
+  contains
+     procedure :: A_proc
+  end type A_type
+
+contains
+
+  subroutine A_proc(this)
+    class(A_type),target,intent(inout) :: this
+  end subroutine A_proc
+
+  subroutine ice_proc(this)
+    class(A_type) :: this
+    call this%A_proc()
+  end subroutine ice_proc
+
+end module ice_module
+
+! { dg-final { cleanup-modules "ice_module" } }