}
+/* 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;
+ fclass->attr.abstract = ts->u.derived->attr.abstract;
+ 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);
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+
+ /* 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;
+ c->initializer = gfc_int_expr (0);
+ }
+
+ 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
sym->attr.implied_index = 0;
+ if (sym->ts.type == BT_CLASS)
+ encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+
return SUCCESS;
}
/* Check if the assignment can happen. This has to be put off
until later for a derived type variable. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
+ && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
}
}
+ if (c->ts.type == BT_CLASS)
+ encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
/* Check array components. */
if (!c->attr.dimension)
- {
- if (c->attr.allocatable)
- {
- gfc_error ("Allocatable component at %C must be an array");
- return FAILURE;
- }
- else
- return SUCCESS;
- }
+ return SUCCESS;
if (c->attr.pointer)
{
}
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. */
break;
case COMP_SELECT:
+ case COMP_SELECT_TYPE:
*st = ST_END_SELECT;
target = " select";
eos_ok = 0;
}
+/* Counter for assigning a unique vindex number to each derived type. */
+static int vindex_counter = 0;
+
+
/* Match the beginning of a derived type declaration. If a type name
was the result of a function, then it is possible to have a symbol
already to be known as a derived type yet have no components. */
st->n.sym = sym;
}
+ if (!sym->vindex)
+ /* Set the vindex for this type and increment the counter. */
+ sym->vindex = ++vindex_counter;
+
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;