This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR41829 - vtables for fortran - fortran-dev to trunk port
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 27 Apr 2010 20:56:11 +0200
- Subject: [Patch, fortran] PR41829 - vtables for fortran - fortran-dev to trunk port
This patch transfers the vtable implementation of OOP from fortran-dev
to trunk. It is by no means complete or bug free but all the
regressions to date have been fixed. We will work on it in the coming
months to deal with the remaining PRs and to implement unlimited
polymorphic objects. In the mean time, fortran-dev is freed up for
array descriptor development.
The most awkward part, in symbol.c, was implementing generic typebound
procedures or 'methods' for CLASS objects.
Bootstraps and regtests on FC9/x86_64 - OK for trunk?
Paul and Janus
2010-04-27 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-27 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-27 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-27 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-27 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-27 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-27 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-27 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-27 Janus Weil <janus@gcc.gnu.org>
PR fortran/42274
* gfortran.dg/class_16.f03: New test.
2010-04-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/43326
* gfortran.dg/dynamic_dispatch_9.f03: Was dynamic_dispatch_7.
2009-04-27 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.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 158765)
--- gcc/fortran/interface.c (working copy)
*************** check_interface1 (gfc_interface *p, gfc_
*** 1129,1136 ****
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 (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
--- 1129,1136 ----
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 (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 158765)
--- gcc/fortran/trans-expr.c (working copy)
*************** get_proc_ptr_comp (gfc_expr *e)
*** 1532,1672 ****
}
- /* 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)
--- 1532,1542 ----
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 2614,2621 ****
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
! vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
--- 2484,2492 ----
/* Remember the vtab corresponds to the derived type
not to the class declared type. */
! 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));
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 4463,4469 ****
if (!c->expr || cm->attr.allocatable)
continue;
! if (cm->ts.type == BT_CLASS)
{
gfc_component *data;
data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
--- 4334,4340 ----
if (!c->expr || cm->attr.allocatable)
continue;
! if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
{
gfc_component *data;
data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
*************** gfc_conv_structure (gfc_se * se, gfc_exp
*** 4484,4493 ****
else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
&& strcmp (cm->name, "$extends") == 0)
{
gfc_symbol *vtabs;
vtabs = cm->initializer->symtree->n.sym;
! val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
! CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
else
{
--- 4355,4365 ----
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)
*** 5579,5584 ****
--- 5451,5553 ----
}
+ /* 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_trans_class_assign (gfc_code *code)
*** 5620,5628 ****
{
gfc_symbol *vtab;
gfc_symtree *st;
! vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
gcc_assert (vtab);
!
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, NULL, 1, &st);
--- 5589,5597 ----
{
gfc_symbol *vtab;
gfc_symtree *st;
! 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);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 158765)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_type_compatible (gfc_typespec *ts1,
*** 4708,4714 ****
gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
! gfc_array_spec **as)
{
char name[GFC_MAX_SYMBOL_LEN + 5];
gfc_symbol *fclass;
--- 4708,4714 ----
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_build_class_symbol (gfc_typespec *ts
*** 4763,4771 ****
if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_DERIVED;
! vtab = gfc_find_derived_vtab (ts->u.derived);
! gcc_assert (vtab);
! c->ts.u.derived = vtab->ts.u.derived;
c->attr.pointer = 1;
}
--- 4763,4776 ----
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, false);
! gcc_assert (vtab);
! c->ts.u.derived = vtab->ts.u.derived;
! }
c->attr.pointer = 1;
}
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 4787,4796 ****
}
! /* 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;
--- 4792,5135 ----
}
! 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, bool resolved)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL;
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 4815,4821 ****
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);
--- 5154,5159 ----
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 4832,4838 ****
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)
--- 5170,5175 ----
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 4864,4876 ****
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 = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
! gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
! &c->initializer->symtree);
}
else
{
--- 5201,5213 ----
parent = gfc_get_derived_super_type (derived);
if (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);
}
else
{
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 4878,4890 ****
c->ts.u.derived = vtype;
c->initializer = gfc_get_null_expr (NULL);
}
}
- vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
}
return vtab;
}
--- 5215,5239 ----
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->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;
}
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 158765)
--- gcc/fortran/decl.c (working copy)
*************** build_sym (const char *name, gfc_charlen
*** 1160,1166 ****
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);
}
return SUCCESS;
--- 1160,1166 ----
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
*** 1570,1576 ****
scalar:
if (c->ts.type == BT_CLASS)
! gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
--- 1570,1576 ----
scalar:
if (c->ts.type == BT_CLASS)
! gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
return t;
}
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 158765)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 691,697 ****
unsigned extension:8; /* extension level of a derived type. */
unsigned is_class:1; /* is a CLASS container. */
unsigned class_ok:1; /* is a CLASS object with correct attributes. */
! unsigned vtab:1; /* is a derived type vtab. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
--- 691,698 ----
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, 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_intrinsic_sym
*** 1615,1631 ****
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:
--- 1616,1621 ----
*************** typedef struct gfc_expr
*** 1717,1723 ****
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;
--- 1707,1712 ----
*************** gfc_gsymbol *gfc_get_gsymbol (const char
*** 2526,2533 ****
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
! gfc_array_spec **);
! gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
--- 2515,2522 ----
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 *, 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*);
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 158765)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4278,4285 ****
if (ts->type == BT_DERIVED)
{
! vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
--- 4278,4286 ----
if (ts->type == BT_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);
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c (revision 158765)
--- gcc/fortran/module.c (working copy)
*************** typedef enum
*** 1674,1680 ****
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_attribute;
--- 1674,1680 ----
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_VTYPE, AB_VTAB
}
ab_attribute;
*************** static const mstring attr_bits[] =
*** 1720,1725 ****
--- 1720,1727 ----
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_symbol_attribute (symbol_attribute *
*** 1880,1885 ****
--- 1882,1891 ----
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 ();
*************** mio_symbol_attribute (symbol_attribute *
*** 2016,2021 ****
--- 2022,2033 ----
case AB_PROC_POINTER:
attr->proc_pointer = 1;
break;
+ case AB_VTYPE:
+ attr->vtype = 1;
+ break;
+ case AB_VTAB:
+ attr->vtab = 1;
+ break;
}
}
}
*************** check_for_ambiguous (gfc_symbol *st_sym,
*** 4201,4206 ****
--- 4213,4221 ----
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
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 158765)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_trans_assignment (gfc_expr *, g
*** 492,497 ****
--- 492,500 ----
/* 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. */
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 158765)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_structure_cons (gfc_expr *expr)
*** 898,904 ****
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
! 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,
--- 898,912 ----
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
! 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,
*************** resolve_global_procedure (gfc_symbol *sy
*** 1874,1886 ****
/* 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)
{
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)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
--- 1882,1893 ----
/* Non-assumed length character functions. */
if (sym->attr.function && sym->ts.type == BT_CHARACTER
! && 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)
{
gfc_error ("Nonconstant character-length function '%s' at %L "
"must have an explicit interface", sym->name,
*************** resolve_typebound_static (gfc_expr* e, g
*** 5121,5127 ****
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;
--- 5128,5134 ----
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
*** 5177,5182 ****
--- 5184,5193 ----
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;
}
}
*************** success:
*** 5195,5201 ****
/* Resolve a call to a type-bound subroutine. */
static gfc_try
! resolve_typebound_call (gfc_code* c)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
--- 5206,5212 ----
/* 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)
*** 5211,5217 ****
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. */
--- 5222,5233 ----
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)
*** 5235,5265 ****
}
! /* 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, bool class_members)
{
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);
--- 5251,5270 ----
}
! /* 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,
*** 5267,5273 ****
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);
--- 5272,5283 ----
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,
*** 5284,5452 ****
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;
}
--- 5294,5308 ----
e->value.function.actual = newactual;
e->value.function.name = NULL;
e->value.function.esym = target->n.sym;
e->value.function.isym = NULL;
e->symtree = target;
e->ts = target->n.sym->ts;
e->expr_type = EXPR_FUNCTION;
! /* 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_declared_from_expr (gfc_ref **class_
*** 5483,5628 ****
}
! /* 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. */
static gfc_try
resolve_typebound_function (gfc_expr* e)
{
! gfc_symbol *derived, *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
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);
}
! /* 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);
!
! if (check_class_members (derived) == FAILURE)
! return FAILURE;
! class_try = (resolve_compcall (e, true, false) == 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 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);
! return class_try;
}
! /* 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 *derived, *declared;
gfc_ref *new_ref;
gfc_ref *class_ref;
gfc_symtree *st;
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);
}
! /* 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);
!
! if (check_class_members (derived) == FAILURE)
! return FAILURE;
! 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 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);
! return class_try;
}
--- 5339,5489 ----
}
! /* 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 *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, 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))
{
gfc_free_ref_list (new_ref);
! return resolve_compcall (e, 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 (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;
! /* 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");
! 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. */
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, 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))
{
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;
}
*************** resolve_select_type (gfc_code *code)
*** 7372,7378 ****
tail->next = NULL;
default_case = tail;
}
!
/* More than one CLASS IS block? */
if (class_is->block)
{
--- 7233,7239 ----
tail->next = NULL;
default_case = tail;
}
!
/* More than one CLASS IS block? */
if (class_is->block)
{
*************** resolve_select_type (gfc_code *code)
*** 7428,7434 ****
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
! vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
--- 7289,7295 ----
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, 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);
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10743,10749 ****
if (c->attr.proc_pointer && c->ts.interface)
{
! if (c->ts.interface->attr.procedure)
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);
--- 10604,10610 ----
if (c->attr.proc_pointer && c->ts.interface)
{
! 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);
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10807,10813 ****
c->ts.u.cl = cl;
}
}
! else if (c->ts.interface->name[0] != '\0')
{
gfc_error ("Interface '%s' of procedure pointer component "
"'%s' at %L must be explicit", c->ts.interface->name,
--- 10668,10674 ----
c->ts.u.cl = cl;
}
}
! 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,
*************** resolve_fl_derived (gfc_symbol *sym)
*** 10823,10829 ****
}
/* Procedure pointer components: Check PASS arg. */
! if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
{
gfc_symbol* me_arg;
--- 10684,10691 ----
}
/* Procedure pointer components: Check PASS arg. */
! if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0
! && !sym->attr.vtype)
{
gfc_symbol* me_arg;
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c (revision 158765)
--- gcc/fortran/iresolve.c (working copy)
*************** gfc_resolve_extends_type_of (gfc_expr *f
*** 832,838 ****
gfc_add_component_ref (a, "$vptr");
else if (a->ts.type == BT_DERIVED)
{
! vtab = gfc_find_derived_vtab (a->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (a->ref);
memset (a, '\0', sizeof (gfc_expr));
--- 832,838 ----
gfc_add_component_ref (a, "$vptr");
else if (a->ts.type == BT_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_resolve_extends_type_of (gfc_expr *f
*** 848,854 ****
gfc_add_component_ref (mo, "$vptr");
else if (mo->ts.type == BT_DERIVED)
{
! vtab = gfc_find_derived_vtab (mo->ts.u.derived);
/* Clear the old expr. */
gfc_free_ref_list (mo->ref);
memset (mo, '\0', sizeof (gfc_expr));
--- 848,854 ----
gfc_add_component_ref (mo, "$vptr");
else if (mo->ts.type == BT_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));
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 158765)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1070,1075 ****
--- 1070,1084 ----
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. */
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 158765)
--- gcc/fortran/match.c (working copy)
*************** select_type_set_tmp (gfc_typespec *ts)
*** 4280,4286 ****
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! &tmp->n.sym->as);
tmp->n.sym->attr.class_ok = 1;
}
--- 4280,4286 ----
if (ts->type == BT_CLASS)
{
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! &tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 158765)
--- gcc/fortran/parse.c (working copy)
*************** endType:
*** 2110,2115 ****
--- 2110,2131 ----
|| 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)
Index: gcc/testsuite/gfortran.dg/class_16.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_16.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/class_16.f03 (revision 0)
***************
*** 0 ****
--- 1,23 ----
+ ! { 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" } }
Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
===================================================================
*** gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (revision 158765)
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03 (working copy)
***************
*** 1,4 ****
! ! { dg-do compile }
! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
--- 1,4 ----
! ! { 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>
*************** contains
*** 166,172 ****
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
! print *, "s_scals"
call a%a%scal(d,info)
return
end subroutine s_scals
--- 166,173 ----
integer :: err_act
character(len=20) :: name='csnmi'
logical, parameter :: debug=.false.
! ! print *, "s_scals"
! info = 0
call a%a%scal(d,info)
return
end subroutine s_scals
*************** end module s_mat_mod
*** 180,185 ****
--- 181,187 ----
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" } }
Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 (revision 158765)
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_7.f03 (working copy)
***************
*** 1,64 ****
! { dg-do run }
- ! Test the fix for PR43291, which was a regression that caused
- ! incorrect type mismatch errors at line 46. In the course of
- ! fixing the PR, it was noted that the dynamic dispatch of the
- ! final typebound call was not occurring - hence the dg-do run.
!
! ! Contributed by Janus Weil <janus@gcc.gnu.org>
!
! module m1
! type :: t1
! contains
! procedure :: sizeof
! end type
! contains
! integer function sizeof(a)
! class(t1) :: a
! sizeof = 1
! end function sizeof
! end module
- module m2
- use m1
- type, extends(t1) :: t2
- contains
- procedure :: sizeof => sizeof2
- end type
contains
! integer function sizeof2(a)
! class(t2) :: a
! sizeof2 = 2
end function
! end module
! module m3
! use m2
! type :: t3
! class(t1), pointer :: a
! contains
! procedure :: sizeof => sizeof3
! end type
! contains
! integer function sizeof3(a)
! class(t3) :: a
! sizeof3 = a%a%sizeof()
! end function
! end module
!
! use m1
! use m2
! use m3
! type(t1), target :: x
! type(t2), target :: y
! type(t3) :: z
! z%a => x
! 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" } }
--- 1,54 ----
! { 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" } }
Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 (revision 0)
***************
*** 0 ****
--- 1,108 ----
+ ! { 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" } }
+
Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03
===================================================================
*** gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 (revision 0)
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_9.f03 (revision 0)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ ! Test the fix for PR43291, which was a regression that caused
+ ! incorrect type mismatch errors at line 46. In the course of
+ ! fixing the PR, it was noted that the dynamic dispatch of the
+ ! final typebound call was not occurring - hence the dg-do run.
+ !
+ ! Contributed by Janus Weil <janus@gcc.gnu.org>
+ !
+ module m1
+ type :: t1
+ contains
+ procedure :: sizeof
+ end type
+ contains
+ integer function sizeof(a)
+ class(t1) :: a
+ sizeof = 1
+ end function sizeof
+ end module
+
+ module m2
+ use m1
+ type, extends(t1) :: t2
+ contains
+ procedure :: sizeof => sizeof2
+ end type
+ contains
+ integer function sizeof2(a)
+ class(t2) :: a
+ sizeof2 = 2
+ end function
+ end module
+
+ module m3
+ use m2
+ type :: t3
+ class(t1), pointer :: a
+ contains
+ procedure :: sizeof => sizeof3
+ end type
+ contains
+ integer function sizeof3(a)
+ class(t3) :: a
+ sizeof3 = a%a%sizeof()
+ end function
+ end module
+
+ use m1
+ use m2
+ use m3
+ type(t1), target :: x
+ type(t2), target :: y
+ type(t3) :: z
+ z%a => x
+ 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" } }
+