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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159745 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9e4702e..abba8f5 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
 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.

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0f970f6..a2ecb3a 100644 (file)
--- a/gcc/fortran/match.c
+++ b/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;
 }
 
 

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9320069..dfc5893 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/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)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f08e198..1f4c236 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 70f6272..6c31ffb 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/class_22.f03 b/gcc/testsuite/gfortran.dg/class_22.f03
new file mode 100644 (file)
index 0000000..df68783
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_22.f03
@@ -0,0 +1,31 @@
+! { 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" } }