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:
parent
e48efd3b2b
commit
7cf078dcea
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,6 +7729,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
|
|||
|
||||
case EXEC_COMPCALL:
|
||||
compcall:
|
||||
if (code->expr1->symtree
|
||||
&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
|
||||
resolve_class_typebound_call (code);
|
||||
else
|
||||
resolve_typebound_call (code);
|
||||
break;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } }
|
|
@ -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" } }
|
|
@ -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" } }
|
|
@ -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" } }
|
||||
|
|
Loading…
Reference in New Issue