+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/43896
+ * symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
+ initializers for PPC members of the vtabs.
+
+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42274
+ * symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
+ attribute for all PPC members of the vtypes.
+ (copy_vtab_proc_comps): Copy the correct interface.
+ * trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
+ * trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
+ a dummy argument and make sure all PPC members of the vtab are
+ initialized correctly.
+ (gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
+ in call to gfc_trans_assign_vtab_procs.
+ * trans-stmt.c (gfc_trans_allocate): Ditto.
+
+2010-04-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/43326
+ * resolve.c (resolve_typebound_function): Renamed
+ resolve_class_compcall.Do all the detection of class references
+ here.
+ (resolve_typebound_subroutine): resolve_class_typebound_call
+ renamed. Otherwise same as resolve_typebound_function.
+ (gfc_resolve_expr): Call resolve_typebound_function.
+ (resolve_code): Call resolve_typebound_subroutine.
+
+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/43492
+ * resolve.c (resolve_typebound_generic_call): For CLASS methods
+ pass back the specific symtree name, rather than the target
+ name.
+
+2010-04-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/42353
+ * resolve.c (resolve_structure_cons): Make the initializer of
+ the vtab component 'extends' the same type as the component.
+
+2010-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/42680
+ * interface.c (check_interface1): Pass symbol name rather than NULL to
+ gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
+ trap MULL. (gfc_compare_derived_types): Revert previous change
+ incorporated incorrectly during merge from trunk, r155778.
+ * resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
+ than NULL to gfc_compare_interfaces.
+ * symbol.c (add_generic_specifics): Likewise.
+
+2010-02-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42353
+ * interface.c (gfc_compare_derived_types): Add condition for vtype.
+ * symbol.c (gfc_find_derived_vtab): Sey access to private.
+ (gfc_find_derived_vtab): Likewise.
+ * module.c (ab_attribute): Add enumerator AB_VTAB.
+ (mio_symbol_attribute): Use new attribute, AB_VTAB.
+ (check_for_ambiguous): Likewise.
+
+2010-04-29 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41829
+ * trans-expr.c (select_class_proc): Remove function.
+ (conv_function_val): Delete reference to previous.
+ (gfc_conv_derived_to_class): Add second argument to the call to
+ gfc_find_derived_vtab.
+ (gfc_conv_structure): Exclude proc_pointer components when
+ accessing $data field of class objects.
+ (gfc_trans_assign_vtab_procs): New function.
+ (gfc_trans_class_assign): Add second argument to the call to
+ gfc_find_derived_vtab.
+ * symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
+ implement holding off searching for the vptr derived type.
+ (add_proc_component): New function.
+ (add_proc_comps): New function.
+ (add_procs_to_declared_vtab1): New function.
+ (copy_vtab_proc_comps): New function.
+ (add_procs_to_declared_vtab): New function.
+ (void add_generic_specifics): New function.
+ (add_generics_to_declared_vtab): New function.
+ (gfc_find_derived_vtab): Add second argument to the call to
+ gfc_find_derived_vtab. Add the calls to
+ add_procs_to_declared_vtab and add_generics_to_declared_vtab.
+ * decl.c (build_sym, build_struct): Use new arg in calls to
+ gfc_build_class_symbol.
+ * gfortran.h : Add vtype bitfield to symbol_attr. Remove the
+ definition of struct gfc_class_esym_list. Modify prototypes
+ of gfc_build_class_symbol and gfc_find_derived_vtab.
+ * trans-stmt.c (gfc_trans_allocate): Add second argument to the
+ call to gfc_find_derived_vtab.
+ * module.c : Add the vtype attribute.
+ * trans.h : Add prototype for gfc_trans_assign_vtab_procs.
+ * resolve.c (resolve_typebound_generic_call): Add second arg
+ to pass along the generic name for class methods.
+ (resolve_typebound_call): The same.
+ (resolve_compcall): Use the second arg to carry the generic
+ name from the above. Remove the reference to class_esym.
+ (check_members, check_class_members, resolve_class_esym,
+ hash_value_expr): Remove functions.
+ (resolve_class_compcall, resolve_class_typebound_call): Modify
+ to use vtable rather than member by member calls.
+ (gfc_resolve_expr): Modify second arg in call to
+ resolve_compcall.
+ (resolve_select_type): Add second arg in call to
+ gfc_find_derived_vtab.
+ (resolve_code): Add second arg in call resolve_typebound_call.
+ (resolve_fl_derived): Exclude vtypes from check for late
+ procedure definitions. Likewise for checking of explicit
+ interface and checking of pass arg.
+ * iresolve.c (gfc_resolve_extends_type_of): Add second arg in
+ calls to gfc_find_derived_vtab.
+ * match.c (select_type_set_tmp): Use new arg in call to
+ gfc_build_class_symbol.
+ * trans-decl.c (gfc_get_symbol_decl): Complete vtable if
+ necessary.
+ * parse.c (endType): Finish incomplete classes.
+
2010-04-28 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
}
return SUCCESS;
scalar:
if (c->ts.type == BT_CLASS)
- gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
+ gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
return t;
}
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. */
+ unsigned vtab:1; /* is a derived type vtab, pointed to by CLASS objects. */
+ unsigned vtype:1; /* is a derived type of a 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
gfc_intrinsic_sym;
-typedef struct gfc_class_esym_list
-{
- gfc_symbol *derived;
- gfc_symbol *esym;
- struct gfc_expr *hash_value;
- struct gfc_class_esym_list *next;
-}
-gfc_class_esym_list;
-
-#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
-
/* Expression nodes. The expression node types deserve explanations,
since the last couple can be easily misconstrued:
const char *name; /* Points to the ultimate name of the function */
gfc_intrinsic_sym *isym;
gfc_symbol *esym;
- gfc_class_esym_list *class_esym;
}
function;
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_array_spec **, bool);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
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*);
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, 0,
- NULL, 0))
+ if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
+ 0, NULL, 0))
{
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
gfc_add_component_ref (a, "$vptr");
else if (a->ts.type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (a->ts.u.derived);
+ vtab = gfc_find_derived_vtab (a->ts.u.derived, false);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
memset (a, '\0', sizeof (gfc_expr));
gfc_add_component_ref (mo, "$vptr");
else if (mo->ts.type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+ vtab = gfc_find_derived_vtab (mo->ts.u.derived, false);
/* Clear the old expr. */
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
- &tmp->n.sym->as);
+ &tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}
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_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
- AB_COARRAY_COMP
+ AB_COARRAY_COMP, AB_VTYPE, AB_VTAB
}
ab_attribute;
minit ("IS_CLASS", AB_IS_CLASS),
minit ("PROCEDURE", AB_PROCEDURE),
minit ("PROC_POINTER", AB_PROC_POINTER),
+ minit ("VTYPE", AB_VTYPE),
+ minit ("VTAB", AB_VTAB),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
if (attr->proc_pointer)
MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
+ if (attr->vtype)
+ MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
+ if (attr->vtab)
+ MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
mio_rparen ();
case AB_PROC_POINTER:
attr->proc_pointer = 1;
break;
+ case AB_VTYPE:
+ attr->vtype = 1;
+ break;
+ case AB_VTAB:
+ attr->vtab = 1;
+ break;
}
}
}
if (st_sym == rsym)
return false;
+ if (st_sym->attr.vtab || st_sym->attr.vtype)
+ return false;
+
/* If the existing symbol is generic from a different module and
the new symbol is generic there can be no ambiguity. */
if (st_sym->attr.generic
|| c->attr.access == ACCESS_PRIVATE
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
sym->attr.private_comp = 1;
+
+ /* Fix up incomplete CLASS components. */
+ if (c->ts.type == BT_CLASS)
+ {
+ gfc_component *data;
+ gfc_component *vptr;
+ gfc_symbol *vtab;
+ data = gfc_find_component (c->ts.u.derived, "$data", true, true);
+ vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
+ if (vptr->ts.u.derived == NULL)
+ {
+ vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
}
if (!seen_component)
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (strcmp (comp->name, "$extends") == 0)
+ {
+ /* Can afford to be brutal with the $extends initializer.
+ The derived type can get lost because it is PRIVATE
+ but it is not usage constrained by the standard. */
+ cons->expr->ts = comp->ts;
+ t = SUCCESS;
+ }
+ else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
/* Non-assumed length character functions. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER
- && gsym->ns->proc_name->ts.u.cl != NULL
- && gsym->ns->proc_name->ts.u.cl->length != NULL)
+ && gsym->ns->proc_name->ts.u.cl->length != NULL)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
the expression into a call of that binding. */
static gfc_try
-resolve_typebound_generic_call (gfc_expr* e)
+resolve_typebound_generic_call (gfc_expr* e, const char **name)
{
gfc_typebound_proc* genproc;
const char* genname;
if (matches)
{
e->value.compcall.tbp = g->specific;
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = g->specific_st->name;
goto success;
}
}
/* Resolve a call to a type-bound subroutine. */
static gfc_try
-resolve_typebound_call (gfc_code* c)
+resolve_typebound_call (gfc_code* c, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
if (check_typebound_baseobject (c->expr1) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (c->expr1) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = c->expr1->value.compcall.name;
+
+ if (resolve_typebound_generic_call (c->expr1, name) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
}
-/* Resolve a component-call expression. This originally was intended
- only to see functions. However, it is convenient to use it in
- resolving subroutine class methods, since we do not have to add a
- gfc_code each time. */
+/* Resolve a component-call expression. */
static gfc_try
-resolve_compcall (gfc_expr* e, bool fcn, bool class_members)
+resolve_compcall (gfc_expr* e, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (fcn && !e->value.compcall.tbp->function)
+ if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
- else if (!fcn && !e->value.compcall.tbp->subroutine)
- {
- /* To resolve class member calls, we borrow this bit
- of code to select the specific procedures. */
- gfc_error ("'%s' at %L should be a SUBROUTINE",
- e->value.compcall.name, &e->where);
- return FAILURE;
- }
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
- if (resolve_typebound_generic_call (e) == FAILURE)
+ /* Pass along the name for CLASS methods, where the vtab
+ procedure pointer component has to be referenced. */
+ if (name)
+ *name = e->value.compcall.name;
+
+ if (resolve_typebound_generic_call (e, name) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
e->value.function.actual = newactual;
e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
- e->value.function.class_esym = NULL;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
- /* Resolution is not necessary when constructing component calls
- for class members, since this must only be done for the
- declared type, which is done afterwards. */
- return !class_members ? gfc_resolve_expr (e) : SUCCESS;
-}
-
-
-/* Resolve a typebound call for the members in a class. This group of
- functions implements dynamic dispatch in the provisional version
- of f03 OOP. As soon as vtables are in place and contain pointers
- to methods, this will no longer be necessary. */
-static gfc_expr *list_e;
-static gfc_try check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
- if (derived->attr.flavor == FL_DERIVED)
- (void) check_class_members (derived);
-}
-
-
-static gfc_try
-check_class_members (gfc_symbol *derived)
-{
- gfc_expr *e;
- gfc_symtree *tbp;
- gfc_class_esym_list *etmp;
-
- e = gfc_copy_expr (list_e);
-
- tbp = gfc_find_typebound_proc (derived, &class_try,
- e->value.compcall.name,
- false, &e->where);
-
- if (tbp == NULL)
- {
- gfc_error ("no typebound available procedure named '%s' at %L",
- e->value.compcall.name, &e->where);
- return FAILURE;
- }
-
- /* If we have to match a passed class member, force the actual
- expression to have the correct type. */
- if (!tbp->n.tb->nopass)
- {
- if (e->value.compcall.base_object == NULL)
- e->value.compcall.base_object = extract_compcall_passed_object (e);
-
- if (e->value.compcall.base_object == NULL)
- return FAILURE;
-
- if (!derived->attr.abstract)
- {
- e->value.compcall.base_object->ts.type = BT_DERIVED;
- e->value.compcall.base_object->ts.u.derived = derived;
- }
- }
-
- e->value.compcall.tbp = tbp->n.tb;
- e->value.compcall.name = tbp->name;
-
- /* Let the original expresssion catch the assertion in
- resolve_compcall, since this flag does not appear to be reset or
- copied in some systems. */
- e->value.compcall.assign = 0;
-
- /* Do the renaming, PASSing, generic => specific and other
- good things for each class member. */
- class_try = (resolve_compcall (e, fcn_flag, true) == SUCCESS)
- ? class_try : FAILURE;
-
- /* Now transfer the found symbol to the esym list. */
- if (class_try == SUCCESS)
- {
- etmp = list_e->value.function.class_esym;
- list_e->value.function.class_esym
- = gfc_get_class_esym_list();
- list_e->value.function.class_esym->next = etmp;
- list_e->value.function.class_esym->derived = derived;
- list_e->value.function.class_esym->esym
- = e->value.function.esym;
- }
-
- gfc_free_expr (e);
-
- /* Burrow down into grandchildren types. */
- if (derived->f2k_derived)
- gfc_traverse_ns (derived->f2k_derived, check_members);
-
- return SUCCESS;
-}
-
-
-/* Eliminate esym_lists where all the members point to the
- typebound procedure of the declared type; ie. one where
- type selection has no effect.. */
-static void
-resolve_class_esym (gfc_expr *e)
-{
- gfc_class_esym_list *p, *q;
- bool empty = true;
-
- gcc_assert (e && e->expr_type == EXPR_FUNCTION);
-
- p = e->value.function.class_esym;
- if (p == NULL)
- return;
-
- for (; p; p = p->next)
- empty = empty && (e->value.function.esym == p->esym);
-
- if (empty)
- {
- p = e->value.function.class_esym;
- for (; p; p = q)
- {
- q = p->next;
- gfc_free (p);
- }
- e->value.function.class_esym = NULL;
- }
-}
-
-
-/* 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*
-hash_value_expr (gfc_ref *class_ref, gfc_ref *new_ref, gfc_symtree *st)
-{
- gfc_expr *hash_value;
-
- /* Build an expression for the correct hash_value; ie. that of the last
- CLASS reference. */
- if (class_ref)
- {
- class_ref->next = NULL;
- }
- else
- {
- gfc_free_ref_list (new_ref);
- new_ref = NULL;
- }
- 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 hash_value;
+ /* Resolution is not necessary if this is a class subroutine; this
+ function only has to identify the specific proc. Resolution of
+ the call will be done next in resolve_typebound_call. */
+ return gfc_resolve_expr (e);
}
}
-/* Resolve the argument expressions so that any arguments expressions
- that include class methods are resolved before the current call.
- This is necessary because of the static variables used in CLASS
- method resolution. */
-static void
-resolve_arg_exprs (gfc_actual_arglist *arg)
-{
- /* Resolve the actual arglist expressions. */
- for (; arg; arg = arg->next)
- {
- if (arg->expr)
- gfc_resolve_expr (arg->expr);
- }
-}
-
-
-/* Resolve a typebound function, or 'method'. First separate all
- the non-CLASS references by calling resolve_compcall directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
- gfc_symbol *derived, *declared;
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
+ const char *genname;
+ gfc_typespec ts;
st = e->symtree;
if (st == NULL)
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
- || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_compcall (e, true, false);
+ return resolve_compcall (e, NULL);
}
- /* Resolve the argument expressions, */
- resolve_arg_exprs (e->value.function.actual);
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
+ /* Keep the generic name so that the vtab reference can be made. */
+ genname = NULL;
+ if (e->value.compcall.tbp->is_generic)
+ genname = e->value.compcall.name;
- /* Resolve the function call for each member of the class. */
- class_try = SUCCESS;
- fcn_flag = true;
- list_e = gfc_copy_expr (e);
-
- if (check_class_members (derived) == FAILURE)
- return FAILURE;
+ /* Treat the call as if it is a typebound procedure, in order to roll
+ out the correct name for the specific function. */
+ resolve_compcall (e, &name);
+ ts = e->ts;
- class_try = (resolve_compcall (e, true, false) == SUCCESS)
- ? class_try : FAILURE;
+ /* Then convert the expression to a procedure pointer component call. */
+ e->value.function.esym = NULL;
+ e->symtree = st;
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- e->value.function.class_esym = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
-
- resolve_class_esym (e);
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ e->ref = new_ref;
+ }
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (e->value.function.class_esym != NULL)
- e->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (e, "$vptr");
+ if (genname)
+ {
+ /* A generic procedure needs the subsidiary vtabs and vtypes for
+ the specific procedures to have been build. */
+ gfc_symbol *vtab;
+ vtab = gfc_find_derived_vtab (declared, true);
+ gcc_assert (vtab);
+ gfc_add_component_ref (e, genname);
+ }
+ gfc_add_component_ref (e, name);
- return class_try;
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ e->ts = ts;
+ return SUCCESS;
}
-/* Resolve a typebound subroutine, or 'method'. First separate all
- the non-CLASS references by calling resolve_typebound_call directly.
- Then treat the CLASS references by resolving for each of the class
- members in turn. */
+/* Resolve a typebound subroutine, or 'method'. First separate all
+ the non-CLASS references by calling resolve_typebound_call
+ directly. */
static gfc_try
resolve_typebound_subroutine (gfc_code *code)
{
- gfc_symbol *derived, *declared;
+ gfc_symbol *declared;
+ gfc_component *c;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *genname;
+ const char *name;
+ gfc_typespec ts;
st = code->expr1->symtree;
if (st == NULL)
- return resolve_typebound_call (code);
+ return resolve_typebound_call (code, NULL);
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
- || (!class_ref && st->n.sym->ts.type != BT_CLASS))
+ || (!class_ref && st->n.sym->ts.type != BT_CLASS))
{
gfc_free_ref_list (new_ref);
- return resolve_typebound_call (code);
+ return resolve_typebound_call (code, NULL);
}
- /* Resolve the argument expressions, */
- resolve_arg_exprs (code->expr1->value.compcall.actual);
-
- /* Get the data component, which is of the declared type. */
- derived = declared->components->ts.u.derived;
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
- class_try = SUCCESS;
- fcn_flag = false;
- list_e = gfc_copy_expr (code->expr1);
-
- if (check_class_members (derived) == FAILURE)
- return FAILURE;
+ /* Keep the generic name so that the vtab reference can be made. */
+ genname = NULL;
+ if (code->expr1->value.compcall.tbp->is_generic)
+ genname = code->expr1->value.compcall.name;
- class_try = (resolve_typebound_call (code) == SUCCESS)
- ? class_try : FAILURE;
+ resolve_typebound_call (code, &name);
+ ts = code->expr1->ts;
- /* Transfer the class list to the original expression. Note that
- the class_esym list is cleaned up in trans-expr.c, as the calls
- are translated. */
- code->expr1->value.function.class_esym
- = list_e->value.function.class_esym;
- list_e->value.function.class_esym = NULL;
- gfc_free_expr (list_e);
+ /* Then convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
- resolve_class_esym (code->expr1);
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ code->expr1->ref = new_ref;
+ }
- /* More than one typebound procedure so transmit an expression for
- the hash_value as the selector. */
- if (code->expr1->value.function.class_esym != NULL)
- code->expr1->value.function.class_esym->hash_value
- = hash_value_expr (class_ref, new_ref, st);
+ /* '$vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_component_ref (code->expr1, "$vptr");
+ if (genname)
+ {
+ /* A generic procedure needs the subsidiary vtabs and vtypes for
+ the specific procedures to have been build. */
+ gfc_symbol *vtab;
+ vtab = gfc_find_derived_vtab (declared, true);
+ gcc_assert (vtab);
+ gfc_add_component_ref (code->expr1, genname);
+ }
+ gfc_add_component_ref (code->expr1, name);
- return class_try;
+ /* Recover the typespec for the expression. This is really only
+ necessary for generic procedures, where the additional call
+ to gfc_add_component_ref seems to throw the collection of the
+ correct typespec. */
+ code->expr1->ts = ts;
+ return SUCCESS;
}
tail->next = NULL;
default_case = tail;
}
-
+
/* More than one CLASS IS block? */
if (class_is->block)
{
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);
+ vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
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);
if (c->attr.proc_pointer && c->ts.interface)
{
- if (c->ts.interface->attr.procedure)
+ if (c->ts.interface->attr.procedure && !sym->attr.vtype)
gfc_error ("Interface '%s', used by procedure pointer component "
"'%s' at %L, is declared in a later PROCEDURE statement",
c->ts.interface->name, c->name, &c->loc);
c->ts.u.cl = cl;
}
}
- else if (c->ts.interface->name[0] != '\0')
+ else if (c->ts.interface->name[0] != '\0' && !sym->attr.vtype)
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
}
/* Procedure pointer components: Check PASS arg. */
- if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
+ if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
+ && !sym->attr.vtype)
{
gfc_symbol* me_arg;
gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as)
+ gfc_array_spec **as, bool delayed_vtab)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
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;
+ if (delayed_vtab)
+ c->ts.u.derived = NULL;
+ else
+ {
+ vtab = gfc_find_derived_vtab (ts->u.derived, false);
+ gcc_assert (vtab);
+ c->ts.u.derived = vtab->ts.u.derived;
+ }
c->attr.pointer = 1;
}
}
-/* Find the symbol for a derived type's vtab. */
+static void
+add_proc_component (gfc_component *c, gfc_symbol *vtype,
+ gfc_symtree *st, gfc_symbol *specific,
+ bool is_generic, bool is_generic_specific)
+{
+ /* Add procedure component. */
+ if (is_generic)
+ {
+ if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
+ return;
+ c->ts.interface = specific;
+ }
+ else if (c && is_generic_specific)
+ {
+ c->ts.interface = st->n.tb->u.specific->n.sym;
+ }
+ else
+ {
+ c = gfc_find_component (vtype, st->name, true, true);
+ if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
+ return;
+ c->ts.interface = st->n.tb->u.specific->n.sym;
+ }
+
+ if (!c->tb)
+ c->tb = XCNEW (gfc_typebound_proc);
+ *c->tb = *st->n.tb;
+ c->tb->ppc = 1;
+ c->attr.procedure = 1;
+ c->attr.proc_pointer = 1;
+ c->attr.flavor = FL_PROCEDURE;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.external = 1;
+ c->attr.untyped = 1;
+ c->attr.if_source = IFSRC_IFBODY;
+
+ /* A static initializer cannot be used here because the specific
+ function is not a constant; internal compiler error: in
+ output_constant, at varasm.c:4623 */
+ c->initializer = NULL;
+}
+
+
+static void
+add_proc_comps (gfc_component *c, gfc_symbol *vtype,
+ gfc_symtree *st, bool is_generic)
+{
+ if (c == NULL && !is_generic)
+ {
+ add_proc_component (c, vtype, st, NULL, false, false);
+ }
+ else if (is_generic && st->n.tb && vtype->components == NULL)
+ {
+ gfc_tbp_generic* g;
+ gfc_symbol * specific;
+ for (g = st->n.tb->u.generic; g; g = g->next)
+ {
+ if (!g->specific)
+ continue;
+ specific = g->specific->u.specific->n.sym;
+ add_proc_component (NULL, vtype, st, specific, true, false);
+ }
+ }
+ else if (c->attr.proc_pointer && c->tb)
+ {
+ *c->tb = *st->n.tb;
+ c->tb->ppc = 1;
+ c->ts.interface = st->n.tb->u.specific->n.sym;
+ }
+}
+
+static void
+add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
+ bool resolved)
+{
+ gfc_component *c;
+ gfc_symbol *generic;
+ char name[3 * GFC_MAX_SYMBOL_LEN + 10];
+
+ if (!st)
+ return;
+
+ if (st->left)
+ add_procs_to_declared_vtab1 (st->left, vtype, resolved);
+
+ if (st->right)
+ add_procs_to_declared_vtab1 (st->right, vtype, resolved);
+
+ if (!st->n.tb)
+ return;
+
+ if (!st->n.tb->is_generic && st->n.tb->u.specific)
+ {
+ c = gfc_find_component (vtype, st->name, true, true);
+ add_proc_comps (c, vtype, st, false);
+ }
+ else if (st->n.tb->is_generic)
+ {
+ c = gfc_find_component (vtype, st->name, true, true);
+
+ if (c == NULL)
+ {
+ /* Add derived type component with generic name. */
+ if (gfc_add_component (vtype, st->name, &c) == FAILURE)
+ return;
+ c->ts.type = BT_DERIVED;
+ c->attr.flavor = FL_VARIABLE;
+ c->attr.pointer = 1;
+
+ /* Add a special empty derived type as a placeholder. */
+ sprintf (name, "$empty");
+ gfc_find_symbol (name, vtype->ns, 0, &generic);
+ if (generic == NULL)
+ {
+ gfc_get_symbol (name, vtype->ns, &generic);
+ generic->attr.flavor = FL_DERIVED;
+ generic->refs++;
+ gfc_set_sym_referenced (generic);
+ generic->ts.type = BT_UNKNOWN;
+ generic->attr.zero_comp = 1;
+ }
+
+ c->ts.u.derived = generic;
+ }
+ }
+}
+
+
+static void
+copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
+ bool resolved)
+{
+ gfc_component *c, *cmp;
+ gfc_symbol *vtab;
+
+ vtab = gfc_find_derived_vtab (declared, resolved);
+
+ for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
+ {
+ if (gfc_find_component (vtype, cmp->name, true, true))
+ continue;
+
+ if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
+ return;
+
+ if (cmp->ts.type == BT_DERIVED)
+ {
+ c->ts = cmp->ts;
+ c->ts.u.derived = cmp->ts.u.derived;
+ c->attr.flavor = FL_VARIABLE;
+ c->attr.pointer = 1;
+ c->initializer = NULL;
+ continue;
+ }
+
+ c->tb = XCNEW (gfc_typebound_proc);
+ *c->tb = *cmp->tb;
+ c->attr.procedure = 1;
+ c->attr.proc_pointer = 1;
+ c->attr.flavor = FL_PROCEDURE;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.external = 1;
+ c->ts.interface = cmp->ts.interface;
+ c->attr.untyped = 1;
+ c->attr.if_source = IFSRC_IFBODY;
+ c->initializer = NULL;
+ }
+}
+
+static void
+add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+ gfc_symbol *derived, bool resolved)
+{
+ gfc_symbol* super_type;
+
+ super_type = gfc_get_derived_super_type (declared);
+
+ if (super_type && (super_type != declared))
+ add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
+
+ if (declared != derived)
+ copy_vtab_proc_comps (declared, vtype, resolved);
+
+ if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
+ add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
+ vtype, resolved);
+
+ if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
+ add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
+ vtype, resolved);
+}
+
+
+static
+void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
+ const char *name)
+{
+ gfc_tbp_generic* g;
+ gfc_symbol * specific1;
+ gfc_symbol * specific2;
+ gfc_symtree *st = NULL;
+ gfc_component *c;
+
+ /* Find the generic procedure using the component name. */
+ st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
+ if (st == NULL)
+ st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
+
+ if (st == NULL)
+ return;
+
+ /* Add procedure pointer components for the specific procedures. */
+ for (g = st->n.tb->u.generic; g; g = g->next)
+ {
+ if (!g->specific)
+ continue;
+ specific1 = g->specific_st->n.tb->u.specific->n.sym;
+
+ c = vtab->ts.u.derived->components;
+ specific2 = NULL;
+
+ /* Override identical specific interface. */
+ if (vtab->ts.u.derived->components)
+ {
+ for (; c; c= c->next)
+ {
+ specific2 = c->ts.interface;
+ if (gfc_compare_interfaces (specific2, specific1,
+ specific1->name, 0, 0, NULL, 0))
+ break;
+ }
+ }
+
+ add_proc_component (c, vtab->ts.u.derived, g->specific_st,
+ NULL, false, true);
+ vtab->ts.u.derived->attr.zero_comp = 0;
+ }
+}
+
+
+static void
+add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
+ gfc_symbol *derived, bool resolved)
+{
+ gfc_component *cmp;
+ gfc_symtree *st = NULL;
+ gfc_symbol * vtab;
+ char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+ gfc_symbol* super_type;
+
+ gcc_assert (resolved);
+
+ for (cmp = vtype->components; cmp; cmp = cmp->next)
+ {
+ if (cmp->ts.type != BT_DERIVED)
+ continue;
+
+ /* The only derived type that does not represent a generic
+ procedure is the pointer to the parent vtab. */
+ if (cmp->ts.u.derived
+ && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
+ continue;
+
+ /* Find the generic procedure using the component name. */
+ st = gfc_find_typebound_proc (declared, NULL, cmp->name,
+ true, NULL);
+ if (st == NULL)
+ st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
+ true, NULL);
+
+ /* Should be an error but we pass on it for now. */
+ if (st == NULL || !st->n.tb->is_generic)
+ continue;
+
+ vtab = NULL;
+
+ /* Build a vtab and a special vtype, with only the procedure
+ pointer fields, to carry the pointers to the specific
+ procedures. Should this name ever be changed, the same
+ should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
+ sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
+ gfc_find_symbol (name, derived->ns, 0, &vtab);
+ if (vtab == NULL)
+ {
+ gfc_get_symbol (name, derived->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, "%s$%s", vtype->name, cmp->name);
+
+ gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
+ if (cmp->ts.u.derived == NULL
+ || (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
+ {
+ gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
+ if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return;
+ cmp->ts.u.derived->refs++;
+ gfc_set_sym_referenced (cmp->ts.u.derived);
+ cmp->ts.u.derived->attr.vtype = 1;
+ cmp->ts.u.derived->attr.zero_comp = 1;
+ }
+ vtab->ts.u.derived = cmp->ts.u.derived;
+ }
+
+ /* Store this for later use in setting the pointer. */
+ cmp->ts.interface = vtab;
+
+ if (vtab->ts.u.derived->components)
+ continue;
+
+ super_type = gfc_get_derived_super_type (declared);
+
+ if (super_type && (super_type != declared))
+ add_generic_specifics (super_type, vtab, cmp->name);
+
+ add_generic_specifics (declared, vtab, cmp->name);
+ }
+}
+
+
+/* Find the symbol for a derived type's vtab. A vtab has the following
+ fields:
+ $hash a hash value used to identify the derived type
+ $size the size in bytes of the derived type
+ $extends a pointer to the vtable of the parent derived type
+ then:
+ procedure pointer components for the specific typebound procedures
+ structure pointers to reduced vtabs that contain procedure
+ pointers to the specific procedures. */
gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived)
+gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL;
vtab->attr.target = 1;
vtab->attr.save = SAVE_EXPLICIT;
vtab->attr.vtab = 1;
- vtab->attr.access = ACCESS_PRIVATE;
vtab->refs++;
gfc_set_sym_referenced (vtab);
sprintf (name, "vtype$%s", derived->name);
return NULL;
vtype->refs++;
gfc_set_sym_referenced (vtype);
- vtype->attr.access = ACCESS_PRIVATE;
/* Add component '$hash'. */
if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
parent = gfc_get_derived_super_type (derived);
if (parent)
{
- parent_vtab = gfc_find_derived_vtab (parent);
+ parent_vtab = gfc_find_derived_vtab (parent, resolved);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
- &c->initializer->symtree);
+ gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
+ 0, &c->initializer->symtree);
}
else
{
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
+
+ add_procs_to_declared_vtab (derived, vtype, derived, resolved);
+ vtype->attr.vtype = 1;
}
- vtab->ts.u.derived = vtype;
+ vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
+ /* Catch the call just before the backend declarations are built, so that
+ the generic procedures have been resolved and the specific procedures
+ have formal interfaces that can be compared. */
+ if (resolved
+ && vtab->ts.u.derived
+ && vtab->ts.u.derived->backend_decl == NULL)
+ add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
+ derived, resolved);
+
return vtab;
}
else
byref = 0;
+ /* Make sure that the vtab for the declared type is completed. */
+ if (sym->ts.type == BT_CLASS)
+ {
+ gfc_component *c = gfc_find_component (sym->ts.u.derived,
+ "$data", true, true);
+ if (!c->ts.u.derived->backend_decl)
+ gfc_find_derived_vtab (c->ts.u.derived, true);
+ }
+
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
{
/* Return via extra parameter. */
}
-/* Select a class typebound procedure at runtime. */
-static void
-select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
- tree declared, gfc_expr *expr)
-{
- tree end_label;
- tree label;
- tree tmp;
- tree hash;
- stmtblock_t body;
- gfc_class_esym_list *next_elist, *tmp_elist;
- gfc_se tmpse;
-
- /* Convert the hash expression. */
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, elist->hash_value);
- gfc_add_block_to_block (&se->pre, &tmpse.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. */
- declared = gfc_create_var (TREE_TYPE (declared), "method");
-
- end_label = gfc_build_label_decl (NULL_TREE);
-
- gfc_init_block (&body);
-
- /* Go through the list of extensions. */
- for (; elist; elist = next_elist)
- {
- /* This case has already been added. */
- if (elist->derived == NULL)
- goto free_elist;
-
- /* Skip abstract base types. */
- if (elist->derived->attr.abstract)
- goto free_elist;
-
- /* Run through the chain picking up all the cases that call the
- same procedure. */
- tmp_elist = elist;
- for (; elist; elist = elist->next)
- {
- tree cval;
-
- if (elist->esym != tmp_elist->esym)
- continue;
-
- 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);
- gfc_add_expr_to_block (&body, tmp);
-
- /* Null the reference the derived type so that this case is
- not used again. */
- elist->derived = NULL;
- }
-
- elist = tmp_elist;
-
- /* Get a pointer to the procedure, */
- tmp = gfc_get_symbol_decl (elist->esym);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
- gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
- /* Assign the pointer to the appropriate procedure. */
- gfc_add_modify (&body, declared,
- fold_convert (TREE_TYPE (declared), tmp));
-
- /* Break to the end of the construct. */
- tmp = build1_v (GOTO_EXPR, end_label);
- gfc_add_expr_to_block (&body, tmp);
-
- /* Free the elists as we go; freeing them in gfc_free_expr causes
- segfaults because it occurs too early and too often. */
- free_elist:
- next_elist = elist->next;
- if (elist->hash_value)
- gfc_free_expr (elist->hash_value);
- gfc_free (elist);
- elist = NULL;
- }
-
- /* Default is an error. */
- label = gfc_build_label_decl (NULL_TREE);
- tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
- NULL_TREE, NULL_TREE, label);
- gfc_add_expr_to_block (&body, tmp);
- tmp = gfc_trans_runtime_error (true, &expr->where,
- "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, hash, tmp, NULL_TREE);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- tmp = build1_v (LABEL_EXPR, end_label);
- gfc_add_expr_to_block (&se->pre, tmp);
-
- se->expr = declared;
- return;
-}
-
-
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
- if (expr && expr->symtree
- && expr->value.function.class_esym)
- {
- if (!sym->backend_decl)
- sym->backend_decl = gfc_get_extern_function_decl (sym);
-
- tmp = sym->backend_decl;
-
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- {
- gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- }
-
- select_class_proc (se, expr->value.function.class_esym,
- tmp, expr);
- return;
- }
-
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, 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));
if (!c->expr || cm->attr.allocatable)
continue;
- if (cm->ts.type == BT_CLASS)
+ if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
{
gfc_component *data;
data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "$extends") == 0)
{
+ tree vtab;
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);
+ vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
else
{
}
+/* Generate code to assign typebound procedures to a derived vtab. */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+ gfc_symbol *vtab)
+{
+ gfc_component *cmp;
+ tree vtb;
+ tree ctree;
+ tree proc;
+ tree cond = NULL_TREE;
+ stmtblock_t body;
+ bool seen_extends;
+
+ /* Point to the first procedure pointer. */
+ cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+
+ seen_extends = (cmp != NULL);
+
+ vtb = gfc_get_symbol_decl (vtab);
+
+ if (seen_extends)
+ {
+ cmp = cmp->next;
+ if (!cmp)
+ return;
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ vtb, cmp->backend_decl, NULL_TREE);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+ build_int_cst (TREE_TYPE (ctree), 0));
+ }
+ else
+ {
+ cmp = vtab->ts.u.derived->components;
+ }
+
+ gfc_init_block (&body);
+ for (; cmp; cmp = cmp->next)
+ {
+ gfc_symbol *target = NULL;
+
+ /* Generic procedure - build its vtab. */
+ if (cmp->ts.type == BT_DERIVED && !cmp->tb)
+ {
+ gfc_symbol *vt = cmp->ts.interface;
+
+ if (vt == NULL)
+ {
+ /* Use association loses the interface. Obtain the vtab
+ by name instead. */
+ char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+ sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
+ cmp->name);
+ gfc_find_symbol (name, vtab->ns, 0, &vt);
+ if (vt == NULL)
+ continue;
+ }
+
+ gfc_trans_assign_vtab_procs (&body, dt, vt);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ vtb, cmp->backend_decl, NULL_TREE);
+ proc = gfc_get_symbol_decl (vt);
+ proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+ gfc_add_modify (&body, ctree, proc);
+ continue;
+ }
+
+ /* This is required when typebound generic procedures are called
+ with derived type targets. The specific procedures do not get
+ added to the vtype, which remains "empty". */
+ if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+ target = cmp->tb->u.specific->n.sym;
+ else
+ {
+ gfc_symtree *st;
+ st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+ if (st->n.tb && st->n.tb->u.specific)
+ target = st->n.tb->u.specific->n.sym;
+ }
+
+ if (!target)
+ continue;
+
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ vtb, cmp->backend_decl, NULL_TREE);
+ proc = gfc_get_symbol_decl (target);
+ proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+ gfc_add_modify (&body, ctree, proc);
+ }
+
+ proc = gfc_finish_block (&body);
+
+ if (seen_extends)
+ proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (block, proc);
+}
+
+
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
{
gfc_symbol *vtab;
gfc_symtree *st;
- vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+ vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
gcc_assert (vtab);
-
+ gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, NULL, 1, &st);
if (ts->type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtab = gfc_find_derived_vtab (ts->u.derived, true);
gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
+/* Generate code to assign typebound procedures to a derived vtab. */
+void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
+
/* Initialize function decls for library functions. */
void gfc_build_intrinsic_lib_fndecls (void);
/* Create function decls for IO library functions. */
+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42274
+ * gfortran.dg/class_16.f03: New test.
+
+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/42274
+ * gfortran.dg/class_15.f03: New.
+
+2010-04-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/43326
+ * gfortran.dg/dynamic_dispatch_9.f03: New test.
+
+2010-04-29 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/43492
+ * gfortran.dg/generic_22.f03 : New test.
+
+2010-04-29 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/42353
+ * gfortran.dg/class_14.f03: New test.
+
+2010-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/42680
+ * gfortran.dg/interface_32.f90: New test.
+
+2009-04-29 Paul Thomas <pault@gcc.gnu.org>
+ Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/41829
+ * gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
+ * gfortran.dg/dynamic_dispatch_7.f03 : New test.
+ * gfortran.dg/dynamic_dispatch_8.f03 : New test.
+
2010-04-28 Mike Stump <mikestump@comcast.net>
* g++.dg/uninit-pred-1_b.C: Use dg-message instead of
--- /dev/null
+! { dg-do "compile" }
+! Test the final fix for PR42353, in which a compilation error was
+! occurring because the derived type of the initializer of the vtab
+! component '$extends' was not the same as that of the component.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+module abstract_vector
+ implicit none
+
+ type, abstract :: vector_class
+ end type vector_class
+end module abstract_vector
+!-------------------------
+module concrete_vector
+ use abstract_vector
+ implicit none
+
+ type, extends(vector_class) :: trivial_vector_type
+ end type trivial_vector_type
+
+ private :: my_assign
+contains
+ subroutine my_assign (this,v)
+ class(trivial_vector_type), intent(inout) :: this
+ class(vector_class), intent(in) :: v
+ end subroutine my_assign
+end module concrete_vector
+!---------------------------
+module concrete_gradient
+ use abstract_vector
+ implicit none
+
+ type, abstract, extends(vector_class) :: gradient_class
+ end type gradient_class
+
+ type, extends(gradient_class) :: trivial_gradient_type
+ end type trivial_gradient_type
+
+ private :: my_assign
+contains
+ subroutine my_assign (this,v)
+ class(trivial_gradient_type), intent(inout) :: this
+ class(vector_class), intent(in) :: v
+ end subroutine my_assign
+end module concrete_gradient
+!----------------------------
+module concrete_inner_product
+ use concrete_vector
+ use concrete_gradient
+ implicit none
+end module concrete_inner_product
+! { dg-final { cleanup-modules "abstract_vector concrete_vector" } }
+! { dg-final { cleanup-modules "concrete_gradient concrete_inner_product" } }
--- /dev/null
+! { dg-do compile }
+!
+! PR 42274: [fortran-dev Regression] ICE: segmentation fault
+!
+! Original test case by Salvatore Filippone <sfilippone@uniroma2.it>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+module mod_A
+ type :: t1
+ contains
+ procedure,nopass :: fun
+ end type
+contains
+ logical function fun()
+ end function
+end module
+
+module mod_B
+ use mod_A
+ type, extends(t1) :: t2
+ contains
+ procedure :: sub1
+ end type
+contains
+ subroutine sub1(a)
+ class(t2) :: a
+ end subroutine
+end module
+
+module mod_C
+contains
+ subroutine sub2(b)
+ use mod_B
+ type(t2) :: b
+ end subroutine
+end module
+
+module mod_D
+ use mod_A
+ use mod_C
+end module
+
+! { dg-final { cleanup-modules "mod_A mod_B mod_C mod_D" } }
--- /dev/null
+! { dg-do compile }
+!
+! PR 43896: [fortran-dev Regression] ICE in gfc_conv_variable, at fortran/trans-expr.c:551
+!
+! Contributed by Fran Martinez Fadrique <fmartinez@gmv.com>
+
+module m_rotation_matrix
+
+ type t_rotation_matrix
+ contains
+ procedure :: array => rotation_matrix_array
+ end type
+
+contains
+
+ function rotation_matrix_array( rot ) result(array)
+ class(t_rotation_matrix) :: rot
+ double precision, dimension(3,3) :: array
+ end function
+
+end module
+
+! { dg-final { cleanup-modules "m_rotation_matrix" } }
-! { dg-do compile }
+! { dg-do run }
! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
- print *, "s_scals"
+! print *, "s_scals"
+ info = 0
call a%a%scal(d,info)
return
end subroutine s_scals
b%a => c
a => b
call a%scal (1.0_spk_, info)
+ if (info .ne. 700) call abort
end
! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
module m1
- type :: t1
- contains
+ type :: t1
+ contains
procedure :: sizeof
end type
contains
sizeof = 1
end function sizeof
end module
-
-
+
module m2
use m1
- type, extends(t1) :: t2
+ type, extends(t1) :: t2
contains
procedure :: sizeof => sizeof2
end type
end function
end module
-
module m3
use m2
type :: t3
- class(t1), pointer :: a
+ class(t1), pointer :: a
contains
procedure :: sizeof => sizeof3
end type
-contains
+contains
integer function sizeof3(a)
class(t3) :: a
sizeof3 = a%a%sizeof()
- end function
+ end function
end module
use m1
if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) call abort
z%a => y
if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) call abort
-
end
! { dg-final { cleanup-modules "m1 m2 m3" } }
-
+
--- /dev/null
+! { dg-do run }
+!
+! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests
+! dynamic dispatch in a case where the caller knows nothing about
+! the dynamic type at compile time.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module foo_mod
+ type foo
+ integer :: i
+ contains
+ procedure, pass(a) :: doit
+ procedure, pass(a) :: getit
+ end type foo
+
+ private doit,getit
+contains
+ subroutine doit(a)
+ class(foo) :: a
+
+ a%i = 1
+! write(*,*) 'FOO%DOIT base version'
+ end subroutine doit
+ function getit(a) result(res)
+ class(foo) :: a
+ integer :: res
+
+ res = a%i
+ end function getit
+
+end module foo_mod
+module foo2_mod
+ use foo_mod
+
+ type, extends(foo) :: foo2
+ integer :: j
+ contains
+ procedure, pass(a) :: doit => doit2
+ procedure, pass(a) :: getit => getit2
+ end type foo2
+
+ private doit2, getit2
+
+contains
+
+ subroutine doit2(a)
+ class(foo2) :: a
+
+ a%i = 2
+ a%j = 3
+! write(*,*) 'FOO2%DOIT derived version'
+ end subroutine doit2
+ function getit2(a) result(res)
+ class(foo2) :: a
+ integer :: res
+
+ res = a%j
+ end function getit2
+
+end module foo2_mod
+
+module bar_mod
+ use foo_mod
+ type bar
+ class(foo), allocatable :: a
+ contains
+ procedure, pass(a) :: doit
+ procedure, pass(a) :: getit
+ end type bar
+ private doit,getit
+
+contains
+ subroutine doit(a)
+ class(bar) :: a
+
+ call a%a%doit()
+ end subroutine doit
+ function getit(a) result(res)
+ class(bar) :: a
+ integer :: res
+
+ res = a%a%getit()
+ end function getit
+end module bar_mod
+
+
+program testd10
+ use foo_mod
+ use foo2_mod
+ use bar_mod
+
+ type(bar) :: a
+
+ allocate(foo :: a%a)
+ call a%doit()
+! write(*,*) 'Getit value : ', a%getit()
+ if (a%getit() .ne. 1) call abort
+ deallocate(a%a)
+ allocate(foo2 :: a%a)
+ call a%doit()
+! write(*,*) 'Getit value : ', a%getit()
+ if (a%getit() .ne. 3) call abort
+
+end program testd10
+
+! { dg-final { cleanup-modules "foo_mod foo2_mod bar_mod" } }
+
--- /dev/null
+! { dg-do run }
+!
+! [OOP] Ensure that different specifc interfaces are
+! handled properly by dynamic dispatch.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module m
+
+ type :: t
+ contains
+ procedure :: a
+ generic :: gen => a
+ end type
+
+ type,extends(t) :: t2
+ contains
+ procedure :: b
+ generic :: gen => b
+ end type
+
+contains
+
+ real function a(ct,x)
+ class(t) :: ct
+ real :: x
+ a=2*x
+ end function
+
+ integer function b(ct,x)
+ class(t2) :: ct
+ integer :: x
+ b=3*x
+ end function
+
+end
+
+
+ use m
+ class(t), allocatable :: o1
+ type (t) :: t1
+ class(t2), allocatable :: o2
+
+ allocate(o1)
+ allocate(o2)
+
+ if (t1%gen(2.0) .ne. o1%gen(2.0)) call abort
+ if (t1%gen(2.0) .ne. o2%gen(2.0)) call abort
+ if (o2%gen(3) .ne. 9) call abort
+
+end
+
+! { dg-final { cleanup-modules "m" } }
+
--- /dev/null
+! { dg-do compile }
+! Test the fix for PR43492, in which the generic call caused and ICE.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module base_mod
+
+ type :: base_mat
+ integer, private :: m, n
+ contains
+ procedure, pass(a) :: transp1 => base_transp1
+ generic, public :: transp => transp1
+ procedure, pass(a) :: transc1 => base_transc1
+ generic, public :: transc => transc1
+ end type base_mat
+
+contains
+
+ subroutine base_transp1(a)
+ implicit none
+
+ class(base_mat), intent(inout) :: a
+ integer :: itmp
+ itmp = a%m
+ a%m = a%n
+ a%n = itmp
+ end subroutine base_transp1
+ subroutine base_transc1(a)
+ implicit none
+ class(base_mat), intent(inout) :: a
+
+ call a%transp()
+!!$ call a%transp1()
+ end subroutine base_transc1
+
+
+end module base_mod
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do compile }
+module m1
+ implicit none
+
+ type, abstract :: vector_class
+ end type vector_class
+end module m1
+!---------------------------------------------------------------
+module m2
+ use m1
+ implicit none
+
+ type, abstract :: inner_product_class
+ contains
+ procedure(dot), deferred :: dot_v_v
+ procedure(dot), deferred :: dot_g_g
+ procedure(sub), deferred :: D_times_v
+ procedure(sub), deferred :: D_times_g
+ end type inner_product_class
+
+ abstract interface
+ function dot (this,a,b)
+ import :: inner_product_class
+ import :: vector_class
+ class(inner_product_class), intent(in) :: this
+ class(vector_class), intent(in) :: a,b
+ real :: dot
+ end function
+ subroutine sub (this,a)
+ import :: inner_product_class
+ import :: vector_class
+ class(inner_product_class), intent(in) :: this
+ class(vector_class), intent(inout) :: a
+ end subroutine
+ end interface
+end module m2
+!---------------------------------------------------------------
+module m3
+ use :: m1
+ use :: m2
+ implicit none
+ private
+ public :: gradient_class
+
+ type, abstract, extends(vector_class) :: gradient_class
+ class(inner_product_class), pointer :: my_inner_product => NULL()
+ contains
+ procedure, non_overridable :: inquire_inner_product
+ procedure(op_g_v), deferred :: to_vector
+ end type gradient_class
+
+ abstract interface
+ subroutine op_g_v(this,v)
+ import vector_class
+ import gradient_class
+ class(gradient_class), intent(in) :: this
+ class(vector_class), intent(inout) :: v
+ end subroutine
+ end interface
+contains
+ function inquire_inner_product (this)
+ class(gradient_class) :: this
+ class(inner_product_class), pointer :: inquire_inner_product
+
+ inquire_inner_product => this%my_inner_product
+ end function inquire_inner_product
+end module m3
+!---------------------------------------------------------------
+module m4
+ use m3
+ use m2
+ implicit none
+contains
+ subroutine cg (g_initial)
+ class(gradient_class), intent(in) :: g_initial
+
+ class(inner_product_class), pointer :: ip_save
+ ip_save => g_initial%inquire_inner_product()
+ end subroutine cg
+end module m4
+! { dg-final { cleanup-modules "m1 m2 m3 m4" } }
OSDN Git Service
