+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42053
+ * resolve.c (resolve_select_type): Check for duplicate CLASS IS blocks.
+
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41631
+ * decl.c (gfc_match_derived_decl): Set extension level.
+ * gfortran.h (symbol_attribute): Expand 'extension' bit field to 8 bit.
+ * iresolve.c (gfc_resolve_extends_type_of): Return value of
+ 'is_extension_of' has kind=4.
+ * match.c (select_type_set_tmp,gfc_match_class_is): Create temporary
+ for CLASS IS blocks.
+ * module.c (MOD_VERSION): Bump module version.
+ (ab_attribute,attr_bits): Remove AB_EXTENSION.
+ (mio_symbol_attribute): Handle expanded 'extension' field.
+ * resolve.c (resolve_select_type): Implement CLASS IS blocks.
+ (resolve_fl_variable_derived): Show correct type name.
+ * symbol.c (gfc_build_class_symbol): Set extension level.
+
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ * intrinsic.h (gfc_resolve_extends_type_of): Add prototype.
+ * intrinsic.c (add_functions): Use 'gfc_resolve_extends_type_of'.
+ * iresolve.c (gfc_resolve_extends_type_of): New function, which
+ replaces the call to EXTENDS_TYPE_OF by the library function
+ 'is_extension_of' and modifies the arguments.
+ * trans-intrinsic.c (gfc_conv_extends_type_of): Removed.
+ (gfc_conv_intrinsic_function): FOR EXTENDS_TYPE_OF, don't call
+ gfc_conv_extends_type_of but gfc_conv_intrinsic_funcall.
+
+2009-11-30 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ * decl.c (encapsulate_class_symbol): Replaced by
+ 'gfc_build_class_symbol'.
+ (build_sym,build_struct): Call 'gfc_build_class_symbol'.
+ (gfc_match_derived_decl): Replace vindex by hash_value.
+ * dump-parse-tree.c (show_symbol): Replace vindex by hash_value.
+ * gfortran.h (symbol_attribute): Add field 'vtab'.
+ (gfc_symbol): Replace vindex by hash_value.
+ (gfc_class_esym_list): Ditto.
+ (gfc_get_derived_type,gfc_build_class_symbol,gfc_find_derived_vtab):
+ New prototypes.
+ * module.c (mio_symbol): Replace vindex by hash_value.
+ * resolve.c (vindex_expr): Rename to 'hash_value_expr'.
+ (resolve_class_compcall,resolve_class_typebound_call): Renamed
+ 'vindex_expr'.
+ (resolve_select_type): Replace $vindex by $vptr->$hash.
+ * symbol.c (gfc_add_save): Handle vtab symbols.
+ (gfc_type_compatible): Rewrite.
+ (gfc_build_class_symbol): New function which replaces
+ 'encapsulate_class_symbol'.
+ (gfc_find_derived_vtab): New function to set up a vtab symbol for a
+ derived type.
+ * trans-decl.c (gfc_create_module_variable): Handle vtab symbols.
+ * trans-expr.c (select_class_proc): Replace vindex by hash_value.
+ (gfc_conv_derived_to_class): New function to construct a temporary
+ CLASS variable from a derived type expression.
+ (gfc_conv_procedure_call): Call 'gfc_conv_derived_to_class'.
+ (gfc_conv_structure): Initialize the $extends and $size fields of
+ vtab symbols.
+ (gfc_trans_class_assign): Replace $vindex by $vptr. Remove the $size
+ assignment.
+ * trans-intrinsic.c (gfc_conv_same_type_as): Replace $vindex by
+ $vptr->$hash, and replace vindex by hash_value.
+ * trans-stmt.c (gfc_trans_allocate): Insert $vptr references, replace
+ $vindex by $vptr. Remove the $size assignment.
+ * trans-types.c (gfc_get_derived_type): Make it non-static.
+
2009-11-30 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/42131
}
-/* 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, and another integer '$size', which
- contains the size of the dynamic type structure. */
-
-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->attr.abstract = ts->u.derived->attr.abstract;
- 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);
-
- /* Add component '$size'. */
- if (gfc_add_component (fclass, "$size", &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. */
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
- encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
return SUCCESS;
scalar:
if (c->ts.type == BT_CLASS)
- encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+ gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
- sym->attr.extension = attr.extension;
extended->refs++;
gfc_set_sym_referenced (extended);
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
+
+ /* Set extension level. */
+ if (extended->attr.extension == 255)
+ {
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ extended->name, &extended->declared_at);
+ return MATCH_ERROR;
+ }
+ sym->attr.extension = extended->attr.extension + 1;
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
st->n.sym = sym;
}
- if (!sym->vindex)
- /* Set the vindex for this type. */
- sym->vindex = hash_value (sym);
+ if (!sym->hash_value)
+ /* Set the hash for the compound name for this type. */
+ sym->hash_value = hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;
if (sym->f2k_derived)
{
show_indent ();
- if (sym->vindex)
- fprintf (dumpfile, "vindex: %d", sym->vindex);
+ if (sym->hash_value)
+ fprintf (dumpfile, "hash: %d", sym->hash_value);
show_f2k_derived (sym->f2k_derived);
}
unsigned untyped:1; /* No implicit type could be found. */
unsigned is_bind_c:1; /* say if is bound to C. */
- unsigned extension:1; /* extends a derived type. */
+ unsigned extension:8; /* extension level of a derived type. */
unsigned is_class:1; /* is a CLASS container. */
unsigned class_ok:1; /* is a CLASS object with correct attributes. */
+ unsigned vtab:1; /* is a derived type vtab. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
int entry_id; /* Used in resolve.c for entries. */
- /* CLASS vindex for declared and dynamic types in the class. */
- int vindex;
+ /* CLASS hashed name for declared and dynamic types in the class. */
+ int hash_value;
struct gfc_symbol *common_next; /* Links for COMMON syms */
{
gfc_symbol *derived;
gfc_symbol *esym;
- struct gfc_expr *vindex;
+ struct gfc_expr *hash_value;
struct gfc_class_esym_list *next;
}
gfc_class_esym_list;
int gfc_validate_kind (bt, int, bool);
int gfc_get_int_kind_from_width_isofortranenv (int size);
int gfc_get_real_kind_from_width_isofortranenv (int size);
+tree gfc_get_derived_type (gfc_symbol * derived);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
extern int gfc_max_integer_kind;
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
+gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+ gfc_array_spec **);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
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*);
add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
- gfc_check_same_type_as, NULL, NULL,
+ gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
void gfc_resolve_etime_sub (gfc_code *);
void gfc_resolve_exp (gfc_expr *, gfc_expr *);
void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
+void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fdate (gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
}
+/* Resolve the EXTENDS_TYPE_OF intrinsic function. */
+
+void
+gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
+{
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+
+ /* Prevent double resolution. */
+ if (f->ts.type == BT_LOGICAL)
+ return;
+
+ /* Replace the first argument with the corresponding vtab. */
+ if (a->ts.type == BT_CLASS)
+ gfc_add_component_ref (a, "$vptr");
+ else if (a->ts.type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (a->ts.u.derived);
+ /* Clear the old expr. */
+ gfc_free_ref_list (a->ref);
+ memset (a, '\0', sizeof (gfc_expr));
+ /* Construct a new one. */
+ a->expr_type = EXPR_VARIABLE;
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ a->symtree = st;
+ a->ts = vtab->ts;
+ }
+
+ /* Replace the second argument with the corresponding vtab. */
+ if (mo->ts.type == BT_CLASS)
+ gfc_add_component_ref (mo, "$vptr");
+ else if (mo->ts.type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+ /* Clear the old expr. */
+ gfc_free_ref_list (mo->ref);
+ memset (mo, '\0', sizeof (gfc_expr));
+ /* Construct a new one. */
+ mo->expr_type = EXPR_VARIABLE;
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ mo->symtree = st;
+ mo->ts = vtab->ts;
+ }
+
+ f->ts.type = BT_LOGICAL;
+ f->ts.kind = 4;
+ /* Call library function. */
+ f->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+}
+
+
void
gfc_resolve_fdate (gfc_expr *f)
{
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
+
+ if (!gfc_type_is_extensible (ts->u.derived))
+ return;
- sprintf (name, "tmp$%s", ts->u.derived->name);
+ if (ts->type == BT_CLASS)
+ sprintf (name, "tmp$class$%s", ts->u.derived->name);
+ else
+ sprintf (name, "tmp$type$%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_pointer (&tmp->n.sym->attr, NULL);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ if (ts->type == BT_CLASS)
+ {
+ gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+ &tmp->n.sym->as);
+ tmp->n.sym->attr.class_ok = 1;
+ }
select_type_stack->tmp = tmp;
}
new_st.op = EXEC_SELECT_TYPE;
new_st.ext.case_list = c;
-
- gfc_error_now ("CLASS IS specification at %C is not yet supported");
+
+ /* Create temporary variable. */
+ select_type_set_tmp (&c->ts);
return MATCH_YES;
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "3"
+#define MOD_VERSION "4"
/* Structure that describes a position within a module file. */
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
- AB_EXTENSION, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
+ AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER
}
ab_attribute;
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
- minit ("EXTENSION", AB_EXTENSION),
minit ("IS_CLASS", AB_IS_CLASS),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
mio_symbol_attribute (symbol_attribute *attr)
{
atom_type t;
- unsigned ext_attr;
+ unsigned ext_attr,extension_level;
mio_lparen ();
attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
attr->save = MIO_NAME (save_state) (attr->save, save_status);
+
ext_attr = attr->ext_attr;
mio_integer ((int *) &ext_attr);
attr->ext_attr = ext_attr;
+ extension_level = attr->extension;
+ mio_integer ((int *) &extension_level);
+ attr->extension = extension_level;
+
if (iomode == IO_OUTPUT)
{
if (attr->allocatable)
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
- if (attr->extension)
- MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
if (attr->is_class)
MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
if (attr->procedure)
case AB_ZERO_COMP:
attr->zero_comp = 1;
break;
- case AB_EXTENSION:
- attr->extension = 1;
- break;
case AB_IS_CLASS:
attr->is_class = 1;
break;
mio_integer (&(sym->intmod_sym_id));
if (sym->attr.flavor == FL_DERIVED)
- mio_integer (&(sym->vindex));
+ mio_integer (&(sym->hash_value));
mio_rparen ();
}
}
-/* Generate an expression for the vindex, given the reference to
+/* Generate an expression for the hash value, given the reference to
the class of the final expression (class_ref), the base of the
full reference list (new_ref), the declared type and the class
object (st). */
static gfc_expr*
-vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
- gfc_symbol *declared, gfc_symtree *st)
+hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
{
- gfc_expr *vindex;
- gfc_ref *ref;
+ gfc_expr *hash_value;
- /* Build an expression for the correct vindex; ie. that of the last
+ /* Build an expression for the correct hash_value; ie. that of the last
CLASS reference. */
- ref = gfc_get_ref();
- ref->type = REF_COMPONENT;
- ref->u.c.component = declared->components->next;
- ref->u.c.sym = declared;
- ref->next = NULL;
if (class_ref)
{
- class_ref->next = ref;
+ class_ref->next = NULL;
}
else
{
gfc_free_ref_list (new_ref);
- new_ref = ref;
+ new_ref = NULL;
}
- vindex = gfc_get_expr ();
- vindex->expr_type = EXPR_VARIABLE;
- vindex->symtree = st;
- vindex->symtree->n.sym->refs++;
- vindex->ts = ref->u.c.component->ts;
- vindex->ref = new_ref;
+ hash_value = gfc_get_expr ();
+ hash_value->expr_type = EXPR_VARIABLE;
+ hash_value->symtree = st;
+ hash_value->symtree->n.sym->refs++;
+ hash_value->ref = new_ref;
+ gfc_add_component_ref (hash_value, "$vptr");
+ gfc_add_component_ref (hash_value, "$hash");
- return vindex;
+ return hash_value;
}
resolve_class_esym (e);
/* More than one typebound procedure so transmit an expression for
- the vindex as the selector. */
+ the hash_value as the selector. */
if (e->value.function.class_esym != NULL)
- e->value.function.class_esym->vindex
- = vindex_expr (class_ref, new_ref, declared, st);
+ e->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
return class_try;
}
resolve_class_esym (code->expr1);
/* More than one typebound procedure so transmit an expression for
- the vindex as the selector. */
+ the hash_value as the selector. */
if (code->expr1->value.function.class_esym != NULL)
- code->expr1->value.function.class_esym->vindex
- = vindex_expr (class_ref, new_ref, declared, st);
+ code->expr1->value.function.class_esym->hash_value
+ = hash_value_expr (class_ref, new_ref, st);
return class_try;
}
resolve_select_type (gfc_code *code)
{
gfc_symbol *selector_type;
- gfc_code *body, *new_st;
- gfc_case *c, *default_case;
+ gfc_code *body, *new_st, *if_st, *tail;
+ gfc_code *class_is = NULL, *default_case = NULL;
+ gfc_case *c;
gfc_symtree *st;
char name[GFC_MAX_SYMBOL_LEN];
gfc_namespace *ns;
+ int error = 0;
ns = code->ext.ns;
gfc_resolve (ns);
else
selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
- /* Assume there is no DEFAULT case. */
- default_case = NULL;
-
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
{
gfc_error ("Derived type '%s' at %L must be extensible",
c->ts.u.derived->name, &c->where);
+ error++;
continue;
}
{
gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
c->ts.u.derived->name, &c->where, selector_type->name);
+ error++;
continue;
}
if (c->ts.type == BT_UNKNOWN)
{
/* Check F03:C818. */
- if (default_case != NULL)
- gfc_error ("The DEFAULT CASE at %L cannot be followed "
- "by a second DEFAULT CASE at %L",
- &default_case->where, &c->where);
+ if (default_case)
+ {
+ gfc_error ("The DEFAULT CASE at %L cannot be followed "
+ "by a second DEFAULT CASE at %L",
+ &default_case->ext.case_list->where, &c->where);
+ error++;
+ continue;
+ }
else
- default_case = c;
- continue;
+ default_case = body;
}
}
+
+ if (error>0)
+ return;
if (code->expr2)
{
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
- gfc_add_component_ref (code->expr1, "$vindex");
+ gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_component_ref (code->expr1, "$hash");
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
c = body->ext.case_list;
+
if (c->ts.type == BT_DERIVED)
- c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
- else if (c->ts.type == BT_CLASS)
- /* Currently IS CLASS blocks are simply ignored.
- TODO: Implement IS CLASS. */
- c->unreachable = 1;
-
- if (c->ts.type != BT_DERIVED)
+ c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+ else if (c->ts.type == BT_UNKNOWN)
continue;
+
/* Assign temporary to selector. */
- sprintf (name, "tmp$%s", c->ts.u.derived->name);
+ if (c->ts.type == BT_CLASS)
+ sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ else
+ sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
new_st = gfc_get_code ();
- new_st->op = EXEC_POINTER_ASSIGN;
new_st->expr1 = gfc_get_variable_expr (st);
new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
- gfc_add_component_ref (new_st->expr2, "$data");
+ if (c->ts.type == BT_DERIVED)
+ {
+ new_st->op = EXEC_POINTER_ASSIGN;
+ gfc_add_component_ref (new_st->expr2, "$data");
+ }
+ else
+ new_st->op = EXEC_POINTER_ASSIGN;
new_st->next = body->next;
body->next = new_st;
}
+
+ /* Take out CLASS IS cases for separate treatment. */
+ body = code;
+ while (body && body->block)
+ {
+ if (body->block->ext.case_list->ts.type == BT_CLASS)
+ {
+ /* Add to class_is list. */
+ if (class_is == NULL)
+ {
+ class_is = body->block;
+ tail = class_is;
+ }
+ else
+ {
+ for (tail = class_is; tail->block; tail = tail->block) ;
+ tail->block = body->block;
+ tail = tail->block;
+ }
+ /* Remove from EXEC_SELECT list. */
+ body->block = body->block->block;
+ tail->block = NULL;
+ }
+ else
+ body = body->block;
+ }
- /* Eliminate dead blocks. */
- for (body = code; body && body->block; body = body->block)
+ if (class_is)
{
- if (body->block->ext.case_list->unreachable)
+ gfc_symbol *vtab;
+
+ if (!default_case)
+ {
+ /* Add a default case to hold the CLASS IS cases. */
+ for (tail = code; tail->block; tail = tail->block) ;
+ tail->block = gfc_get_code ();
+ tail = tail->block;
+ tail->op = EXEC_SELECT_TYPE;
+ tail->ext.case_list = gfc_get_case ();
+ tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->next = NULL;
+ default_case = tail;
+ }
+
+ /* More than one CLASS IS block? */
+ if (class_is->block)
{
- /* Cut the unreachable block from the code chain. */
- gfc_code *cd = body->block;
- body->block = cd->block;
- /* Kill the dead block, but not the blocks below it. */
- cd->block = NULL;
- gfc_free_statements (cd);
+ gfc_code **c1,*c2;
+ bool swapped;
+ /* Sort CLASS IS blocks by extension level. */
+ do
+ {
+ swapped = false;
+ for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block))
+ {
+ c2 = (*c1)->block;
+ /* F03:C817 (check for doubles). */
+ if ((*c1)->ext.case_list->ts.u.derived->hash_value
+ == c2->ext.case_list->ts.u.derived->hash_value)
+ {
+ gfc_error ("Double CLASS IS block in SELECT TYPE "
+ "statement at %L", &c2->ext.case_list->where);
+ return;
+ }
+ if ((*c1)->ext.case_list->ts.u.derived->attr.extension
+ < c2->ext.case_list->ts.u.derived->attr.extension)
+ {
+ /* Swap. */
+ (*c1)->block = c2->block;
+ c2->block = *c1;
+ *c1 = c2;
+ swapped = true;
+ }
+ }
+ }
+ while (swapped);
}
+
+ /* Generate IF chain. */
+ if_st = gfc_get_code ();
+ if_st->op = EXEC_IF;
+ new_st = if_st;
+ for (body = class_is; body; body = body->block)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ /* Set up IF condition: Call _gfortran_is_extension_of. */
+ new_st->expr1 = gfc_get_expr ();
+ new_st->expr1->expr_type = EXPR_FUNCTION;
+ new_st->expr1->ts.type = BT_LOGICAL;
+ new_st->expr1->ts.kind = 4;
+ new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of"));
+ new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym);
+ new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF;
+ /* Set up arguments. */
+ new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
+ gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
+ new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
+ new_st->next = body->next;
+ }
+ if (default_case->next)
+ {
+ new_st->block = gfc_get_code ();
+ new_st = new_st->block;
+ new_st->op = EXEC_IF;
+ new_st->next = default_case->next;
+ }
+
+ /* Replace CLASS DEFAULT code by the IF chain. */
+ default_case->next = if_st;
}
resolve_select (code);
if (!gfc_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);
+ sym->ts.u.derived->components->ts.u.derived->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
return FAILURE;
}
- if (attr->save == SAVE_EXPLICIT)
+ if (attr->save == SAVE_EXPLICIT && !attr->vtab)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
bool
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
{
- if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
- && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
+ gfc_component *cmp1, *cmp2;
+
+ bool is_class1 = (ts1->type == BT_CLASS);
+ bool is_class2 = (ts2->type == BT_CLASS);
+ bool is_derived1 = (ts1->type == BT_DERIVED);
+ bool is_derived2 = (ts2->type == BT_DERIVED);
+
+ if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+ return (ts1->type == ts2->type);
+
+ if (is_derived1 && is_derived2)
+ return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+ cmp1 = cmp2 = NULL;
+
+ if (is_class1)
{
- if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
- ts2->u.derived);
- else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
- ts2->u.derived->components->ts.u.derived);
- else if (ts2->type != BT_CLASS)
- return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
- else
+ cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
+ if (cmp1 == NULL)
return 0;
}
+
+ if (is_class2)
+ {
+ cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
+ if (cmp2 == NULL)
+ return 0;
+ }
+
+ if (is_class1 && is_derived2)
+ return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
+
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
+
else
- return (ts1->type == ts2->type);
+ return 0;
+}
+
+
+/* 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 a pointer
+ component '$vptr' which determines the dynamic type. */
+
+gfc_try
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+ gfc_array_spec **as)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 5];
+ gfc_symbol *fclass;
+ gfc_symbol *vtab;
+ 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->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->attr.abstract = ts->u.derived->attr.abstract;
+ c->as = (*as);
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+
+ /* Add component '$vptr'. */
+ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+ return FAILURE;
+ c->ts.type = BT_DERIVED;
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ c->ts.u.derived = vtab->ts.u.derived;
+ c->attr.pointer = 1;
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+ }
+
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ if (ts->u.derived->attr.extension == 255)
+ {
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ ts->u.derived->name, &ts->u.derived->declared_at);
+ return FAILURE;
+ }
+
+ fclass->attr.extension = ts->u.derived->attr.extension + 1;
+ fclass->attr.is_class = 1;
+ ts->u.derived = fclass;
+ attr->allocatable = attr->pointer = attr->dimension = 0;
+ (*as) = NULL; /* XXX */
+ return SUCCESS;
+}
+
+
+/* Find the symbol for a derived type's vtab. */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+ gfc_namespace *ns;
+ gfc_symbol *vtab = NULL, *vtype = NULL;
+ char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+
+ ns = gfc_current_ns;
+
+ for (; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+
+ if (ns)
+ {
+ sprintf (name, "vtab$%s", derived->name);
+ gfc_find_symbol (name, ns, 0, &vtab);
+
+ if (vtab == NULL)
+ {
+ gfc_get_symbol (name, ns, &vtab);
+ vtab->ts.type = BT_DERIVED;
+ vtab->attr.flavor = FL_VARIABLE;
+ vtab->attr.target = 1;
+ vtab->attr.save = SAVE_EXPLICIT;
+ vtab->attr.vtab = 1;
+ vtab->refs++;
+ gfc_set_sym_referenced (vtab);
+ sprintf (name, "vtype$%s", derived->name);
+
+ gfc_find_symbol (name, ns, 0, &vtype);
+ if (vtype == NULL)
+ {
+ gfc_component *c;
+ gfc_symbol *parent = NULL, *parent_vtab = NULL;
+
+ gfc_get_symbol (name, ns, &vtype);
+ if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return NULL;
+ vtype->refs++;
+ gfc_set_sym_referenced (vtype);
+
+ /* Add component '$hash'. */
+ if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_int_expr (derived->hash_value);
+
+ /* Add component '$size'. */
+ if (gfc_add_component (vtype, "$size", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ /* Remember the derived type in ts.u.derived,
+ so that the correct initializer can be set later on
+ (in gfc_conv_structure). */
+ c->ts.u.derived = derived;
+ c->initializer = gfc_int_expr (0);
+
+ /* Add component $extends. */
+ if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+ return NULL;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_get_expr ();
+ parent = gfc_get_derived_super_type (derived);
+ if (parent)
+ {
+ parent_vtab = gfc_find_derived_vtab (parent);
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = parent_vtab->ts.u.derived;
+ c->initializer->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
+ &c->initializer->symtree);
+ }
+ else
+ {
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = vtype;
+ c->initializer->expr_type = EXPR_NULL;
+ }
+ }
+ vtab->ts.u.derived = vtype;
+
+ vtab->value = gfc_default_initializer (&vtab->ts);
+ }
+ }
+
+ return vtab;
}
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
- if (sym->backend_decl)
+ if (sym->backend_decl && !sym->attr.vtab)
internal_error ("backend decl for module variable %s already exists",
sym->name);
tree end_label;
tree label;
tree tmp;
- tree vindex;
+ tree hash;
stmtblock_t body;
gfc_class_esym_list *next_elist, *tmp_elist;
gfc_se tmpse;
- /* Convert the vindex expression. */
+ /* Convert the hash expression. */
gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, elist->vindex);
+ gfc_conv_expr (&tmpse, elist->hash_value);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
- vindex = gfc_evaluate_now (tmpse.expr, &se->pre);
+ hash = gfc_evaluate_now (tmpse.expr, &se->pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
/* Fix the function type to be that of the declared type method. */
if (elist->esym != tmp_elist->esym)
continue;
- cval = build_int_cst (TREE_TYPE (vindex),
- elist->derived->vindex);
- /* Build a label for the vindex value. */
+ cval = build_int_cst (TREE_TYPE (hash),
+ elist->derived->hash_value);
+ /* Build a label for the hash value. */
label = gfc_build_label_decl (NULL_TREE);
tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
cval, NULL_TREE, label);
segfaults because it occurs too early and too often. */
free_elist:
next_elist = elist->next;
- if (elist->vindex)
- gfc_free_expr (elist->vindex);
+ if (elist->hash_value)
+ gfc_free_expr (elist->hash_value);
gfc_free (elist);
elist = NULL;
}
NULL_TREE, NULL_TREE, label);
gfc_add_expr_to_block (&body, tmp);
tmp = gfc_trans_runtime_error (true, &expr->where,
- "internal error: bad vindex in dynamic dispatch");
+ "internal error: bad hash value in dynamic dispatch");
gfc_add_expr_to_block (&body, tmp);
/* Write the switch expression. */
tmp = gfc_finish_block (&body);
- tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
+ tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
}
+/* Takes a derived type expression and returns the address of a temporary
+ class object of the 'declared' type. */
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts)
+{
+ gfc_component *cmp;
+ gfc_symbol *vtab;
+ gfc_symbol *declared = class_ts.u.derived;
+ gfc_ss *ss;
+ tree ctree;
+ tree var;
+ tree tmp;
+
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ tmp = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (tmp, "class");
+
+ /* Set the vptr. */
+ cmp = gfc_find_component (declared, "$vptr", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+
+ /* Remember the vtab corresponds to the derived type
+ not to the class declared type. */
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Now set the data field. */
+ cmp = gfc_find_component (declared, "$data", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+ ss = gfc_walk_expr (e);
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ gfc_conv_expr (parmse, e);
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ }
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
else if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_DERIVED)
{
- tree data;
- tree vindex;
- tree size;
-
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
- type = gfc_typenode_for_spec (&fsym->ts);
- var = gfc_create_var (type, "class");
-
- /* Get the components. */
- tmp = fsym->ts.u.derived->components->backend_decl;
- data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->backend_decl;
- vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
- tmp = fsym->ts.u.derived->components->next->next->backend_decl;
- size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
- var, tmp, NULL_TREE);
-
- /* Set the vindex. */
- tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
- gfc_add_modify (&parmse.pre, vindex, tmp);
-
- /* Set the size. */
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
- gfc_add_modify (&parmse.pre, size,
- fold_convert (TREE_TYPE (size), tmp));
-
- /* Now set the data field. */
- argss = gfc_walk_expr (e);
- if (argss == gfc_ss_terminator)
- {
- gfc_conv_expr_reference (&parmse, e);
- tmp = fold_convert (TREE_TYPE (data),
- parmse.expr);
- gfc_add_modify (&parmse.pre, data, tmp);
- }
- else
- {
- gfc_conv_expr (&parmse, e);
- gfc_add_modify (&parmse.pre, data, parmse.expr);
- }
-
- /* Pass the address of the class object. */
- parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
else if (se->ss && se->ss->useflags)
{
if (cm->ts.type == BT_CLASS)
{
+ gfc_component *data;
+ data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->ts.u.derived->components->backend_decl),
- cm->ts.u.derived->components->attr.dimension,
- cm->ts.u.derived->components->attr.pointer);
+ TREE_TYPE (data->backend_decl),
+ data->attr.dimension,
+ data->attr.pointer);
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
- val);
+ CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+ }
+ else if (strcmp (cm->name, "$size") == 0)
+ {
+ val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
+ else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+ && strcmp (cm->name, "$extends") == 0)
+ {
+ gfc_symbol *vtabs;
+ vtabs = cm->initializer->symtree->n.sym;
+ val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
else
{
{
stmtblock_t block;
tree tmp;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
gfc_start_block (&block);
if (code->expr2->ts.type != BT_CLASS)
{
- /* Insert an additional assignment which sets the '$vindex' field. */
- gfc_expr *lhs,*rhs;
+ /* Insert an additional assignment which sets the '$vptr' field. */
lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$vindex");
- if (code->expr2->ts.type == BT_DERIVED)
- /* vindex is constant, determined at compile time. */
- rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
- else if (code->expr2->expr_type == EXPR_NULL)
- rhs = gfc_int_expr (0);
- else
- gcc_unreachable ();
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
-
- /* Insert another assignment which sets the '$size' field. */
- lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$size");
+ gfc_add_component_ref (lhs, "$vptr");
if (code->expr2->ts.type == BT_DERIVED)
{
- /* Size is fixed at compile time. */
- gfc_se lse;
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, lhs);
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+ vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
}
else if (code->expr2->expr_type == EXPR_NULL)
- {
- rhs = gfc_int_expr (0);
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
- }
+ rhs = gfc_int_expr (0);
else
gcc_unreachable ();
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
b = expr->value.function.actual->next->expr;
if (a->ts.type == BT_CLASS)
- gfc_add_component_ref (a, "$vindex");
+ {
+ gfc_add_component_ref (a, "$vptr");
+ gfc_add_component_ref (a, "$hash");
+ }
else if (a->ts.type == BT_DERIVED)
- a = gfc_int_expr (a->ts.u.derived->vindex);
+ a = gfc_int_expr (a->ts.u.derived->hash_value);
if (b->ts.type == BT_CLASS)
- gfc_add_component_ref (b, "$vindex");
+ {
+ gfc_add_component_ref (b, "$vptr");
+ gfc_add_component_ref (b, "$hash");
+ }
else if (b->ts.type == BT_DERIVED)
- b = gfc_int_expr (b->ts.u.derived->vindex);
+ b = gfc_int_expr (b->ts.u.derived->hash_value);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);
}
-/* Generate code for the EXTENDS_TYPE_OF intrinsic. */
-
-static void
-gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
-{
- gfc_expr *e;
- /* TODO: Implement EXTENDS_TYPE_OF. */
- gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
- &expr->where);
- /* Just return 'false' for now. */
- e = gfc_logical_expr (false, &expr->where);
- gfc_conv_expr (se, e);
-}
-
-
/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
gfc_conv_same_type_as (se, expr);
break;
- case GFC_ISYM_EXTENDS_TYPE_OF:
- gfc_conv_extends_type_of (se, expr);
- break;
-
case GFC_ISYM_ABS:
gfc_conv_intrinsic_abs (se, expr);
break;
case GFC_ISYM_CHMOD:
case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
+ case GFC_ISYM_EXTENDS_TYPE_OF:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_FNUM:
gfc_expr *sz;
gfc_se se_sz;
sz = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (sz, "$vptr");
gfc_add_component_ref (sz, "$size");
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
{
gfc_expr *lhs,*rhs;
gfc_se lse;
- /* Initialize VINDEX for CLASS objects. */
+
+ /* Initialize VPTR for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
- gfc_add_component_ref (lhs, "$vindex");
+ gfc_add_component_ref (lhs, "$vptr");
+ rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
- /* vindex must be determined at run time. */
+ /* VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
- gfc_add_component_ref (rhs, "$vindex");
+ gfc_add_component_ref (rhs, "$vptr");
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (rhs);
}
else
{
- /* vindex is fixed at compile time. */
- int vindex;
+ /* VPTR is fixed at compile time. */
+ gfc_symbol *vtab;
+ gfc_typespec *ts;
if (code->expr3)
- vindex = code->expr3->ts.u.derived->vindex;
+ ts = &code->expr3->ts;
+ else if (expr->ts.type == BT_DERIVED)
+ ts = &expr->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
- vindex = code->ext.alloc.ts.u.derived->vindex;
+ ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
- vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
+ ts = &expr->ts.u.derived->components->ts;
else
- vindex = expr->ts.u.derived->vindex;
- rhs = gfc_int_expr (vindex);
- }
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- gfc_add_expr_to_block (&block, tmp);
+ ts = &expr->ts;
- /* Initialize SIZE for CLASS objects. */
- lhs = gfc_expr_to_initialize (expr);
- gfc_add_component_ref (lhs, "$size");
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, lhs);
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), memsz));
- gfc_free_expr (lhs);
+ if (ts->type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, lhs);
+ tmp = gfc_build_addr_expr (NULL_TREE,
+ gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ }
}
}
/* array of structs so we don't have to worry about xmalloc or free */
CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
-static tree gfc_get_derived_type (gfc_symbol * derived);
-
tree gfc_array_index_type;
tree gfc_array_range_type;
tree gfc_character1_type_node;
at the same time. If an equal derived type has been built
in a parent namespace, this is used. */
-static tree
+tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42053
+ * gfortran.dg/select_type_9.f03: New.
+
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41631
+ * gfortran.dg/extends_type_of_1.f03: Fix invalid test case.
+ * gfortran.dg/module_md5_1.f90: Adjusted MD5 sum.
+ * gfortran.dg/select_type_1.f03: Remove FIXMEs.
+ * gfortran.dg/select_type_2.f03: Ditto.
+ * gfortran.dg/select_type_8.f03: New test.
+
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ * gfortran.dg/extends_type_of_1.f03: New test.
+ * gfortran.dg/same_type_as_1.f03: Extended.
+
+2009-11-30 Paul Thomas <pault@gcc.gnu.org>
+
+ * gfortran.dg/class_4c.f03: Add dg-additional-sources.
+ * gfortran.dg/class_4d.f03: Rename module. Cleanup modules.
+
2009-11-30 Janis Johnson <janis187@us.ibm.com>
PR testsuite/42212
! { dg-do run }
+! { dg-additional-sources class_4a.f03 class_4b.f03 }
!
! Test the fix for PR41583, in which the different source files
! would generate the same 'vindex' for different class declared
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
-module m
+module m3
type t
end type t
-end module m
-! { dg-final { cleanup-modules "m m2" } }
+end module m3
+! { dg-final { cleanup-modules "m m2 m3" } }
--- /dev/null
+! { dg-do run }
+!
+! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ implicit none
+
+ intrinsic :: extends_type_of
+
+ type :: t1
+ integer :: i = 42
+ end type
+
+ type, extends(t1) :: t2
+ integer :: j = 43
+ end type
+
+ type, extends(t2) :: t3
+ class(t1),pointer :: cc
+ end type
+
+ class(t1), pointer :: c1,c2
+ type(t1), target :: x
+ type(t2), target :: y
+ type(t3), target :: z
+
+ c1 => x
+ c2 => y
+ z%cc => y
+
+ if (.not. extends_type_of (c1, c1)) call abort()
+ if ( extends_type_of (c1, c2)) call abort()
+ if (.not. extends_type_of (c2, c1)) call abort()
+
+ if (.not. extends_type_of (x, x)) call abort()
+ if ( extends_type_of (x, y)) call abort()
+ if (.not. extends_type_of (y, x)) call abort()
+
+ if (.not. extends_type_of (c1, x)) call abort()
+ if ( extends_type_of (c1, y)) call abort()
+ if (.not. extends_type_of (x, c1)) call abort()
+ if (.not. extends_type_of (y, c1)) call abort()
+
+ if (.not. extends_type_of (z, c1)) call abort()
+ if ( extends_type_of (z%cc, z)) call abort()
+
+end
use foo
print *, pi
end program test
-! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
+! { dg-final { scan-module "foo" "MD5:5632bcd379cf023bf7e663e91d52fa12" } }
! { dg-final { cleanup-modules "foo" } }
! { dg-do compile }
!
-! Error checking for the intrinsic function SAME_TYPE_AS.
+! Error checking for the intrinsic functions SAME_TYPE_AS and EXTENDS_TYPE_OF.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
integer :: i
- print *, SAME_TYPE_AS (l,x1) ! { dg-error "must be of a derived type" }
+ print *, SAME_TYPE_AS (i,x1) ! { dg-error "must be of a derived type" }
print *, SAME_TYPE_AS (x1,x2) ! { dg-error "must be of an extensible type" }
+ print *, EXTENDS_TYPE_OF (i,x1) ! { dg-error "must be of a derived type" }
+ print *, EXTENDS_TYPE_OF (x1,x2) ! { dg-error "must be of an extensible type" }
+
end
print *,"a is TYPE(t1)"
type is (t2)
print *,"a is TYPE(t2)"
-! FIXME: CLASS IS specification is not yet supported
-! class is (ts) ! { FIXME: error "must be extensible" }
-! print *,"a is TYPE(ts)"
+ class is (ts) ! { dg-error "must be extensible" }
+ print *,"a is TYPE(ts)"
type is (t3) ! { dg-error "must be an extension of" }
print *,"a is TYPE(t3)"
type is (t4) ! { dg-error "is not an accessible derived type" }
print *,"a is TYPE(t3)"
-! FIXME: CLASS IS specification is not yet supported
-! class is (t1)
-! print *,"a is CLASS(t1)"
+ class is (t1)
+ print *,"a is CLASS(t1)"
class is (t2) label ! { dg-error "Syntax error" }
print *,"a is CLASS(t2)"
class default ! { dg-error "cannot be followed by a second DEFAULT CASE" }
i = 1
type is (t2)
i = 2
-! FIXME: CLASS IS is not yet supported
-! class is (t1)
-! i = 3
+ class is (t1)
+ i = 3
end select
if (i /= 1) call abort()
i = 1
type is (t2)
i = 2
-! FIXME: CLASS IS is not yet supported
-! class is (t2)
-! i = 3
+ class is (t2)
+ i = 3
end select
if (i /= 2) call abort()
--- /dev/null
+! { dg-do run }
+!
+! executing SELECT TYPE statements with CLASS IS blocks
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ implicit none
+
+ type :: t1
+ integer :: i
+ end type t1
+
+ type, extends(t1) :: t2
+ integer :: j
+ end type t2
+
+ type, extends(t2) :: t3
+ real :: r
+ end type
+
+ class(t1), pointer :: cp
+ type(t1), target :: a
+ type(t2), target :: b
+ type(t3), target :: c
+ integer :: i
+
+ cp => c
+ i = 0
+ select type (cp)
+ type is (t1)
+ i = 1
+ type is (t2)
+ i = 2
+ class is (t1)
+ i = 3
+ class default
+ i = 4
+ end select
+ print *,i
+ if (i /= 3) call abort()
+
+ cp => a
+ select type (cp)
+ type is (t1)
+ i = 1
+ type is (t2)
+ i = 2
+ class is (t1)
+ i = 3
+ end select
+ print *,i
+ if (i /= 1) call abort()
+
+ cp => b
+ select type (cp)
+ type is (t1)
+ i = 1
+ class is (t3)
+ i = 3
+ class is (t2)
+ i = 4
+ class is (t1)
+ i = 5
+ end select
+ print *,i
+ if (i /= 4) call abort()
+
+ cp => b
+ select type (cp)
+ type is (t1)
+ i = 1
+ class is (t1)
+ i = 5
+ class is (t2)
+ i = 4
+ class is (t3)
+ i = 3
+ end select
+ print *,i
+ if (i /= 4) call abort()
+
+ cp => a
+ select type (cp)
+ type is (t2)
+ i = 1
+ class is (t2)
+ i = 2
+ class default
+ i = 3
+ class is (t3)
+ i = 4
+ type is (t3)
+ i = 5
+ end select
+ print *,i
+ if (i /= 3) call abort()
+
+end
--- /dev/null
+! { dg-do compile }
+!
+! PR 42053: [OOP] SELECT TYPE: reject duplicate CLASS IS blocks
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ type :: t
+ integer :: i
+ end type
+
+ CLASS(t),pointer :: x
+
+ select type (x)
+ class is (t)
+ print *,"a"
+ class is (t) ! { dg-error "Double CLASS IS block" }
+ print *,"b"
+ end select
+
+end
+2009-11-30 Janus Weil <janus@gcc.gnu.org>
+
+ * gfortran.map: Add _gfortran_is_extension_of.
+ * Makefile.am: Add intrinsics/extends_type_of.c.
+ * Makefile.in: Regenerated.
+ * intrinsics/extends_type_of.c: New file.
+
2009-11-30 Kai Tietz <Kai.Tietz@onevision.com>
* io/unix.c (find_file): Add variable id conditionally for
intrinsics/erfc_scaled.c \
intrinsics/etime.c \
intrinsics/exit.c \
+intrinsics/extends_type_of.c \
intrinsics/fnum.c \
intrinsics/gerror.c \
intrinsics/getcwd.c \
intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
intrinsics/eoshift0.c intrinsics/eoshift2.c \
intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \
- intrinsics/fnum.c intrinsics/gerror.c intrinsics/getcwd.c \
- intrinsics/getlog.c intrinsics/getXid.c intrinsics/hostnm.c \
- intrinsics/ierrno.c intrinsics/ishftc.c \
- intrinsics/iso_c_generated_procs.c intrinsics/iso_c_binding.c \
- intrinsics/kill.c intrinsics/link.c intrinsics/malloc.c \
- intrinsics/mvbits.c intrinsics/move_alloc.c \
- intrinsics/pack_generic.c intrinsics/perror.c \
- intrinsics/selected_char_kind.c intrinsics/signal.c \
- intrinsics/size.c intrinsics/sleep.c \
+ intrinsics/extends_type_of.c intrinsics/fnum.c \
+ intrinsics/gerror.c intrinsics/getcwd.c intrinsics/getlog.c \
+ intrinsics/getXid.c intrinsics/hostnm.c intrinsics/ierrno.c \
+ intrinsics/ishftc.c intrinsics/iso_c_generated_procs.c \
+ intrinsics/iso_c_binding.c intrinsics/kill.c intrinsics/link.c \
+ intrinsics/malloc.c intrinsics/mvbits.c \
+ intrinsics/move_alloc.c intrinsics/pack_generic.c \
+ intrinsics/perror.c intrinsics/selected_char_kind.c \
+ intrinsics/signal.c intrinsics/size.c intrinsics/sleep.c \
intrinsics/spread_generic.c intrinsics/string_intrinsics.c \
intrinsics/system.c intrinsics/rand.c intrinsics/random.c \
intrinsics/rename.c intrinsics/reshape_generic.c \
bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
- fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
- ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
- kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
- pack_generic.lo perror.lo selected_char_kind.lo signal.lo \
- size.lo sleep.lo spread_generic.lo string_intrinsics.lo \
- system.lo rand.lo random.lo rename.lo reshape_generic.lo \
- reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
- stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
- umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
+ extends_type_of.lo fnum.lo gerror.lo getcwd.lo getlog.lo \
+ getXid.lo hostnm.lo ierrno.lo ishftc.lo \
+ iso_c_generated_procs.lo iso_c_binding.lo kill.lo link.lo \
+ malloc.lo mvbits.lo move_alloc.lo pack_generic.lo perror.lo \
+ selected_char_kind.lo signal.lo size.lo sleep.lo \
+ spread_generic.lo string_intrinsics.lo system.lo rand.lo \
+ random.lo rename.lo reshape_generic.lo reshape_packed.lo \
+ selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
+ system_clock.lo time.lo transpose_generic.lo umask.lo \
+ unlink.lo unpack_generic.lo in_pack_generic.lo \
in_unpack_generic.lo
am__objects_37 =
am__objects_38 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
intrinsics/erfc_scaled.c \
intrinsics/etime.c \
intrinsics/exit.c \
+intrinsics/extends_type_of.c \
intrinsics/fnum.c \
intrinsics/gerror.c \
intrinsics/getcwd.c \
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/exponent_r8.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extends_type_of.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fbuf.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/file_pos.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fmain.Plo@am__quote@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
+extends_type_of.lo: intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT extends_type_of.lo -MD -MP -MF $(DEPDIR)/extends_type_of.Tpo -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/extends_type_of.Tpo $(DEPDIR)/extends_type_of.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/extends_type_of.c' object='extends_type_of.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o extends_type_of.lo `test -f 'intrinsics/extends_type_of.c' || echo '$(srcdir)/'`intrinsics/extends_type_of.c
+
fnum.lo: intrinsics/fnum.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT fnum.lo -MD -MP -MF $(DEPDIR)/fnum.Tpo -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/fnum.Tpo $(DEPDIR)/fnum.Plo
global:
_gfortran_clz128;
_gfortran_ctz128;
+ _gfortran_is_extension_of;
} GFORTRAN_1.1;
F2C_1.0 {
--- /dev/null
+/* Implementation of the EXTENDS_TYPE_OF intrinsic.
+ Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc.
+ Contributed by Janus Weil <janus@gcc.gnu.org>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
+
+
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+
+typedef struct vtype
+{
+ GFC_INTEGER_4 hash;
+ GFC_INTEGER_4 size;
+ struct vtype *extends;
+}
+vtype;
+
+
+extern GFC_LOGICAL_4 is_extension_of (struct vtype *, struct vtype *);
+export_proto(is_extension_of);
+
+
+/* This is a helper function for the F2003 intrinsic EXTENDS_TYPE_OF.
+ While EXTENDS_TYPE_OF accepts CLASS or TYPE arguments, this one here gets
+ passed the corresponding vtabs. Each call to EXTENDS_TYPE_OF is translated
+ to a call to is_extension_of. */
+
+GFC_LOGICAL_4
+is_extension_of (struct vtype *v1, struct vtype *v2)
+{
+ while (v1)
+ {
+ if (v1->hash == v2->hash) return 1;
+ v1 = v1->extends;
+ }
+ return 0;
+}
projects / platform / upstream / gcc.git / commitdiff