+2009-10-05 Paul Thomas <pault@gcc.gnu.org>
+
+ * trans-expr.c (select_class_proc): New function.
+ (conv_function_val): Deal with class methods and call above.
+ * symbol.c (gfc_type_compatible): Treat case where both ts1 and
+ ts2 are BT_CLASS.
+ gfortran.h : Add structure gfc_class_esym_list and include in
+ the structure gfc_expr.
+ * module.c (load_derived_extensions): New function.
+ (read_module): Call above.
+ (write_dt_extensions): New function.
+ (write_derived_extensions): New function.
+ (write_module): Use the above.
+ * resolve.c (resolve_typebound_call): Add a function expression
+ for class methods. This carries the chain of symbols for the
+ dynamic dispatch in select_class_proc.
+ (resolve_compcall): Add second, boolean argument to indicate if
+ a function is being handled.
+ (check_members): New function.
+ (check_class_members): New function.
+ (resolve_class_compcall): New function.
+ (resolve_class_typebound_call): New function.
+ (gfc_resolve_expr): Call above for component calls..
+
2009-10-05 Daniel Kraft <d@domob.eu>
PR fortran/41403
gfc_intrinsic_sym;
+typedef struct gfc_class_esym_list
+{
+ gfc_symbol *derived;
+ gfc_symbol *esym;
+ gfc_symbol *class_object;
+ struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
/* Expression nodes. The expression node types deserve explanations,
since the last couple can be easily misconstrued:
const char *name; /* Points to the ultimate name of the function */
gfc_intrinsic_sym *isym;
gfc_symbol *esym;
+ gfc_class_esym_list *class_esym;
}
function;
}
+/* This function loads the sym_root of f2k_derived with the extensions to
+ the derived type. */
+static void
+load_derived_extensions (void)
+{
+ int symbol, nuse, j;
+ gfc_symbol *derived;
+ gfc_symbol *dt;
+ gfc_symtree *st;
+ pointer_info *info;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char module[GFC_MAX_SYMBOL_LEN + 1];
+ const char *p;
+
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_integer (&symbol);
+ info = get_integer (symbol);
+ derived = info->u.rsym.sym;
+
+ gcc_assert (derived->attr.flavor == FL_DERIVED);
+ if (derived->f2k_derived == NULL)
+ derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_internal_string (name);
+ mio_internal_string (module);
+
+ /* Only use one use name to find the symbol. */
+ nuse = number_use_names (name, false);
+ j = 1;
+ p = find_use_name_n (name, &j, false);
+ st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+ dt = st->n.sym;
+ st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+ if (st == NULL)
+ {
+ /* Only use the real name in f2k_derived to ensure a single
+ symtree. */
+ st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+ st->n.sym = dt;
+ st->n.sym->refs++;
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
static void
read_module (void)
{
- module_locus operator_interfaces, user_operators;
+ module_locus operator_interfaces, user_operators, extensions;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
skip_list ();
skip_list ();
- /* Skip commons and equivalences for now. */
+ /* Skip commons, equivalences and derived type extensions for now. */
skip_list ();
skip_list ();
+ get_module_locus (&extensions);
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
gfc_check_interfaces (gfc_current_ns);
+ /* Now we should be in a position to fill f2k_derived with derived type
+ extensions, since everything has been loaded. */
+ set_module_locus (&extensions);
+ load_derived_extensions ();
+
/* Clean up symbol nodes that were never loaded, create references
to hidden symbols. */
}
+/* Write derived type extensions to the module. */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+ mio_lparen ();
+ mio_pool_string (&st->n.sym->name);
+ if (st->n.sym->module != NULL)
+ mio_pool_string (&st->n.sym->module);
+ else
+ mio_internal_string (module_name);
+ mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+ if (!((st->n.sym->attr.flavor == FL_DERIVED)
+ && (st->n.sym->f2k_derived != NULL)
+ && (st->n.sym->f2k_derived->sym_root != NULL)))
+ return;
+
+ mio_lparen ();
+ mio_symbol_ref (&(st->n.sym));
+ gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+ write_dt_extensions);
+ mio_rparen ();
+}
+
+
/* Write a symbol to the module. */
static void
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ gfc_traverse_symtree (gfc_current_ns->sym_root,
+ write_derived_extensions);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
gfc_free_expr (c->expr1);
- c->expr1 = NULL;
+ c->expr1 = gfc_get_expr ();
+ c->expr1->expr_type = EXPR_FUNCTION;
+ c->expr1->symtree = target;
+ c->expr1->where = c->loc;
return resolve_call (c);
}
-/* Resolve a component-call expression. */
-
+/* 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)
+resolve_compcall (gfc_expr* e, bool fcn)
{
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a FUNCTION. */
- if (!e->value.compcall.tbp->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);
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;
e->expr_type = EXPR_FUNCTION;
- return gfc_resolve_expr (e);
+ /* 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;
+
+ /* 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->class_object
+ = class_object;
+ 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;
+ }
+}
+
+
+/* Resolve a CLASS typebound function, or 'method'. */
+static gfc_try
+resolve_class_compcall (gfc_expr* e)
+{
+ gfc_symbol *derived;
+
+ class_object = e->symtree->n.sym;
+
+ /* Get the CLASS type. */
+ derived = e->symtree->n.sym->ts.u.derived;
+
+ /* Get the data component, which is of the declared type. */
+ derived = derived->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);
+
+ return class_try;
+}
+
+/* Resolve a CLASS typebound subroutine, or 'method'. */
+static gfc_try
+resolve_class_typebound_call (gfc_code *code)
+{
+ gfc_symbol *derived;
+
+ class_object = code->expr1->symtree->n.sym;
+
+ /* Get the CLASS type. */
+ derived = code->expr1->symtree->n.sym->ts.u.derived;
+
+ /* Get the data component, which is of the declared type. */
+ derived = derived->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);
+
+ return class_try;
}
break;
case EXPR_COMPCALL:
- t = resolve_compcall (e);
+ 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:
case EXEC_COMPCALL:
compcall:
- resolve_typebound_call (code);
+ if (code->expr1->symtree
+ && code->expr1->symtree->n.sym->ts.type == BT_CLASS)
+ resolve_class_typebound_call (code);
+ else
+ resolve_typebound_call (code);
break;
case EXEC_CALL_PPC:
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
{
- if (ts1->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
}
+/* Select a class typebound procedure at runtime. */
+static void
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+ tree declared, locus *where)
+{
+ tree end_label;
+ tree label;
+ tree tmp;
+ tree vindex;
+ stmtblock_t body;
+ gfc_class_esym_list *next_elist, *tmp_elist;
+
+ /* Calculate the switch expression: class_object.vindex. */
+ gcc_assert (elist->class_object->ts.type == BT_CLASS);
+ tmp = elist->class_object->ts.u.derived->components->next->backend_decl;
+ vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ elist->class_object->backend_decl,
+ tmp, NULL_TREE);
+ vindex = gfc_evaluate_now (vindex, &se->pre);
+
+ /* Fix the function type to be that of the declared type. */
+ 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;
+ 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, 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->where);
+ return;
+ }
+
if (gfc_is_proc_ptr_comp (expr, NULL))
tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
+2009-10-05 Paul Thomas <pault@gcc.gnu.org>
+
+ * gfortran.dg/dynamic_dispatch_1.f90: New test.
+ * gfortran.dg/dynamic_dispatch_2.f90: New test.
+ * gfortran.dg/dynamic_dispatch_3.f90: New test.
+ * gfortran.dg/module_md5_1.f90: Update md5 sum.
+
2009-10-05 Sriraman Tallam <tmsriram@google.com>
* gcc.dg/plugin/selfassign.c (plugin_init): Change plugin_pass to
--- /dev/null
+! { dg-do run }
+! Tests dynamic dispatch of class functions.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+ type :: t1
+ integer :: i = 42
+ procedure(make_real), pointer :: ptr
+ contains
+ procedure, pass :: real => make_real
+ procedure, pass :: make_integer
+ procedure, pass :: prod => i_m_j
+ generic, public :: extract => real, make_integer
+ generic, public :: base_extract => real, make_integer
+ end type t1
+
+ type, extends(t1) :: t2
+ integer :: j = 99
+ contains
+ procedure, pass :: real => make_real2
+ procedure, pass :: make_integer_2
+ procedure, pass :: prod => i_m_j_2
+ generic, public :: extract => real, make_integer_2
+ end type t2
+contains
+ real function make_real (arg)
+ class(t1), intent(in) :: arg
+ make_real = real (arg%i)
+ end function make_real
+
+ real function make_real2 (arg)
+ class(t2), intent(in) :: arg
+ make_real2 = real (arg%j)
+ end function make_real2
+
+ integer function make_integer (arg, arg2)
+ class(t1), intent(in) :: arg
+ integer :: arg2
+ make_integer = arg%i * arg2
+ end function make_integer
+
+ integer function make_integer_2 (arg, arg2)
+ class(t2), intent(in) :: arg
+ integer :: arg2
+ make_integer_2 = arg%j * arg2
+ end function make_integer_2
+
+ integer function i_m_j (arg)
+ class(t1), intent(in) :: arg
+ i_m_j = arg%i
+ end function i_m_j
+
+ integer function i_m_j_2 (arg)
+ class(t2), intent(in) :: arg
+ i_m_j_2 = arg%j
+ end function i_m_j_2
+end module m
+
+ use m
+ type, extends(t1) :: l1
+ character(16) :: chr
+ end type l1
+ class(t1), pointer :: a !=> NULL()
+ type(t1), target :: b
+ type(t2), target :: c
+ type(l1), target :: d
+ a => b ! declared type
+ if (a%real() .ne. real (42)) call abort
+ if (a%prod() .ne. 42) call abort
+ if (a%extract (2) .ne. 84) call abort
+ if (a%base_extract (2) .ne. 84) call abort
+ a => c ! extension in module
+ if (a%real() .ne. real (99)) call abort
+ if (a%prod() .ne. 99) call abort
+ if (a%extract (3) .ne. 297) call abort
+ if (a%base_extract (3) .ne. 126) call abort
+ a => d ! extension in main
+ if (a%real() .ne. real (42)) call abort
+ if (a%prod() .ne. 42) call abort
+ if (a%extract (4) .ne. 168) call abort
+ if (a%base_extract (4) .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do run }
+! Tests dynamic dispatch of class subroutines.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+ type :: t1
+ integer :: i = 42
+ procedure(make_real), pointer :: ptr
+ contains
+ procedure, pass :: real => make_real
+ procedure, pass :: make_integer
+ procedure, pass :: prod => i_m_j
+ generic, public :: extract => real, make_integer
+ generic, public :: base_extract => real, make_integer
+ end type t1
+
+ type, extends(t1) :: t2
+ integer :: j = 99
+ contains
+ procedure, pass :: real => make_real2
+ procedure, pass :: make_integer_2
+ procedure, pass :: prod => i_m_j_2
+ generic, public :: extract => real, make_integer_2
+ end type t2
+contains
+ subroutine make_real (arg, arg2)
+ class(t1), intent(in) :: arg
+ real :: arg2
+ arg2 = real (arg%i)
+ end subroutine make_real
+
+ subroutine make_real2 (arg, arg2)
+ class(t2), intent(in) :: arg
+ real :: arg2
+ arg2 = real (arg%j)
+ end subroutine make_real2
+
+ subroutine make_integer (arg, arg2, arg3)
+ class(t1), intent(in) :: arg
+ integer :: arg2, arg3
+ arg3 = arg%i * arg2
+ end subroutine make_integer
+
+ subroutine make_integer_2 (arg, arg2, arg3)
+ class(t2), intent(in) :: arg
+ integer :: arg2, arg3
+ arg3 = arg%j * arg2
+ end subroutine make_integer_2
+
+ subroutine i_m_j (arg, arg2)
+ class(t1), intent(in) :: arg
+ integer :: arg2
+ arg2 = arg%i
+ end subroutine i_m_j
+
+ subroutine i_m_j_2 (arg, arg2)
+ class(t2), intent(in) :: arg
+ integer :: arg2
+ arg2 = arg%j
+ end subroutine i_m_j_2
+end module m
+
+ use m
+ type, extends(t1) :: l1
+ character(16) :: chr
+ end type l1
+ class(t1), pointer :: a !=> NULL()
+ type(t1), target :: b
+ type(t2), target :: c
+ type(l1), target :: d
+ real :: r
+ integer :: i
+
+ a => b ! declared type
+ call a%real(r)
+ if (r .ne. real (42)) call abort
+ call a%prod(i)
+ if (i .ne. 42) call abort
+ call a%extract (2, i)
+ if (i .ne. 84) call abort
+ call a%base_extract (2, i)
+ if (i .ne. 84) call abort
+
+ a => c ! extension in module
+ call a%real(r)
+ if (r .ne. real (99)) call abort
+ call a%prod(i)
+ if (i .ne. 99) call abort
+ call a%extract (3, i)
+ if (i .ne. 297) call abort
+ call a%base_extract (3, i)
+ if (i .ne. 126) call abort
+
+ a => d ! extension in main
+ call a%real(r)
+ if (r .ne. real (42)) call abort
+ call a%prod(i)
+ if (i .ne. 42) call abort
+ call a%extract (4, i)
+ if (i .ne. 168) call abort
+ call a%extract (4, i)
+ if (i .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do run }
+! Tests dynamic dispatch of class functions, spread over
+! different modules. Apart from the location of the derived
+! type declarations, this test is the same as
+! dynamic_dispatch_1.f03
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m1
+ type :: t1
+ integer :: i = 42
+ procedure(make_real), pointer :: ptr
+ contains
+ procedure, pass :: real => make_real
+ procedure, pass :: make_integer
+ procedure, pass :: prod => i_m_j
+ generic, public :: extract => real, make_integer
+ generic, public :: base_extract => real, make_integer
+ end type t1
+contains
+ real function make_real (arg)
+ class(t1), intent(in) :: arg
+ make_real = real (arg%i)
+ end function make_real
+
+ integer function make_integer (arg, arg2)
+ class(t1), intent(in) :: arg
+ integer :: arg2
+ make_integer = arg%i * arg2
+ end function make_integer
+
+ integer function i_m_j (arg)
+ class(t1), intent(in) :: arg
+ i_m_j = arg%i
+ end function i_m_j
+end module m1
+
+module m2
+ use m1
+ type, extends(t1) :: t2
+ integer :: j = 99
+ contains
+ procedure, pass :: real => make_real2
+ procedure, pass :: make_integer_2
+ procedure, pass :: prod => i_m_j_2
+ generic, public :: extract => real, make_integer_2
+ end type t2
+contains
+ real function make_real2 (arg)
+ class(t2), intent(in) :: arg
+ make_real2 = real (arg%j)
+ end function make_real2
+
+ integer function make_integer_2 (arg, arg2)
+ class(t2), intent(in) :: arg
+ integer :: arg2
+ make_integer_2 = arg%j * arg2
+ end function make_integer_2
+
+ integer function i_m_j_2 (arg)
+ class(t2), intent(in) :: arg
+ i_m_j_2 = arg%j
+ end function i_m_j_2
+end module m2
+
+ use m1
+ use m2
+ type, extends(t1) :: l1
+ character(16) :: chr
+ end type l1
+ class(t1), pointer :: a !=> NULL()
+ type(t1), target :: b
+ type(t2), target :: c
+ type(l1), target :: d
+ a => b ! declared type in module m1
+ if (a%real() .ne. real (42)) call abort
+ if (a%prod() .ne. 42) call abort
+ if (a%extract (2) .ne. 84) call abort
+ if (a%base_extract (2) .ne. 84) call abort
+ a => c ! extension in module m2
+ if (a%real() .ne. real (99)) call abort
+ if (a%prod() .ne. 99) call abort
+ if (a%extract (3) .ne. 297) call abort
+ if (a%base_extract (3) .ne. 126) call abort
+ a => d ! extension in main
+ if (a%real() .ne. real (42)) call abort
+ if (a%prod() .ne. 42) call abort
+ if (a%extract (4) .ne. 168) call abort
+ if (a%base_extract (4) .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m1, m2" } }
use foo
print *, pi
end program test
-! { dg-final { scan-module "foo" "MD5:dc2fd1358dcaddc25e3c89dae859ef32" } }
+! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
! { dg-final { cleanup-modules "foo" } }
OSDN Git Service
