+ /* 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 void 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)
+ check_class_members (derived);
+}
+
+
+static void
+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;
+ }
+
+ /* 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 (!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);
+}
+
+
+/* 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;
+}
+
+
+/* Get the ultimate declared type from an expression. In addition,
+ return the last class/derived type reference and the copy of the
+ reference list. */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+ gfc_expr *e)
+{
+ gfc_symbol *declared;
+ gfc_ref *ref;
+
+ declared = NULL;
+ *class_ref = NULL;
+ *new_ref = gfc_copy_ref (e->ref);
+ for (ref = *new_ref; ref; ref = ref->next)
+ {
+ if (ref->type != REF_COMPONENT)
+ continue;
+
+ if (ref->u.c.component->ts.type == BT_CLASS
+ || ref->u.c.component->ts.type == BT_DERIVED)
+ {
+ declared = ref->u.c.component->ts.u.derived;
+ *class_ref = ref;
+ }
+ }
+
+ if (declared == NULL)
+ declared = e->symtree->n.sym->ts.u.derived;
+
+ return declared;
+}
+
+
+/* Resolve a typebound function, or 'method'. First separate all
+ the non-CLASS references by calling resolve_compcall directly. */
+
+/* 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. */
+
+static gfc_try
+resolve_typebound_function (gfc_expr* e)
+{
+ 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);
+
+ /* 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))
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_compcall (e, true, false);
+ }
+
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->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;
+
+ /* 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;
+
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ e->ref = new_ref;
+ }
+
+ /* '$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);
+
+ /* 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. */
+
+static gfc_try
+resolve_typebound_subroutine (gfc_code *code)
+{
+ 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);
+
+ /* 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))
+ {
+ gfc_free_ref_list (new_ref);
+ return resolve_typebound_call (code, NULL);
+ }
+
+ c = gfc_find_component (declared, "$data", true, true);
+ declared = c->ts.u.derived;
+
+ /* 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;
+
+ resolve_typebound_call (code, &name);
+ ts = code->expr1->ts;
+
+ /* Then convert the expression to a procedure pointer component call. */
+ code->expr1->value.function.esym = NULL;
+ code->expr1->symtree = st;
+
+ if (class_ref)
+ {
+ gfc_free_ref_list (class_ref->next);
+ code->expr1->ref = new_ref;
+ }
+
+ /* '$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);
+
+ /* 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;