OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

trans-expr.c (select_class_proc): New function. 

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  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.

From-SVN: r152463
This commit is contained in:
Paul Thomas 2009-10-05 18:19:55 +00:00
parent e48efd3b2b
commit 7cf078dcea
11 changed files with 778 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
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

12
gcc/fortran/gfortran.h
View File

@ -1594,6 +1594,17 @@ typedef struct gfc_intrinsic_sym
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:
@ -1705,6 +1716,7 @@ typedef struct gfc_expr
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;

104
gcc/fortran/module.c
View File

@ -3972,6 +3972,61 @@ load_equiv (void)
}
/* 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. */
@ -4113,7 +4168,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
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;
@ -4130,10 +4185,13 @@ read_module (void)
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. */
@ -4386,6 +4444,11 @@ read_module (void)
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. */
@ -4594,6 +4657,36 @@ write_equiv (void)
}
/* 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
@ -4820,6 +4913,13 @@ write_module (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

232
gcc/fortran/resolve.c
View File

@ -4997,28 +4997,42 @@ resolve_typebound_call (gfc_code* c)
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);
@ -5043,12 +5057,207 @@ resolve_compcall (gfc_expr* e)
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;
}
@ -5162,7 +5371,10 @@ gfc_resolve_expr (gfc_expr *e)
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:
@ -7517,7 +7729,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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:

5
gcc/fortran/symbol.c
View File

@ -4579,9 +4579,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
{
if (ts1->type == BT_CLASS)
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

124
gcc/fortran/trans-expr.c
View File

@ -1523,11 +1523,135 @@ get_proc_ptr_comp (gfc_expr *e)
}
/* 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)

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
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

84
gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03 Normal file
View File

@ -0,0 +1,84 @@
! { 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" } }

105
gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03 Normal file
View File

@ -0,0 +1,105 @@
! { 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" } }

91
gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03 Normal file
View File

@ -0,0 +1,91 @@
! { 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" } }

2
gcc/testsuite/gfortran.dg/module_md5_1.f90
View File

@ -10,5 +10,5 @@ program test
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" } }