This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: OOP on fortran-dev branch


Hi all,

here is an update of the OOP patch with many new fixes. It should
handle the most common cases of CLASS pointer assignments now (see
attached test case). Some CLASS allocate statements will also work
(e.g. class_1.f03), but probably not all cases yet. The patch also
behaves a bit better on Salvatore's code, but one still gets an ICE at
some point (in psb_mat_mod.f03).

The question is how to go on: Should I just commit this to the branch
now, or rather wait until trunk is a reasonable state again?


>> But I also made some modifications on Paul's
>> 'gfc_add_class_..._reference' functions, which I think did not quite
>> do the right thing. In particular I merged both into one function,
>> which I called 'gfc_add_component_ref'. Paul, could you have a look at
>> this, and make sure it is correct?
>
> I do not think that it is. ?In particular, you must not stick the
> component reference after the final array reference, when the class
> object has non-zero rank. ?Your 'while' loop will have to stop when
> the next reference is an array reference with the array-spec of the
> class object.... if you see what I mean!

I see. That means that in general one can neither just insert the new
reference at the end, nor at the beginning. I hope the present
implementation is reasonable (at least it works for my class pointer
assignment examples, and some class allocate statements).


Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/typebound_call_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_2.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_call_2.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Check calls with passed-objects.
 
Index: gcc/testsuite/gfortran.dg/typebound_call_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_4.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_call_4.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Check for recognition/errors with more complicated references and some
 ! error-handling in general.
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_proc_1.f08	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Test that the basic syntax for specific bindings is parsed and resolved.
 
Index: gcc/testsuite/gfortran.dg/class_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_1.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/class_1.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 40940: CLASS statement
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
Index: gcc/testsuite/gfortran.dg/typebound_generic_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_3.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_generic_3.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 
-! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Check calls with GENERIC bindings.
 
Index: gcc/testsuite/gfortran.dg/typebound_operator_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_2.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_operator_2.f03	(Arbeitskopie)
@@ -1,6 +1,4 @@
 ! { dg-do compile }
-! { dg-options "-w" }
-! FIXME: Remove -w once CLASS is fully supported.
 
 ! Type-bound procedures
 ! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage.
Index: gcc/testsuite/gfortran.dg/typebound_operator_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_4.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_operator_4.f03	(Arbeitskopie)
@@ -1,6 +1,4 @@
 ! { dg-do compile }
-! { dg-options "-w" }
-! FIXME: Remove -w when CLASS is fully implemented.
 
 ! Type-bound procedures
 ! Check for errors with operator calls.
Index: gcc/testsuite/gfortran.dg/typebound_proc_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_5.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Test for errors in specific bindings, during resolution.
 
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_1.f90	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 39630: [F03] Procedure Pointer Components with PASS
 !
 ! found at http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_3.f90	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 39630: [F03] Procedure Pointer Components with PASS
 !
 ! taken from "Fortran 95/2003 explained" (Metcalf, Reid, Cohen, 2004)
Index: gcc/testsuite/gfortran.dg/typebound_call_10.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_10.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_call_10.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 39630: [F03] Procedure Pointer Components with PASS
 !
 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
Index: gcc/testsuite/gfortran.dg/typebound_call_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_3.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_call_3.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Check that calls work across module-boundaries.
 
Index: gcc/testsuite/gfortran.dg/allocate_derived_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_derived_1.f90	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/allocate_derived_1.f90	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! ALLOCATE statements with derived type specification
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
Index: gcc/testsuite/gfortran.dg/typebound_operator_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_1.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_operator_1.f03	(Arbeitskopie)
@@ -1,6 +1,4 @@
 ! { dg-do compile }
-! { dg-options "-w" }
-! FIXME: Remove -w once CLASS is fully supported.
 
 ! Type-bound procedures
 ! Check correct type-bound operator definitions.
Index: gcc/testsuite/gfortran.dg/typebound_call_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_9.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_call_9.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 
-! FIXME: Remove once polymorphic PASS is resolved
-! { dg-options "-w" }
-
 ! PR fortran/37638
 ! If a PASS(arg) is invalid, a call to this routine later would ICE in
 ! resolving.  Check that this also works for GENERIC, in addition to the
Index: gcc/testsuite/gfortran.dg/class_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_2.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/class_2.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 40940: CLASS statement
 !
 ! Contributed by Janus Weil <janus@gcc.gnu.org>
Index: gcc/testsuite/gfortran.dg/typebound_generic_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_4.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_generic_4.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 
-! FIXME: Remove -w once the TYPE/CLASS issue is resolved
-! { dg-options "-w" }
-
 ! PR fortran/37588
 ! This test used to not resolve the GENERIC binding.
 
Index: gcc/testsuite/gfortran.dg/typebound_operator_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_3.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_operator_3.f03	(Arbeitskopie)
@@ -1,6 +1,4 @@
 ! { dg-do run }
-! { dg-options "-w" }
-! FIXME: Remove -w when CLASS is fully implemented.
 
 ! Type-bound procedures
 ! Check they can actually be called and run correctly.
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do compile }
 
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-
 ! Type-bound procedures
 ! Test for the check if overriding methods "match" the overridden ones by their
 ! characteristics.
Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90	(Revision 151849)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_pass_2.f90	(Arbeitskopie)
@@ -1,8 +1,5 @@
 ! { dg-do run }
 !
-! FIXME: Remove -w after polymorphic entities are supported.
-! { dg-options "-w" }
-!
 ! PR 39630: [F03] Procedure Pointer Components with PASS
 !
 ! taken from "The Fortran 2003 Handbook" (Adams et al., 2009)
Index: gcc/testsuite/ChangeLog.fortran-dev
===================================================================
--- gcc/testsuite/ChangeLog.fortran-dev	(Revision 0)
+++ gcc/testsuite/ChangeLog.fortran-dev	(Revision 0)
@@ -0,0 +1,22 @@
+2009-09-20  Janus Weil  <janus@gcc.gnu.org>
+
+	* gfortran.dg/allocate_derived_1.f90: Remove -w option.
+	* gfortran.dg/class_1.f03: Ditto.
+	* gfortran.dg/class_2.f03: Ditto.
+	* gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto.
+	* gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto.
+	* gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto.
+	* gfortran.dg/typebound_call_10.f03: Ditto.
+	* gfortran.dg/typebound_call_2.f03: Ditto.
+	* gfortran.dg/typebound_call_3.f03: Ditto.
+	* gfortran.dg/typebound_call_4.f03: Ditto.
+	* gfortran.dg/typebound_call_9.f03: Ditto.
+	* gfortran.dg/typebound_generic_3.f03: Ditto.
+	* gfortran.dg/typebound_generic_4.f03: Ditto.
+	* gfortran.dg/typebound_operator_1.f03: Ditto.
+	* gfortran.dg/typebound_operator_2.f03: Ditto.
+	* gfortran.dg/typebound_operator_3.f03: Ditto.
+	* gfortran.dg/typebound_operator_4.f03: Ditto.
+	* gfortran.dg/typebound_proc_1.f08: Ditto.
+	* gfortran.dg/typebound_proc_5.f03: Ditto.
+	* gfortran.dg/typebound_proc_6.f03: Ditto.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 151849)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -360,6 +360,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, g
 {
   gfc_component *dt1, *dt2;
 
+  if (derived1 == derived2)
+    return 1;
+
   /* Special case for comparing derived types across namespaces.  If the
      true names and module names are the same and the module name is
      nonnull, then they are equal.  */
@@ -448,13 +451,15 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec
   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     return 1;
    
-  if (ts1->type != ts2->type)
+  if (ts1->type != ts2->type
+      && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+	  || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
     return 0;
-  if (ts1->type != BT_DERIVED)
+  if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
     return (ts1->kind == ts2->kind);
 
   /* Compare derived types.  */
-  if (ts1->u.derived == ts2->u.derived)
+  if (gfc_type_compatible (ts1, ts2))
     return 1;
 
   return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 151849)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -510,8 +510,12 @@ conv_parent_component_references (gfc_se * se, gfc
 
   if (dt->attr.extension && dt->components)
     {
+      if (dt->attr.is_class)
+	cmp = dt->components;
+      else
+	cmp = dt->components->next;
       /* Return if the component is not in the parent type.  */
-      for (cmp = dt->components->next; cmp; cmp = cmp->next)
+      for (; cmp; cmp = cmp->next)
 	if (strcmp (c->name, cmp->name) == 0)
 	  return;
 	
@@ -3607,6 +3611,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespe
       switch (ts->type)
 	{
 	case BT_DERIVED:
+	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
 	  gfc_conv_structure (&se, expr, 1);
 	  return se.expr;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 151849)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -4534,6 +4534,23 @@ gfc_get_derived_super_type (gfc_symbol* derived)
 }
 
 
+/* Get the ultimate super-type of a given derived type.  */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+  if (!derived->attr.extension)
+    return NULL;
+
+  derived = gfc_get_derived_super_type (derived);
+
+  if (derived->attr.extension)
+    return gfc_get_ultimate_derived_super_type (derived);
+  else
+    return derived;
+}
+
+
 /* Check if two typespecs are type compatible (F03:5.1.1.2):
    If ts1 is nonpolymorphic, ts2 must be the same type.
    If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
@@ -4541,16 +4558,17 @@ gfc_get_derived_super_type (gfc_symbol* derived)
 bool
 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
 {
-  if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
+  if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
+      && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
     {
       gfc_symbol *t0, *t;
-      if (ts1->is_class)
+      if (ts1->type == BT_CLASS)
 	{
-	  t0 = ts1->u.derived;
+	  t0 = ts1->u.derived->components->ts.u.derived;
 	  t = ts2->u.derived;
-	  while (t0 != t && t->attr.extension)
+	  while (!gfc_compare_derived_types (t0, t) && t->attr.extension)
 	    t = gfc_get_derived_super_type (t);
-	  return (t0 == t);
+	  return gfc_compare_derived_types (t0, t);
 	}
       else
 	return (ts1->u.derived == ts2->u.derived);
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 151849)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -1025,6 +1025,75 @@ verify_c_interop_param (gfc_symbol *sym)
 }
 
 
+/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
+   A CLASS entity is represented by an encapsulating type, which contains the
+   declared type as 'data' component, plus an integer component 'vindex' which
+   determines the dynamic type.  */
+
+static gfc_try
+encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+			  gfc_array_spec **as)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 5];
+  gfc_symbol *fclass;
+  gfc_component *c;
+
+  /* Determine the name of the encapsulating type.  */
+  if ((*as) && (*as)->rank && attr->allocatable)
+    sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+  else if ((*as) && (*as)->rank)
+    sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+  else if (attr->allocatable)
+    sprintf (name, ".class.%s.a", ts->u.derived->name);
+  else
+    sprintf (name, ".class.%s", ts->u.derived->name);
+
+  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+  if (fclass == NULL)
+    {
+      gfc_symtree *st;
+      /* If not there, create a new symbol.  */
+      fclass = gfc_new_symbol (name, ts->u.derived->ns);
+      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+      st->n.sym = fclass;
+      gfc_set_sym_referenced (fclass);
+      fclass->refs++;
+      fclass->ts.type = BT_UNKNOWN;
+      fclass->vindex = ts->u.derived->vindex;
+      if (ts->u.derived->f2k_derived)
+	fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+	  NULL, &gfc_current_locus) == FAILURE)
+	return FAILURE;
+
+      /* Add component 'data'.  */
+      if (gfc_add_component (fclass, "data", &c) == FAILURE)
+   	return FAILURE;
+      c->ts = *ts;
+      c->ts.type = BT_DERIVED;
+      c->attr.access = ACCESS_PRIVATE;
+      c->ts.u.derived = ts->u.derived;
+      c->attr.pointer = attr->pointer || attr->dummy;
+      c->attr.allocatable = attr->allocatable;
+      c->attr.dimension = attr->dimension;
+      c->as = (*as);
+
+      /* Add component 'vindex'.  */
+      if (gfc_add_component (fclass, "vindex", &c) == FAILURE)
+   	return FAILURE;
+      c->ts.type = BT_INTEGER;
+      c->ts.kind = 4;
+      c->attr.access = ACCESS_PRIVATE;
+    }
+
+  fclass->attr.extension = 1;
+  fclass->attr.is_class = 1;
+  ts->u.derived = fclass;
+  attr->allocatable = attr->pointer = attr->dimension = 0;
+  (*as) = NULL;  /* XXX */
+  return SUCCESS;
+}
+
 /* Function called by variable_decl() that adds a name to the symbol table.  */
 
 static gfc_try
@@ -1097,6 +1166,9 @@ build_sym (const char *name, gfc_charlen *cl,
 
   sym->attr.implied_index = 0;
 
+  if (sym->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+
   return SUCCESS;
 }
 
@@ -1467,6 +1539,9 @@ build_struct (const char *name, gfc_charlen *cl, g
 	}
     }
 
+  if (c->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
   /* Check array components.  */
   if (!c->attr.dimension)
     {
@@ -2370,24 +2445,20 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int im
     }
 
   m = gfc_match (" type ( %n )", name);
-  if (m != MATCH_YES)
+  if (m == MATCH_YES)
+    ts->type = BT_DERIVED;
+  else
     {
       m = gfc_match (" class ( %n )", name);
       if (m != MATCH_YES)
 	return m;
-      ts->is_class = 1;
+      ts->type = BT_CLASS;
 
       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
 			  == FAILURE)
 	return MATCH_ERROR;
-
-      /* TODO: Implement Polymorphism.  */
-      gfc_warning ("Polymorphic entities are not yet implemented. "
-		   "CLASS will be treated like TYPE at %C");
     }
 
-  ts->type = BT_DERIVED;
-
   /* Defer association of the derived type until the end of the
      specification block.  However, if the derived type can be
      found, add it to the typespec.  */  
@@ -6776,6 +6847,7 @@ gfc_match_derived_decl (void)
     {
       gfc_component *p;
       gfc_symtree *st;
+      gfc_symbol *declared_type;
 
       /* Add the extended derived type as the first component.  */
       gfc_add_component (sym, parent, &p);
@@ -6792,6 +6864,14 @@ gfc_match_derived_decl (void)
 	extended->f2k_derived = gfc_get_namespace (NULL, 0);
       st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
       st->n.sym = sym;
+
+      /* Increment the VINDEX of the top-level declared type and set
+	 the VINDEX for this one.  This is done so that the size of
+	 the VTABLE entries for the top-level derived type is VINDEX.  */
+      declared_type = gfc_get_ultimate_derived_super_type (sym);
+      if (declared_type->vindex == 0)
+	declared_type->vindex++; 
+      sym->vindex = declared_type->vindex++;
     }
 
   /* Take over the ABSTRACT attribute.  */
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c	(Revision 151849)
+++ gcc/fortran/dump-parse-tree.c	(Arbeitskopie)
@@ -825,7 +825,12 @@ show_symbol (gfc_symbol *sym)
     }
 
   if (sym->f2k_derived)
-    show_f2k_derived (sym->f2k_derived);
+    {
+      show_indent ();
+      if (sym->vindex)
+	fprintf (dumpfile, "vindex: %d", sym->vindex);
+      show_f2k_derived (sym->f2k_derived);
+    }
 
   if (sym->formal)
     {
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 151849)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -142,9 +142,8 @@ gfc_source_form;
 /* Basic types.  BT_VOID is used by ISO C Binding so funcs like c_f_pointer
    can take any arg with the pointer attribute as a param.  */
 typedef enum
-{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
-  BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH,
-  BT_VOID
+{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, BT_LOGICAL, BT_CHARACTER,
+  BT_DERIVED, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID
 }
 bt;
 
@@ -668,6 +667,7 @@ typedef struct
 
   unsigned is_bind_c:1;		/* say if is bound to C.  */
   unsigned extension:1;		/* extends a derived type.  */
+  unsigned is_class:1;		/* is a CLASS container.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
@@ -847,7 +847,6 @@ typedef struct
   u;
 
   struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
-  unsigned int is_class:1;
   int is_c_interop;
   int is_iso_c;
   bt f90_type; 
@@ -1131,6 +1130,11 @@ typedef struct gfc_symbol
   /* Defined only for Cray pointees; points to their pointer.  */
   struct gfc_symbol *cp_pointer;
 
+  int entry_id;			/* Used in resolve.c for entries.  */
+
+  /* CLASS vindex for declared and dynamic types in the class.  */
+  int vindex;
+
   struct gfc_symbol *common_next;	/* Links for COMMON syms */
 
   /* This is in fact a gfc_common_head but it is only used for pointer
@@ -1141,8 +1145,6 @@ typedef struct gfc_symbol
      order.  */
   int dummy_order;
 
-  int entry_id;
-
   gfc_namelist *namelist, *namelist_tail;
 
   /* Change management fields.  Symbols that might be modified by the
@@ -2469,6 +2471,7 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, cons
 
 gfc_typebound_proc* gfc_get_typebound_proc (void);
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
 bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
 				      const char*, bool, locus*);
@@ -2544,6 +2547,7 @@ const char *gfc_extract_int (gfc_expr *, int *);
 gfc_expr *gfc_expr_to_initialize (gfc_expr *);
 bool is_subref_array (gfc_expr *);
 
+void gfc_add_component_ref (gfc_expr *, const char *);
 gfc_expr *gfc_build_conversion (gfc_expr *);
 void gfc_free_ref_list (gfc_ref *);
 void gfc_type_convert_binary (gfc_expr *);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 151849)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -330,6 +330,33 @@ gfc_has_vector_index (gfc_expr *e)
 }
 
 
+/* Insert a reference to the component of the given name.  */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+  gfc_ref **tail = &(e->ref);
+  gfc_ref *next = NULL;
+  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+  while (*tail != NULL)
+    {
+      if ((*tail)->type == REF_COMPONENT)
+	derived = (*tail)->u.c.component->ts.u.derived;
+      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+	break;
+      tail = &((*tail)->next);
+    }
+  if (*tail != NULL && strcmp (name, "data") == 0)
+    next = *tail;
+  (*tail) = gfc_get_ref();
+  (*tail)->next = next;
+  (*tail)->type = REF_COMPONENT;
+  (*tail)->u.c.sym = derived;
+  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+  gcc_assert((*tail)->u.c.component);
+}
+
+
 /* Copy a shape array.  */
 
 mpz_t *
@@ -481,6 +508,7 @@ gfc_copy_expr (gfc_expr *p)
 	case BT_HOLLERITH:
 	case BT_LOGICAL:
 	case BT_DERIVED:
+	case BT_CLASS:
 	  break;		/* Already done.  */
 
 	case BT_PROCEDURE:
@@ -3124,7 +3152,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
       return FAILURE;
     }
 
-  if (!pointer && !proc_pointer)
+  if (!pointer && !proc_pointer
+	&& !(lvalue->ts.type == BT_CLASS
+		&& lvalue->ts.u.derived->components->attr.pointer))
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3244,7 +3274,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
       return SUCCESS;
     }
 
-  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
+  if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
+	&& !gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
 		 "assignment of %s to %s", &lvalue->where, 
@@ -3252,7 +3283,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
       return FAILURE;
     }
 
-  if (lvalue->ts.kind != rvalue->ts.kind)
+  if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
     {
       gfc_error ("Different kind type parameters in pointer "
 		 "assignment at %L", &lvalue->where);
@@ -3332,7 +3363,9 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer || sym->attr.proc_pointer)
+  if (sym->attr.pointer || sym->attr.proc_pointer
+      || (sym->ts.type == BT_CLASS 
+	  && sym->ts.u.derived->components->attr.pointer))
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(Revision 151849)
+++ gcc/fortran/module.c	(Arbeitskopie)
@@ -2004,6 +2004,7 @@ static const mstring bt_types[] = {
     minit ("LOGICAL", BT_LOGICAL),
     minit ("CHARACTER", BT_CHARACTER),
     minit ("DERIVED", BT_DERIVED),
+    minit ("CLASS", BT_CLASS),
     minit ("PROCEDURE", BT_PROCEDURE),
     minit ("UNKNOWN", BT_UNKNOWN),
     minit ("VOID", BT_VOID),
@@ -2054,7 +2055,7 @@ mio_typespec (gfc_typespec *ts)
 
   ts->type = MIO_NAME (bt) (ts->type, bt_types);
 
-  if (ts->type != BT_DERIVED)
+  if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
     mio_integer (&ts->kind);
   else
     mio_symbol_ref (&ts->u.derived);
@@ -3566,7 +3567,10 @@ mio_symbol (gfc_symbol *sym)
     }
   
   mio_integer (&(sym->intmod_sym_id));
-  
+
+  if (sym->attr.flavor == FL_DERIVED)
+    mio_integer (&(sym->vindex));
+
   mio_rparen ();
 }
 
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(Revision 151849)
+++ gcc/fortran/trans-types.c	(Arbeitskopie)
@@ -1029,6 +1029,7 @@ gfc_typenode_for_spec (gfc_typespec * spec)
       break;
 
     case BT_DERIVED:
+    case BT_CLASS:
       basetype = gfc_get_derived_type (spec->u.derived);
 
       /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
@@ -2063,7 +2064,7 @@ gfc_get_derived_type (gfc_symbol * derived)
      will be built and so we can return the type.  */
   for (c = derived->components; c; c = c->next)
     {
-      if (c->ts.type != BT_DERIVED)
+      if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
 	continue;
 
       if ((!c->attr.pointer && !c->attr.proc_pointer)
@@ -2098,7 +2099,7 @@ gfc_get_derived_type (gfc_symbol * derived)
     {
       if (c->attr.proc_pointer)
 	field_type = gfc_get_ppc_type (c);
-      else if (c->ts.type == BT_DERIVED)
+      else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
         field_type = c->ts.u.derived->backend_decl;
       else
 	{
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 151849)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -3912,7 +3912,10 @@ find_array_spec (gfc_expr *e)
   gfc_symbol *derived;
   gfc_ref *ref;
 
-  as = e->symtree->n.sym->as;
+  if (e->symtree->n.sym->ts.type == BT_CLASS)
+    as = e->symtree->n.sym->ts.u.derived->components->as;
+  else
+    as = e->symtree->n.sym->as;
   derived = NULL;
 
   for (ref = e->ref; ref; ref = ref->next)
@@ -4825,7 +4828,7 @@ check_typebound_baseobject (gfc_expr* e)
   if (!base)
     return FAILURE;
 
-  gcc_assert (base->ts.type == BT_DERIVED);
+  gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
   if (base->ts.u.derived->attr.abstract)
     {
       gfc_error ("Base object for type-bound procedure call at %L is of"
@@ -5032,8 +5035,11 @@ static gfc_try
 resolve_ppc_call (gfc_code* c)
 {
   gfc_component *comp;
-  gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
+  bool b;
 
+  b = gfc_is_proc_ptr_comp (c->expr1, &comp);
+  gcc_assert (b);
+
   c->resolved_sym = c->expr1->symtree->n.sym;
   c->expr1->expr_type = EXPR_VARIABLE;
 
@@ -5064,8 +5070,11 @@ static gfc_try
 resolve_expr_ppc (gfc_expr* e)
 {
   gfc_component *comp;
-  gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
+  bool b;
 
+  b = gfc_is_proc_ptr_comp (e, &comp);
+  gcc_assert (b);
+
   /* Convert to EXPR_FUNCTION.  */
   e->expr_type = EXPR_FUNCTION;
   e->value.function.isym = NULL;
@@ -5496,6 +5505,12 @@ resolve_deallocate_expr (gfc_expr *e)
       return FAILURE;
     }
 
+  if (e->ts.type == BT_CLASS)
+    {
+      /* Only deallocate the DATA component.  */
+      gfc_add_component_ref (e, "data");
+    }
+
   return SUCCESS;
 }
 
@@ -5574,6 +5589,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
      pointer, the next-to-last reference must be a pointer.  */
 
   ref2 = NULL;
+  if (e->symtree)
+    sym = e->symtree->n.sym;
 
   if (e->expr_type != EXPR_VARIABLE)
     {
@@ -5584,9 +5601,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
     }
   else
     {
-      allocatable = e->symtree->n.sym->attr.allocatable;
-      pointer = e->symtree->n.sym->attr.pointer;
-      dimension = e->symtree->n.sym->attr.dimension;
+      if (sym->ts.type == BT_CLASS)
+	{
+	  allocatable = sym->ts.u.derived->components->attr.allocatable;
+	  pointer = sym->ts.u.derived->components->attr.pointer;
+	  dimension = sym->ts.u.derived->components->attr.dimension;
+	}
+      else
+	{
+	  allocatable = sym->attr.allocatable;
+	  pointer = sym->attr.pointer;
+	  dimension = sym->attr.dimension;
+	}
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
 	{
@@ -5601,11 +5627,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
 		break;
 
 	      case REF_COMPONENT:
-		allocatable = (ref->u.c.component->as != NULL
-			       && ref->u.c.component->as->type == AS_DEFERRED);
-
-		pointer = ref->u.c.component->attr.pointer;
-		dimension = ref->u.c.component->attr.dimension;
+		if (ref->u.c.component->ts.type == BT_CLASS)
+		  {
+		    allocatable = ref->u.c.component->ts.u.derived->components->attr.allocatable;
+		    pointer = ref->u.c.component->ts.u.derived->components->attr.pointer;
+		    dimension = ref->u.c.component->ts.u.derived->components->attr.dimension;
+		  }
+		else
+		  {
+		    allocatable = ref->u.c.component->attr.allocatable;
+		    pointer = ref->u.c.component->attr.pointer;
+		    dimension = ref->u.c.component->attr.dimension;
+		  }
 		break;
 
 	      case REF_SUBSTRING:
@@ -5623,14 +5656,30 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
       return FAILURE;
     }
 
-  if (check_intent_in
-      && e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in && sym->attr.intent == INTENT_IN)
     {
       gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
-		 e->symtree->n.sym->name, &e->where);
+		 sym->name, &e->where);
       return FAILURE;
     }
 
+  if (e->ts.type == BT_CLASS)
+    {
+      /* Initialize VINDEX for CLASS objects.  */
+      int vindex = e->ts.u.derived->vindex;
+      init_st = gfc_get_code ();
+      init_st->loc = code->loc;
+      init_st->expr1 = expr_to_initialize (e);
+      init_st->op = EXEC_ASSIGN;
+      gfc_add_component_ref (init_st->expr1, "vindex");
+      init_st->expr2 = gfc_int_expr (vindex);
+      init_st->expr2->where = init_st->expr1->where = init_st->loc;
+      init_st->next = code->next;
+      code->next = init_st;
+      /* Only allocate the DATA component.  */
+      gfc_add_component_ref (e, "data");
+    }
+
   /* Add default initializer for those derived types that need them.  */
   if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
     {
@@ -7066,6 +7115,47 @@ resolve_ordinary_assign (gfc_code *code, gfc_names
   return false;
 }
 
+
+/* Check a pointer assignment to a CLASS object.  */
+
+static void
+check_class_pointer_assign (gfc_code **code)
+{
+  gfc_code *assign_code = gfc_get_code ();
+
+  /* Insert an additional assignment which sets the vindex.  */
+  assign_code->next = (*code)->next;
+  (*code)->next = assign_code;
+  assign_code->op = EXEC_ASSIGN;
+  assign_code->expr1 = gfc_copy_expr ((*code)->expr1);
+  gfc_add_component_ref (assign_code->expr1, "vindex");
+  if ((*code)->expr2->ts.type == BT_DERIVED)
+    {
+      /* vindex is constant, determined at compile time.  */
+      int vindex = (*code)->expr2->ts.u.derived->vindex;
+      assign_code->expr2 = gfc_int_expr (vindex);
+    }
+  else if ((*code)->expr2->ts.type == BT_CLASS)
+    {
+      /* vindex must be determined at run time.  */
+      assign_code->expr2 = gfc_copy_expr ((*code)->expr2);
+      gfc_add_component_ref (assign_code->expr2, "vindex");
+    }
+  else
+    gcc_unreachable ();
+
+  /* Modify the actual pointer assignment.  */
+  gfc_add_component_ref ((*code)->expr1, "data");
+  if ((*code)->expr2->ts.type == BT_CLASS)
+    gfc_add_component_ref ((*code)->expr2, "data");
+
+  gfc_check_pointer_assign ((*code)->expr1, (*code)->expr2);
+
+  if ((*code)->expr1->ts.type == BT_CLASS)
+    (*code) = (*code)->next;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -7216,7 +7306,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
-	  gfc_check_pointer_assign (code->expr1, code->expr2);
+	  if (code->expr1->ts.type == BT_CLASS)
+	    check_class_pointer_assign (&code);
+	  else
+	    gfc_check_pointer_assign (code->expr1, code->expr2);
+
 	  break;
 
 	case EXEC_ARITHMETIC_IF:
@@ -7983,8 +8077,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_f
     }
   else
     {
-      if (!mp_flag && !sym->attr.allocatable
-	  && !sym->attr.pointer && !sym->attr.dummy)
+      if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
+	  && !sym->attr.dummy && sym->ts.type != BT_CLASS)
 	{
 	  gfc_error ("Array '%s' at %L cannot have a deferred shape",
 		     sym->name, &sym->declared_at);
@@ -8010,7 +8104,7 @@ type_is_extensible (gfc_symbol *sym)
 static gfc_try
 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
 {
-  gcc_assert (sym->ts.type == BT_DERIVED);
+  gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
 
   /* Check to see if a derived type is blocked from being host
      associated by the presence of another class I symbol in the same
@@ -8052,10 +8146,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
       return FAILURE;
     }
 
-  if (sym->ts.is_class)
+  if (sym->ts.type == BT_CLASS)
     {
       /* C502.  */
-      if (!type_is_extensible (sym->ts.u.derived))
+      if (!type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
 	{
 	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
 		     sym->ts.u.derived->name, sym->name, &sym->declared_at);
@@ -8063,7 +8157,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
 	}
 
       /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
+	      || sym->ts.u.derived->components->attr.allocatable
+	      || sym->ts.u.derived->components->attr.pointer))
 	{
 	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
 		     "or pointer", sym->name, &sym->declared_at);
@@ -8204,7 +8300,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
     }
 
 no_init_error:
-  if (sym->ts.type == BT_DERIVED)
+  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
     return resolve_fl_variable_derived (sym, no_init_flag);
 
   return SUCCESS;
@@ -8850,6 +8946,9 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1,
   sym1 = t1->specific->u.specific->n.sym;
   sym2 = t2->specific->u.specific->n.sym;
 
+  if (sym1 == sym2)
+    return SUCCESS;
+
   /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
   if (sym1->attr.subroutine != sym2->attr.subroutine
       || sym1->attr.function != sym2->attr.function)
@@ -9243,21 +9342,22 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
       /* Now check that the argument-type matches.  */
       gcc_assert (me_arg);
-      if (me_arg->ts.type != BT_DERIVED
-	  || me_arg->ts.u.derived != resolve_bindings_derived)
+      if (me_arg->ts.type != BT_CLASS)
 	{
+	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+		     " at %L", proc->name, &where);
+	  goto error;
+	}
+
+      if (me_arg->ts.u.derived->components->ts.u.derived
+	  != resolve_bindings_derived)
+	{
 	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
 		     " the derived-type '%s'", me_arg->name, proc->name,
 		     me_arg->name, &where, resolve_bindings_derived->name);
 	  goto error;
 	}
 
-      if (!me_arg->ts.is_class)
-	{
-	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
-		     " at %L", proc->name, &where);
-	  goto error;
-	}
     }
 
   /* If we are extending some type, check that we don't override a procedure
@@ -9571,8 +9671,10 @@ resolve_fl_derived (gfc_symbol *sym)
 
 	  /* Now check that the argument-type matches.  */
 	  gcc_assert (me_arg);
-	  if (me_arg->ts.type != BT_DERIVED
-	      || me_arg->ts.u.derived != sym)
+	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
+	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+	      || (me_arg->ts.type == BT_CLASS
+		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
 	    {
 	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
 			 " the derived type '%s'", me_arg->name, c->name,
@@ -9609,9 +9711,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	      return FAILURE;
 	    }
 
-	  if (type_is_extensible (sym) && !me_arg->ts.is_class)
+	  if (type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
 	    gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
-			 " at %L", c->name, &c->loc);
+		       " at %L", c->name, &c->loc);
 
 	}
 
@@ -9680,8 +9782,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
 
       /* C437.  */
-      if (c->ts.type == BT_DERIVED && c->ts.is_class
-	  && !(c->attr.pointer || c->attr.allocatable))
+      if (c->ts.type == BT_CLASS
+	  && !(c->ts.u.derived->components->attr.pointer
+	       || c->ts.u.derived->components->attr.allocatable))
 	{
 	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
 		     "or pointer", c->name, &c->loc);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 151849)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -2405,6 +2405,7 @@ gfc_match_allocate (void)
   gfc_alloc *head, *tail;
   gfc_expr *stat, *errmsg, *tmp, *source;
   gfc_typespec ts;
+  gfc_symbol *sym;
   match m;
   locus old_locus;
   bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
@@ -2489,19 +2490,20 @@ gfc_match_allocate (void)
 	tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
 
       /* FIXME: disable the checking on derived types and arrays.  */
+      sym = tail->expr->symtree->n.sym;
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 		|| tail->expr->ref->type == REF_ARRAY));
-      b2 = tail->expr->symtree->n.sym
-	   && !(tail->expr->symtree->n.sym->attr.allocatable
-		|| tail->expr->symtree->n.sym->attr.pointer
-		|| tail->expr->symtree->n.sym->attr.proc_pointer);
-      b3 = tail->expr->symtree->n.sym
-	   && tail->expr->symtree->n.sym->ns
-	   && tail->expr->symtree->n.sym->ns->proc_name
-	   && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
-		|| tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
-		|| tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
+      if (sym && sym->ts.type == BT_CLASS)
+	b2 = !(sym->ts.u.derived->components->attr.allocatable
+	       || sym->ts.u.derived->components->attr.pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      b3 = sym && sym->ns && sym->ns->proc_name
+	   && (sym->ns->proc_name->attr.allocatable
+		|| sym->ns->proc_name->attr.pointer
+		|| sym->ns->proc_name->attr.proc_pointer);
       if (b1 && b2 && !b3)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
@@ -2730,8 +2732,9 @@ gfc_match_deallocate (void)
 {
   gfc_alloc *head, *tail;
   gfc_expr *stat, *errmsg, *tmp;
+  gfc_symbol *sym;
   match m;
-  bool saw_stat, saw_errmsg;
+  bool saw_stat, saw_errmsg, b1, b2;
 
   head = tail = NULL;
   stat = errmsg = tmp = NULL;
@@ -2759,20 +2762,25 @@ gfc_match_deallocate (void)
       if (gfc_check_do_variable (tail->expr->symtree))
 	goto cleanup;
 
-      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
+      sym = tail->expr->symtree->n.sym;
+
+      if (gfc_pure (NULL) && gfc_impure_variable (sym))
 	{
 	  gfc_error ("Illegal allocate-object at %C for a PURE procedure");
 	  goto cleanup;
 	}
 
       /* FIXME: disable the checking on derived types.  */
-      if (!(tail->expr->ref
+      b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
-	       || tail->expr->ref->type == REF_ARRAY)) 
-	  && tail->expr->symtree->n.sym
-	  && !(tail->expr->symtree->n.sym->attr.allocatable
-	       || tail->expr->symtree->n.sym->attr.pointer
-	       || tail->expr->symtree->n.sym->attr.proc_pointer))
+	       || tail->expr->ref->type == REF_ARRAY));
+      if (sym && sym->ts.type == BT_CLASS)
+	b2 = !(sym->ts.u.derived->components->attr.allocatable
+	       || sym->ts.u.derived->components->attr.pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      if (b1 && b2)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
 		     "or an allocatable variable");
@@ -2997,7 +3005,8 @@ gfc_match_call (void)
 
   /* If this is a variable of derived-type, it probably starts a type-bound
      procedure call.  */
-  if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
+  if (sym->attr.flavor != FL_PROCEDURE
+      && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
     return match_typebound_call (st);
 
   /* If it does not seem to be callable (include functions so that the
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(Revision 151849)
+++ gcc/fortran/check.c	(Arbeitskopie)
@@ -2135,9 +2135,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to
   if (variable_check (from, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (from, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (from, NULL);
   if (!attr.allocatable)
     {
@@ -2150,9 +2147,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to
   if (variable_check (to, 0) == FAILURE)
     return FAILURE;
 
-  if (array_check (to, 0) == FAILURE)
-    return FAILURE;
-
   attr = gfc_variable_attr (to, NULL);
   if (!attr.allocatable)
     {
@@ -2162,7 +2156,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to
       return FAILURE;
     }
 
-  if (same_type_check (from, 0, to, 1) == FAILURE)
+  if (same_type_check (to, 1, from, 0) == FAILURE)
     return FAILURE;
 
   if (to->rank != from->rank)
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 151849)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -1733,7 +1733,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
       || (sym->attr.dimension && !sym->attr.proc_pointer
 	  && !gfc_is_proc_ptr_comp (primary, NULL)
 	  && !(gfc_matching_procptr_assignment
-	       && sym->attr.flavor == FL_PROCEDURE)))
+	       && sym->attr.flavor == FL_PROCEDURE))
+      || (sym->ts.type == BT_CLASS
+	  && sym->ts.u.derived->components->attr.dimension))
     {
       /* In EQUIVALENCE, we don't know yet whether we are seeing
 	 an array, character variable or array of character
@@ -1767,7 +1769,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
-  if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
+  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+      || gfc_match_char ('%') != MATCH_YES)
     goto check_substring;
 
   sym = sym->ts.u.derived;
@@ -1866,7 +1869,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
 	    return m;
 	}
 
-      if (component->ts.type != BT_DERIVED
+      if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
 	  || gfc_match_char ('%') != MATCH_YES)
 	break;
 
@@ -1875,7 +1878,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
 
 check_substring:
   unknown = false;
-  if (primary->ts.type == BT_UNKNOWN)
+  if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
     {
       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
        {
@@ -1943,23 +1946,34 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
   int dimension, pointer, allocatable, target;
   symbol_attribute attr;
   gfc_ref *ref;
+  gfc_symbol *sym;
 
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
   ref = expr->ref;
-  attr = expr->symtree->n.sym->attr;
+  sym = expr->symtree->n.sym;
+  attr = sym->attr;
 
-  dimension = attr.dimension;
-  pointer = attr.pointer;
-  allocatable = attr.allocatable;
+  if (sym->ts.type == BT_CLASS)
+    {
+      dimension = sym->ts.u.derived->components->attr.dimension;
+      pointer = sym->ts.u.derived->components->attr.pointer;
+      allocatable = sym->ts.u.derived->components->attr.allocatable;
+    }
+  else
+    {
+      dimension = attr.dimension;
+      pointer = attr.pointer;
+      allocatable = attr.allocatable;
+    }
 
   target = attr.target;
   if (pointer || attr.proc_pointer)
     target = 1;
 
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
-    *ts = expr->symtree->n.sym->ts;
+    *ts = sym->ts;
 
   for (; ref; ref = ref->next)
     switch (ref->type)
@@ -1999,8 +2013,16 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
 		ts->u.cl = NULL;
 	  }
 
-	pointer = ref->u.c.component->attr.pointer;
-	allocatable = ref->u.c.component->attr.allocatable;
+	if (ref->u.c.component->ts.type == BT_CLASS)
+	  {
+	    pointer = ref->u.c.component->ts.u.derived->components->attr.pointer;
+	    allocatable = ref->u.c.component->ts.u.derived->components->attr.allocatable;
+	  }
+	else
+	  {
+	    pointer = ref->u.c.component->attr.pointer;
+	    allocatable = ref->u.c.component->attr.allocatable;
+	  }
 	if (pointer || attr.proc_pointer)
 	  target = 1;
 
Index: gcc/fortran/misc.c
===================================================================
--- gcc/fortran/misc.c	(Revision 151849)
+++ gcc/fortran/misc.c	(Arbeitskopie)
@@ -71,7 +71,6 @@ gfc_clear_ts (gfc_typespec *ts)
   ts->kind = 0;
   ts->u.cl = NULL;
   ts->interface = NULL;
-  ts->is_class = 0;
   /* flag that says if the type is C interoperable */
   ts->is_c_interop = 0;
   /* says what f90 type the C kind interops with */
@@ -131,6 +130,9 @@ gfc_basic_typename (bt type)
     case BT_DERIVED:
       p = "DERIVED";
       break;
+    case BT_CLASS:
+      p = "CLASS";
+      break;
     case BT_PROCEDURE:
       p = "PROCEDURE";
       break;
@@ -186,6 +188,10 @@ gfc_typename (gfc_typespec *ts)
     case BT_DERIVED:
       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
       break;
+    case BT_CLASS:
+      sprintf (buffer, "CLASS(%s)",
+	       ts->u.derived->components->ts.u.derived->name);
+      break;
     case BT_PROCEDURE:
       strcpy (buffer, "PROCEDURE");
       break;
Index: gcc/fortran/ChangeLog.fortran-dev
===================================================================
--- gcc/fortran/ChangeLog.fortran-dev	(Revision 0)
+++ gcc/fortran/ChangeLog.fortran-dev	(Revision 0)
@@ -0,0 +1,50 @@
+2009-09-20  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas <pault@gcc.gnu.org> 
+
+	* check.c (gfc_check_move_alloc): Arguments don't have to be arrays.
+	The second argument needs to be type-compatible with the first (not the
+	other way around, which makes a difference for CLASS entities).
+	* decl.c (encapsulate_class_symbol): New function.
+	(build_sym,build_struct): Handle BT_CLASS, call
+	'encapsulate_class_symbol'.
+	(gfc_match_decl_type_spec): Remove warning, use BT_CLASS.
+	(gfc_match_derived_decl): Set vindex;
+	* expr.c (gfc_add_component_ref): New function.
+	(gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol):
+	Handle BT_CLASS.
+	* dump-parse-tree.c (show_symbol): Print vindex.
+	* gfortran.h (bt): New basic type BT_CLASS.
+	(symbol_attribute): New field 'is_class'.
+	(gfc_typespec): Remove field 'is_class'.
+	(gfc_symbol): New field 'vindex'.
+	(gfc_get_ultimate_derived_super_type): New prototype.
+	(gfc_add_component_ref): Ditto.
+	* interface.c (gfc_compare_derived_types): Pointer equality check
+	moved here from gfc_compare_types.
+	(gfc_compare_types): Handle BT_CLASS and use
+	gfc_type_compatible.
+	* match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call):
+	Handle BT_CLASS.
+	* misc.c (gfc_clear_ts): Removed is_class.
+	(gfc_basic_typename,gfc_typename): Handle BT_CLASS.
+	* module.c (bt_types,mio_typespec): Handle BT_CLASS.
+	(mio_symbol): Handle vindex.
+	* primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS.
+	* resolve.c (find_array_spec,check_typebound_baseobject):
+	Handle BT_CLASS.
+	(resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp'
+	inside 'gcc_assert'.
+	(resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS.
+	(check_class_pointer_assign): New function.
+	(resolve_code): Handle BT_CLASS, call check_class_pointer_assign.
+	(resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived,
+	resolve_fl_variable): Handle BT_CLASS.
+	(check_generic_tbp_ambiguity): Add special case.
+	(resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS.
+	* symbol.c (gfc_get_ultimate_derived_super_type): New function.
+	(gfc_type_compatible): Handle BT_CLASS.
+	* trans-expr.c (conv_parent_component_references): Handle CLASS
+	containers.
+	(gfc_conv_initializer): Handle BT_CLASS.
+	* trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type):
+	Handle BT_CLASS.

Attachment: class_pointer_assign.f90
Description: Binary data


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]