This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [OOP] SELECT TYPE with CLASS IS
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: "Rouson, Damian" <rouson at sandia dot gov>
- Cc: "dominiq at lps dot ens dot fr" <dominiq at lps dot ens dot fr>, "janus at gcc dot gnu dot org" <janus at gcc dot gnu dot org>, "salvatore dot filippone at uniroma2 dot it" <salvatore dot filippone at uniroma2 dot it>, "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>
- Date: Sun, 8 Nov 2009 19:42:39 +0100
- Subject: Re: [OOP] SELECT TYPE with CLASS IS
- References: <20091108140201.547F53BE85@mailhost.lps.ens.fr> <C71C44BC.A004%rouson@sandia.gov>
Dear All,
Just to keep you up to date, I have attached the working version of my
patch, relative to trunk, to fix PR41289 and to implement a form of
vtables. It does away completely with the previous form of dynamic
dispatch and replaces it with proc pointer calls from components of
the derived type vtab.
It breaks more than it fixes, at present!
(i) abstract types are broken again - both class_10.f03 and class_12.f03 ICE;
(ii) I still have not found a satisfactory way of dealing with generic
typebound procedures, with the result that dynamic_dispatch_[n].f03 is
broken.
This latter occurs when one specific in the generic is over-ridden by
a specific with a different name; eg. line 76 in
dynamic_dispatch_1.f03.
On the bright side, the testcases in PR41829 now work :-)
Cheers
Paul
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 153993)
--- gcc/fortran/trans-expr.c (working copy)
*************** get_proc_ptr_comp (gfc_expr *e)
*** 1524,1660 ****
}
- /* 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 vindex;
- stmtblock_t body;
- gfc_class_esym_list *next_elist, *tmp_elist;
- gfc_se tmpse;
-
- /* Convert the vindex expression. */
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, elist->vindex);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- vindex = 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;
-
- /* 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 (vindex),
- elist->derived->vindex);
- /* Build a label for the vindex 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->vindex)
- gfc_free_expr (elist->vindex);
- 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 vindex 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);
- 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)
--- 1524,1535 ----
*************** conv_arglist_function (gfc_se *se, gfc_e
*** 2533,2538 ****
--- 2408,2468 ----
}
+ /* 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);
+ gfc_trans_assign_vtab_procs (&parmse->pre, 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);
+ }
+
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2776,2828 ****
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);
}
else if (se->ss && se->ss->useflags)
{
--- 2706,2715 ----
else if (fsym && fsym->ts.type == BT_CLASS
&& e->ts.type == BT_DERIVED)
{
/* The derived type needs to be converted to a temporary
CLASS object. */
gfc_init_se (&parmse, se);
! gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
else if (se->ss && se->ss->useflags)
{
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 4213,4226 ****
if (cm->ts.type == BT_CLASS)
{
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);
! /* Append it to the constructor list. */
! CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl,
! val);
}
else
{
--- 4100,4127 ----
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 (data->backend_decl),
! data->attr.dimension,
! data->attr.pointer);
! 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)
! {
! tree vtab = NULL_TREE;
! gfc_symbol *vtabs;
! vtabs = cm->initializer->symtree->n.sym;
! vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
! CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
}
else
{
*************** gfc_trans_assign (gfc_code * code)
*** 5331,5336 ****
--- 5232,5278 ----
}
+ /* Generate code to assign typebound procedures to a derived vtab. */
+ void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *vtab)
+ {
+ gfc_component *cmp;
+ tree vtb;
+ tree ctree;
+ tree proc;
+ tree cond;
+ stmtblock_t body;
+
+ /* Point to the first procedure pointer. */
+ cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+ cmp = cmp->next;
+
+ if (cmp == NULL)
+ return;
+
+ vtb = gfc_get_symbol_decl (vtab);
+
+ 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));
+
+ gfc_init_block (&body);
+ for (; cmp; cmp = cmp->next)
+ {
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ vtb, cmp->backend_decl, NULL_TREE);
+
+ proc = gfc_get_symbol_decl (cmp->tb->u.specific->n.sym);
+ proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+ gfc_add_modify (&body, ctree, proc);
+ }
+
+ proc = gfc_finish_block (&body);
+ 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_trans_class_assign (gfc_code *code)
*** 5339,5385 ****
{
stmtblock_t block;
tree tmp;
gfc_start_block (&block);
if (code->expr2->ts.type != BT_CLASS)
{
! /* Insert an additional assignment which sets the '$vindex' field. */
! gfc_expr *lhs,*rhs;
! 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");
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));
}
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);
! }
else
gcc_unreachable ();
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
--- 5281,5317 ----
{
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 '$vptr' field. */
lhs = gfc_copy_expr (code->expr1);
! gfc_add_component_ref (lhs, "$vptr");
if (code->expr2->ts.type == BT_DERIVED)
{
! gfc_symbol *vtab;
! gfc_symtree *st;
! vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
! gcc_assert (vtab);
! gfc_trans_assign_vtab_procs (&block, 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);
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);
}
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 153993)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_save (symbol_attribute *attr, co
*** 1045,1051 ****
return FAILURE;
}
! if (attr->save == SAVE_EXPLICIT)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
--- 1045,1051 ----
return FAILURE;
}
! if (attr->save == SAVE_EXPLICIT && !attr->vtab)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate SAVE attribute specified at %L",
*************** gfc_type_is_extension_of (gfc_symbol *t1
*** 4592,4613 ****
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))
{
! 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
return 0;
}
else
! return (ts1->type == ts2->type);
}
--- 4592,4916 ----
bool
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
{
! 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)
{
! 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 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, bool delayed_vtab)
! {
! 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;
! if (delayed_vtab)
! c->ts.u.derived = NULL;
! else
! {
! 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;
! }
!
! 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;
! }
!
!
! static void
! add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
! {
! gfc_component *c;
!
! if (st->left)
! add_procs_to_declared_vtab1 (st->left, vtype);
!
! if (st->right)
! add_procs_to_declared_vtab1 (st->right, vtype);
!
! if (!st->n.tb->is_generic && st->n.tb->u.specific)
! {
! c = gfc_find_component (vtype, st->name, true, true);
!
! if (c == NULL)
! {
! /* Add procedure component. */
! if (gfc_add_component (vtype, st->name, &c) == FAILURE)
! return;
! c->tb = XCNEW (gfc_typebound_proc);
! *c->tb = *st->n.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 = st->n.tb->u.specific->n.sym;
! 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 = gfc_get_expr ();
! c->initializer->expr_type = EXPR_NULL;
! }
! else if (c->attr.proc_pointer && c->tb)
! {
! *c->tb = *st->n.tb;
! c->ts.interface = st->n.tb->u.specific->n.sym;
! }
! }
! }
!
!
! static void
! copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
! {
! gfc_component *c, *cmp;
! gfc_symbol *vtab;
!
! vtab = gfc_find_derived_vtab (declared);
!
! 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;
!
! 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->tb->u.specific->n.sym;
! c->attr.untyped = 1;
! c->attr.if_source = IFSRC_IFBODY;
! c->initializer = gfc_get_expr ();
! c->initializer->expr_type = EXPR_NULL;
! }
! }
!
! static void
! add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
! gfc_symbol *derived)
! {
! 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);
!
! if (declared != derived)
! copy_vtab_proc_comps (declared, vtype);
!
! if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
! add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root, vtype);
!
! if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
! add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root, vtype);
! }
!
!
! /* 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;
! }
! add_procs_to_declared_vtab (derived, vtype, derived);
! vtype->attr.vtype = 1;
! }
!
! vtab->ts.u.derived = vtype;
! vtab->value = gfc_default_initializer (&vtab->ts);
! }
! }
!
! return vtab;
}
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 153993)
--- gcc/fortran/decl.c (working copy)
*************** verify_c_interop_param (gfc_symbol *sym)
*** 1025,1112 ****
}
- /* 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. */
--- 1025,1030 ----
*************** build_sym (const char *name, gfc_charlen
*** 1185,1191 ****
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
! encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
return SUCCESS;
--- 1103,1109 ----
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, false);
}
return SUCCESS;
*************** build_struct (const char *name, gfc_char
*** 1594,1600 ****
scalar:
if (c->ts.type == BT_CLASS)
! encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
--- 1512,1518 ----
scalar:
if (c->ts.type == BT_CLASS)
! gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
return t;
}
*************** gfc_match_derived_decl (void)
*** 6943,6951 ****
st->n.sym = sym;
}
! if (!sym->vindex)
! /* Set the vindex for this type. */
! sym->vindex = hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;
--- 6861,6869 ----
st->n.sym = 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;
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c (revision 153993)
--- gcc/fortran/dump-parse-tree.c (working copy)
*************** show_symbol (gfc_symbol *sym)
*** 827,834 ****
if (sym->f2k_derived)
{
show_indent ();
! if (sym->vindex)
! fprintf (dumpfile, "vindex: %d", sym->vindex);
show_f2k_derived (sym->f2k_derived);
}
--- 827,834 ----
if (sym->f2k_derived)
{
show_indent ();
! if (sym->hash_value)
! fprintf (dumpfile, "hash: %d", sym->hash_value);
show_f2k_derived (sym->f2k_derived);
}
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 153993)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 673,678 ****
--- 673,680 ----
unsigned extension:1; /* extends 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, 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
*************** typedef struct gfc_symbol
*** 1137,1144 ****
int entry_id; /* Used in resolve.c for entries. */
! /* CLASS vindex for declared and dynamic types in the class. */
! int vindex;
struct gfc_symbol *common_next; /* Links for COMMON syms */
--- 1139,1146 ----
int entry_id; /* Used in resolve.c for entries. */
! /* CLASS hashed name for declared and dynamic types in the class. */
! int hash_value;
struct gfc_symbol *common_next; /* Links for COMMON syms */
*************** typedef struct gfc_intrinsic_sym
*** 1595,1611 ****
gfc_intrinsic_sym;
- typedef struct gfc_class_esym_list
- {
- gfc_symbol *derived;
- gfc_symbol *esym;
- struct gfc_expr *vindex;
- 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:
--- 1597,1602 ----
*************** typedef struct gfc_expr
*** 1718,1724 ****
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;
--- 1709,1714 ----
*************** gfc_try gfc_check_any_c_kind (gfc_typesp
*** 2380,2385 ****
--- 2370,2376 ----
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;
*************** void gfc_free_dt_list (void);
*** 2517,2522 ****
--- 2508,2516 ----
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 **, bool);
+ 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*);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 153993)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4029,4034 ****
--- 4029,4035 ----
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_trans_allocate (gfc_code * code)
*** 4124,4165 ****
{
gfc_expr *lhs,*rhs;
gfc_se lse;
! /* Initialize VINDEX for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
! gfc_add_component_ref (lhs, "$vindex");
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
! /* vindex must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
! gfc_add_component_ref (rhs, "$vindex");
}
else
{
! /* vindex is fixed at compile time. */
! int vindex;
if (code->expr3)
! vindex = code->expr3->ts.u.derived->vindex;
else if (code->ext.alloc.ts.type == BT_DERIVED)
! vindex = code->ext.alloc.ts.u.derived->vindex;
else if (expr->ts.type == BT_CLASS)
! vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
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);
! /* 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);
}
}
--- 4125,4174 ----
{
gfc_expr *lhs,*rhs;
gfc_se lse;
!
! /* Initialize VPTR for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
! gfc_add_component_ref (lhs, "$vptr");
! rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
! /* VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
! 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
{
! /* VPTR is fixed at compile time. */
! gfc_symbol *vtab;
! gfc_typespec *ts;
if (code->expr3)
! ts = &code->expr3->ts;
! else if (expr->ts.type == BT_DERIVED)
! ts = &expr->ts;
else if (code->ext.alloc.ts.type == BT_DERIVED)
! ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
! ts = &expr->ts.u.derived->components->ts;
else
! ts = &expr->ts;
! if (ts->type == BT_DERIVED)
! {
! vtab = gfc_find_derived_vtab (ts->u.derived);
! gcc_assert (vtab);
! gfc_trans_assign_vtab_procs (&block, 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));
! }
! }
}
}
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 153993)
--- gcc/fortran/module.c (working copy)
*************** mio_symbol (gfc_symbol *sym)
*** 3575,3581 ****
mio_integer (&(sym->intmod_sym_id));
if (sym->attr.flavor == FL_DERIVED)
! mio_integer (&(sym->vindex));
mio_rparen ();
}
--- 3575,3581 ----
mio_integer (&(sym->intmod_sym_id));
if (sym->attr.flavor == FL_DERIVED)
! mio_integer (&(sym->hash_value));
mio_rparen ();
}
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 153993)
--- gcc/fortran/trans-types.c (working copy)
*************** along with GCC; see the file COPYING3.
*** 53,60 ****
/* 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;
--- 53,58 ----
*************** gfc_get_ppc_type (gfc_component* c)
*** 1941,1947 ****
at the same time. If an equal derived type has been built
in a parent namespace, this is used. */
! static tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
--- 1939,1945 ----
at the same time. If an equal derived type has been built
in a parent namespace, this is used. */
! tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 153993)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_trans_assignment (gfc_expr *, g
*** 490,495 ****
--- 490,498 ----
/* 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*);
+
/* Initialize function decls for library functions. */
void gfc_build_intrinsic_lib_fndecls (void);
/* Create function decls for IO library functions. */
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 153993)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_typebound_static (gfc_expr* e, g
*** 4919,4925 ****
the expression into a call of that binding. */
static gfc_try
! resolve_typebound_generic_call (gfc_expr* e)
{
gfc_typebound_proc* genproc;
const char* genname;
--- 4919,4925 ----
the expression into a call of that binding. */
static gfc_try
! resolve_typebound_generic_call (gfc_expr* e, const char **name)
{
gfc_typebound_proc* genproc;
const char* genname;
*************** resolve_typebound_generic_call (gfc_expr
*** 4975,4980 ****
--- 4975,4984 ----
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->u.specific->name;
goto success;
}
}
*************** success:
*** 4993,4999 ****
/* Resolve a call to a type-bound subroutine. */
static gfc_try
! resolve_typebound_call (gfc_code* c)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
--- 4997,5003 ----
/* Resolve a call to a type-bound subroutine. */
static gfc_try
! resolve_typebound_call (gfc_code* c, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
*************** resolve_typebound_call (gfc_code* c)
*** 5009,5015 ****
if (check_typebound_baseobject (c->expr1) == FAILURE)
return FAILURE;
! if (resolve_typebound_generic_call (c->expr1) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
--- 5013,5024 ----
if (check_typebound_baseobject (c->expr1) == FAILURE)
return 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_typebound_call (gfc_code* c)
*** 5033,5063 ****
}
! /* 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. */
static gfc_try
! resolve_compcall (gfc_expr* e, bool fcn)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
! if (fcn && !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);
--- 5042,5061 ----
}
! /* Resolve a component-call expression. */
static gfc_try
! resolve_compcall (gfc_expr* e, const char **name)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
! if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5065,5071 ****
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
! if (resolve_typebound_generic_call (e) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
--- 5063,5074 ----
if (check_typebound_baseobject (e) == FAILURE)
return 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);
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5082,5088 ****
e->value.function.actual = newactual;
e->value.function.name = e->value.compcall.name;
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;
--- 5085,5090 ----
*************** resolve_compcall (gfc_expr* e, bool fcn)
*** 5091,5264 ****
/* 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 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;
}
/* 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)
--- 5093,5106 ----
/* 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);
}
/* 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)
*************** get_declared_from_expr (gfc_ref **class_
*** 5289,5321 ****
}
- /* 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 CLASS typebound function, or 'method'. */
static gfc_try
resolve_class_compcall (gfc_expr* e)
{
! gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
st = e->symtree;
- class_object = st->n.sym;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
--- 5131,5148 ----
}
/* Resolve a CLASS typebound function, or 'method'. */
+
static gfc_try
resolve_class_compcall (gfc_expr* e)
{
! gfc_symbol *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
st = e->symtree;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
*************** resolve_class_compcall (gfc_expr* e)
*** 5324,5376 ****
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
! return resolve_compcall (e, true);
}
! /* Resolve the argument expressions, */
! resolve_arg_exprs (e->value.function.actual);
!
! /* Get the data component, which is of the declared type. */
! derived = declared->components->ts.u.derived;
!
! /* Resolve the function call for each member of the class. */
! class_try = SUCCESS;
! fcn_flag = true;
! list_e = gfc_copy_expr (e);
! check_class_members (derived);
! class_try = (resolve_compcall (e, true) == SUCCESS)
! ? class_try : FAILURE;
! /* 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);
! /* More than one typebound procedure so transmit an expression for
! the vindex as the selector. */
! if (e->value.function.class_esym != NULL)
! e->value.function.class_esym->vindex
! = vindex_expr (class_ref, new_ref, declared, st);
! return class_try;
}
/* Resolve a CLASS typebound subroutine, or 'method'. */
static gfc_try
resolve_class_typebound_call (gfc_code *code)
{
! gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
st = code->expr1->symtree;
- class_object = st->n.sym;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
--- 5151,5191 ----
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
! return resolve_compcall (e, NULL);
}
! /* 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);
! /* Then convert the expression to a procedure pointer component call. */
! e->value.function.esym = NULL;
! e->symtree = st;
! 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");
! gfc_add_component_ref (e, name);
! return SUCCESS;
}
/* Resolve a CLASS typebound subroutine, or 'method'. */
static gfc_try
resolve_class_typebound_call (gfc_code *code)
{
! gfc_symbol *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
+ const char *name;
st = code->expr1->symtree;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
*************** resolve_class_typebound_call (gfc_code *
*** 5379,5418 ****
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
! return resolve_typebound_call (code);
}
! /* 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;
! class_try = SUCCESS;
! fcn_flag = false;
! list_e = gfc_copy_expr (code->expr1);
! check_class_members (derived);
!
! class_try = (resolve_typebound_call (code) == SUCCESS)
! ? class_try : FAILURE;
!
! /* 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);
!
! resolve_class_esym (code->expr1);
!
! /* More than one typebound procedure so transmit an expression for
! the vindex 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);
! return class_try;
}
--- 5194,5219 ----
if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
{
gfc_free_ref_list (new_ref);
! return resolve_typebound_call (code, NULL);
}
! resolve_typebound_call (code, &name);
! /* 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");
! gfc_add_component_ref (code->expr1, name);
! return SUCCESS;
}
*************** gfc_resolve_expr (gfc_expr *e)
*** 5529,5535 ****
if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
t = resolve_class_compcall (e);
else
! t = resolve_compcall (e, true);
break;
case EXPR_SUBSTRING:
--- 5330,5336 ----
if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
t = resolve_class_compcall (e);
else
! t = resolve_compcall (e, NULL);
break;
case EXPR_SUBSTRING:
*************** resolve_select_type (gfc_code *code)
*** 6944,6957 ****
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
! gfc_add_component_ref (code->expr1, "$vindex");
/* 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. */
--- 6745,6759 ----
/* Transform to EXEC_SELECT. */
code->op = EXEC_SELECT;
! 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->hash_value);
else if (c->ts.type == BT_CLASS)
/* Currently IS CLASS blocks are simply ignored.
TODO: Implement IS CLASS. */
*************** resolve_code (gfc_code *code, gfc_namesp
*** 7942,7948 ****
&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
resolve_class_typebound_call (code);
else
! resolve_typebound_call (code);
break;
case EXEC_CALL_PPC:
--- 7744,7750 ----
&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
resolve_class_typebound_call (code);
else
! resolve_typebound_call (code, NULL);
break;
case EXEC_CALL_PPC:
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10226,10231 ****
--- 10028,10036 ----
{
gfc_symbol* me_arg;
+ if (c->ts.interface && c->ts.interface->formal && !c->formal)
+ c->formal = c->ts.interface->formal;
+
if (c->tb->pass_arg)
{
gfc_formal_arglist* i;
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10274,10280 ****
gcc_assert (me_arg);
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
! || (me_arg->ts.type == BT_CLASS
&& me_arg->ts.u.derived->components->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
--- 10079,10085 ----
gcc_assert (me_arg);
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
! || (!sym->attr.vtype && me_arg->ts.type == BT_CLASS
&& me_arg->ts.u.derived->components->ts.u.derived != sym))
{
gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 153993)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_create_module_variable (gfc_symbol *
*** 3405,3411 ****
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
! if (sym->backend_decl)
internal_error ("backend decl for module variable %s already exists",
sym->name);
--- 3405,3411 ----
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
! if (sym->backend_decl && !sym->attr.vtab)
internal_error ("backend decl for module variable %s already exists",
sym->name);
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 153993)
--- gcc/fortran/parse.c (working copy)
*************** endType:
*** 2091,2096 ****
--- 2091,2112 ----
|| 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);
+ gcc_assert (vtab);
+ vptr->ts.u.derived = vtab->ts.u.derived;
+ }
+ }
}
if (!seen_component)
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 153993)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_same_type_as (gfc_se *se, gfc_e
*** 4721,4734 ****
b = expr->value.function.actual->next->expr;
if (a->ts.type == BT_CLASS)
! gfc_add_component_ref (a, "$vindex");
else if (a->ts.type == BT_DERIVED)
! a = gfc_int_expr (a->ts.u.derived->vindex);
if (b->ts.type == BT_CLASS)
! gfc_add_component_ref (b, "$vindex");
else if (b->ts.type == BT_DERIVED)
! b = gfc_int_expr (b->ts.u.derived->vindex);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);
--- 4721,4740 ----
b = expr->value.function.actual->next->expr;
if (a->ts.type == BT_CLASS)
! {
! 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->hash_value);
if (b->ts.type == BT_CLASS)
! {
! 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->hash_value);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);