- return fcn ? 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 void check_class_members (gfc_symbol *);
-static gfc_try class_try;
-static bool fcn_flag;
-static gfc_symbol *class_object;
-
-
-static void
-check_members (gfc_symbol *derived)
-{
- if (derived->attr.flavor == FL_DERIVED)
- check_class_members (derived);
-}
-
-
-static void
-check_class_members (gfc_symbol *derived)
-{
- gfc_symbol* tbp_sym;
- 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;
- }
-
- if (tbp->n.tb->is_generic)
- {
- tbp_sym = NULL;
-
- /* 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);
-
- e->value.compcall.base_object->ts.type = BT_DERIVED;
- e->value.compcall.base_object->ts.u.derived = derived;
- }
- }
- else
- tbp_sym = tbp->n.tb->u.specific->n.sym;
-
- 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) == 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);
-}
-
-
-/* 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 vindex, 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)
-{
- gfc_expr *vindex;
- gfc_ref *ref;
-
- /* Build an expression for the correct vindex; 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;
- }
- else
- {
- gfc_free_ref_list (new_ref);
- new_ref = ref;
- }
- 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;
-
- return vindex;