Re: advice on creation of a derived TYPE

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

Iain,


> Would anyone recommend a place to look for an example ?so that I can
> determine how to build the derived type by hand?

Take a look at 'encapsulate_class_symbol' below.

Cheers

Paul

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 151449)
+++ gcc/fortran/decl.c	(working copy)
@@ -1025,6 +1025,70 @@
 }


+/* Build a class entity, using the symbol that comes from build_sym. */
+
+static gfc_try
+encapsulate_class_symbol (gfc_symbol *sym)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 5];
+  gfc_symbol *fclass;
+  gfc_component *c;
+
+  if (sym->as && sym->as->rank
+	&& (sym->attr.allocatable || sym->attr.pointer))
+    sprintf (name, ".class.%s.%d.%s", sym->ts.u.derived->name,
+	     sym->as->rank, sym->attr.allocatable ? "a" : "p");
+  else if (sym->as && sym->as->rank)
+    sprintf (name, ".class.%s.%d", sym->ts.u.derived->name,
+	     sym->as->rank);
+  else if (sym->attr.allocatable || sym->attr.pointer)
+    sprintf (name, ".class.%s.%s", sym->ts.u.derived->name,
+	     sym->attr.allocatable ? "a" : "p");
+  else
+    sprintf (name, ".class.%s", sym->ts.u.derived->name);
+
+  gfc_find_symbol (name, sym->ts.u.derived->ns, 0, &fclass);
+  if (fclass == NULL)
+    {
+      gfc_symtree *st;
+      /* If not there, create a new symbol.  */
+      fclass = gfc_new_symbol (name, sym->ts.u.derived->ns);
+      st = gfc_new_symtree (&sym->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 = sym->ts.u.derived->vindex;
+      fclass->f2k_derived = sym->ts.u.derived->f2k_derived;
+      fclass->f2k_derived->refs++;
+
+      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+	  NULL, &sym->declared_at) == FAILURE)
+	return FAILURE;
+
+      if (gfc_add_component (fclass, "data", &c) == FAILURE)
+   	return FAILURE;
+
+      c->ts = sym->ts;
+      c->ts.is_class = 0;
+      c->ts.u.derived = sym->ts.u.derived;
+      c->as = sym->as;
+      c->attr.pointer = sym->attr.pointer;
+      c->attr.allocatable = sym->attr.allocatable;
+
+      if (gfc_add_component (fclass, "vindex", &c) == FAILURE)
+   	return FAILURE;
+
+      c->ts.type = BT_INTEGER;
+      c->ts.kind = 4;
+    }
+  fclass->attr.extension = 1;
+  sym->ts.u.derived = fclass;
+  sym->attr.allocatable = sym->attr.pointer = 0;
+
+  return SUCCESS;
+}
+
 /* Function called by variable_decl() that adds a name to the symbol table.  */

 static gfc_try
@@ -1097,6 +1161,9 @@

   sym->attr.implied_index = 0;

+  if (sym->ts.is_class)
+    encapsulate_class_symbol (sym);
+
   return SUCCESS;
 }

@@ -6764,6 +6831,7 @@
     {
       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);
@@ -6780,6 +6848,14 @@
 	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 151449)
+++ gcc/fortran/dump-parse-tree.c	(working copy)
@@ -825,7 +825,12 @@
     }

   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/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 151449)
+++ gcc/fortran/expr.c	(working copy)
@@ -3124,7 +3124,9 @@
       return FAILURE;
     }

-  if (!pointer && !proc_pointer)
+  if (!pointer && !proc_pointer
+	&& !(lvalue->ts.is_class
+		&& lvalue->ts.u.derived->components->attr.pointer))
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3244,7 +3246,8 @@
       return SUCCESS;
     }

-  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
+  if (!lvalue->ts.is_class && !lvalue->symtree->n.sym->ts.is_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 +3255,7 @@
       return FAILURE;
     }

-  if (lvalue->ts.kind != rvalue->ts.kind)
+  if (!lvalue->ts.is_class && lvalue->ts.kind != rvalue->ts.kind)
     {
       gfc_error ("Different kind type parameters in pointer "
 		 "assignment at %L", &lvalue->where);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 151449)
+++ gcc/fortran/module.c	(working copy)
@@ -2050,6 +2050,7 @@
 static void
 mio_typespec (gfc_typespec *ts)
 {
+  int is_class;
   mio_lparen ();

   ts->type = MIO_NAME (bt) (ts->type, bt_types);
@@ -2059,6 +2060,12 @@
   else
     mio_symbol_ref (&ts->u.derived);

+  /* Variable is a CLASS.  */
+  is_class = ts->is_class ? 1 : 0;
+  mio_integer (&is_class);
+  if (iomode == IO_OUTPUT)
+    ts->is_class = is_class ? 1 : 0;
+
   /* Add info for C interop and is_iso_c.  */
   mio_integer (&ts->is_c_interop);
   mio_integer (&ts->is_iso_c);
@@ -3504,10 +3511,11 @@
 mio_symbol (gfc_symbol *sym)
 {
   int intmod = INTMOD_NONE;
-
+
   mio_lparen ();
+
+  mio_symbol_attribute (&sym->attr);

-  mio_symbol_attribute (&sym->attr);
   mio_typespec (&sym->ts);

   if (iomode == IO_OUTPUT)
@@ -3566,7 +3574,10 @@
     }

   mio_integer (&(sym->intmod_sym_id));
-
+
+  if (sym->attr.flavor == FL_DERIVED)
+    mio_integer (&(sym->vindex));
+
   mio_rparen ();
 }

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 151449)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8056,7 +8056,9 @@
 	}

       /* 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);
@@ -8843,6 +8845,9 @@
   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)
@@ -9237,7 +9242,11 @@
       /* 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)
+	  || (me_arg->ts.u.derived != resolve_bindings_derived
+			&&
+	     (resolve_bindings_derived->ts.is_class
+		&& me_arg->ts.u.derived
+		     != resolve_bindings_derived->components->ts.u.derived)))
 	{
 	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
 		     " the derived-type '%s'", me_arg->name, proc->name,
@@ -9565,7 +9574,10 @@
 	  /* Now check that the argument-type matches.  */
 	  gcc_assert (me_arg);
 	  if (me_arg->ts.type != BT_DERIVED
-	      || me_arg->ts.u.derived != sym)
+	      || (me_arg->ts.u.derived != sym
+			&&
+		 (sym->ts.is_class
+		    && me_arg->ts.u.derived != sym->components->ts.u.derived)))
 	    {
 	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
 			 " the derived type '%s'", me_arg->name, c->name,
@@ -10186,8 +10198,9 @@
      the type is not declared in the scope of the implicit
      statement. Change the type to BT_UNKNOWN, both because it is so
      and to prevent an ICE.  */
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
-      && !sym->ts.u.derived->attr.zero_comp)
+  if (sym->ts.type == BT_DERIVED
+	&& sym->ts.u.derived->components == NULL
+        && !sym->ts.u.derived->attr.zero_comp)
     {
       gfc_error ("The derived type '%s' at %L is of type '%s', "
 		 "which has not been defined", sym->name,
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 151449)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4534,6 +4534,23 @@
 }


+/* 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.  */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 151449)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1131,6 +1131,11 @@
   /* 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 +1146,6 @@
      order.  */
   int dummy_order;

-  int entry_id;
-
   gfc_namelist *namelist, *namelist_tail;

   /* Change management fields.  Symbols that might be modified by the
@@ -2469,6 +2472,7 @@

 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*);