mirror of git://gcc.gnu.org/git/gcc.git
re PR fortran/45271 ([OOP] Polymorphic code breaks when changing order of USE statements)
2010-08-21 Janus Weil <janus@gcc.gnu.org> PR fortran/45271 PR fortran/45290 * class.c (add_proc_comp): Add static initializer for PPCs. (add_procs_to_declared_vtab): Modified comment. * module.c (mio_component): Add argument 'vtype'. Don't read/write the initializer if the component is part of a vtype. (mio_component_list): Add argument 'vtype', pass it on to 'mio_component'. (mio_symbol): Modified call to 'mio_component_list'. * trans.h (gfc_conv_initializer): Modified prototype. (gfc_trans_assign_vtab_procs): Removed. * trans-common.c (create_common): Modified call to 'gfc_conv_initializer'. * trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl, gfc_emit_parameter_debug_info): Modified call to 'gfc_conv_initializer'. (build_function_decl): Remove assertion. * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): Removed call to 'gfc_trans_assign_vtab_procs'. (gfc_conv_initializer): Add argument 'procptr'. (gfc_conv_structure): Modified call to 'gfc_conv_initializer'. (gfc_trans_assign_vtab_procs): Removed. * trans-stmt.c (gfc_trans_allocate): Removed call to 'gfc_trans_assign_vtab_procs'. 2010-08-21 Janus Weil <janus@gcc.gnu.org> PR fortran/44863 PR fortran/45271 PR fortran/45290 * gfortran.dg/dynamic_dispatch_10.f03: New (PR 44863 comment #1). * gfortran.dg/pointer_init_5.f90: New (PR 45290 comment #6). * gfortran.dg/typebound_call_18.f03: New (PR 45271 comment #3). From-SVN: r163445
This commit is contained in:
Janus Weil
parent
02be26e48b
commit
1d0134b3cc
|
|
@ -1,3 +1,30 @@
|
|||
2010-08-21 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/45271
|
||||
PR fortran/45290
|
||||
* class.c (add_proc_comp): Add static initializer for PPCs.
|
||||
(add_procs_to_declared_vtab): Modified comment.
|
||||
* module.c (mio_component): Add argument 'vtype'. Don't read/write the
|
||||
initializer if the component is part of a vtype.
|
||||
(mio_component_list): Add argument 'vtype', pass it on to
|
||||
'mio_component'.
|
||||
(mio_symbol): Modified call to 'mio_component_list'.
|
||||
* trans.h (gfc_conv_initializer): Modified prototype.
|
||||
(gfc_trans_assign_vtab_procs): Removed.
|
||||
* trans-common.c (create_common): Modified call to
|
||||
'gfc_conv_initializer'.
|
||||
* trans-decl.c (gfc_get_symbol_decl,get_proc_pointer_decl,
|
||||
gfc_emit_parameter_debug_info): Modified call to
|
||||
'gfc_conv_initializer'.
|
||||
(build_function_decl): Remove assertion.
|
||||
* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
|
||||
Removed call to 'gfc_trans_assign_vtab_procs'.
|
||||
(gfc_conv_initializer): Add argument 'procptr'.
|
||||
(gfc_conv_structure): Modified call to 'gfc_conv_initializer'.
|
||||
(gfc_trans_assign_vtab_procs): Removed.
|
||||
* trans-stmt.c (gfc_trans_allocate): Removed call to
|
||||
'gfc_trans_assign_vtab_procs'.
|
||||
|
||||
2010-08-21 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/36158
|
||||
|
|
|
|||
|
|
@ -214,8 +214,6 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
|
|||
/* Add procedure component. */
|
||||
if (gfc_add_component (vtype, name, &c) == FAILURE)
|
||||
return;
|
||||
if (tb->u.specific)
|
||||
c->ts.interface = tb->u.specific->n.sym;
|
||||
|
||||
if (!c->tb)
|
||||
c->tb = XCNEW (gfc_typebound_proc);
|
||||
|
|
@ -228,17 +226,18 @@ add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
|
|||
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;
|
||||
}
|
||||
else if (c->attr.proc_pointer && c->tb)
|
||||
{
|
||||
*c->tb = *tb;
|
||||
c->tb->ppc = 1;
|
||||
c->ts.interface = tb->u.specific->n.sym;
|
||||
}
|
||||
|
||||
if (tb->u.specific)
|
||||
{
|
||||
c->ts.interface = tb->u.specific->n.sym;
|
||||
if (!tb->deferred)
|
||||
c->initializer = gfc_get_variable_expr (tb->u.specific);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -296,7 +295,7 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
|
|||
{
|
||||
/* Make sure that the PPCs appear in the same order as in the parent. */
|
||||
copy_vtab_proc_comps (super_type, vtype);
|
||||
/* Only needed to get the PPC interfaces right. */
|
||||
/* Only needed to get the PPC initializers right. */
|
||||
add_procs_to_declared_vtab (super_type, vtype);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2343,7 +2343,7 @@ static void mio_formal_arglist (gfc_formal_arglist **formal);
|
|||
static void mio_typebound_proc (gfc_typebound_proc** proc);
|
||||
|
||||
static void
|
||||
mio_component (gfc_component *c)
|
||||
mio_component (gfc_component *c, int vtype)
|
||||
{
|
||||
pointer_info *p;
|
||||
int n;
|
||||
|
|
@ -2373,7 +2373,8 @@ mio_component (gfc_component *c)
|
|||
mio_symbol_attribute (&c->attr);
|
||||
c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
|
||||
|
||||
mio_expr (&c->initializer);
|
||||
if (!vtype)
|
||||
mio_expr (&c->initializer);
|
||||
|
||||
if (c->attr.proc_pointer)
|
||||
{
|
||||
|
|
@ -2408,7 +2409,7 @@ mio_component (gfc_component *c)
|
|||
|
||||
|
||||
static void
|
||||
mio_component_list (gfc_component **cp)
|
||||
mio_component_list (gfc_component **cp, int vtype)
|
||||
{
|
||||
gfc_component *c, *tail;
|
||||
|
||||
|
|
@ -2417,7 +2418,7 @@ mio_component_list (gfc_component **cp)
|
|||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
for (c = *cp; c; c = c->next)
|
||||
mio_component (c);
|
||||
mio_component (c, vtype);
|
||||
}
|
||||
else
|
||||
{
|
||||
|
|
@ -2430,7 +2431,7 @@ mio_component_list (gfc_component **cp)
|
|||
break;
|
||||
|
||||
c = gfc_get_component ();
|
||||
mio_component (c);
|
||||
mio_component (c, vtype);
|
||||
|
||||
if (tail == NULL)
|
||||
*cp = c;
|
||||
|
|
@ -3597,7 +3598,7 @@ mio_symbol (gfc_symbol *sym)
|
|||
/* Note that components are always saved, even if they are supposed
|
||||
to be private. Component access is checked during searching. */
|
||||
|
||||
mio_component_list (&sym->components);
|
||||
mio_component_list (&sym->components, sym->attr.vtype);
|
||||
|
||||
if (sym->components != NULL)
|
||||
sym->component_access
|
||||
|
|
|
|||
|
|
@ -649,8 +649,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
|
|||
{
|
||||
/* Add the initializer for this field. */
|
||||
tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
|
||||
TREE_TYPE (s->field), s->sym->attr.dimension,
|
||||
s->sym->attr.pointer || s->sym->attr.allocatable);
|
||||
TREE_TYPE (s->field),
|
||||
s->sym->attr.dimension,
|
||||
s->sym->attr.pointer
|
||||
|| s->sym->attr.allocatable, false);
|
||||
|
||||
CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1034,6 +1034,9 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
|
|||
}
|
||||
|
||||
|
||||
static void build_function_decl (gfc_symbol * sym, bool global);
|
||||
|
||||
|
||||
/* Return the decl for a gfc_symbol, create it if it doesn't already
|
||||
exist. */
|
||||
|
||||
|
|
@ -1160,12 +1163,21 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
}
|
||||
}
|
||||
|
||||
/* Catch function declarations. Only used for actual parameters and
|
||||
procedure pointers. */
|
||||
if (sym->attr.flavor == FL_PROCEDURE)
|
||||
{
|
||||
decl = gfc_get_extern_function_decl (sym);
|
||||
gfc_set_decl_location (decl, &sym->declared_at);
|
||||
/* Catch function declarations. Only used for actual parameters,
|
||||
procedure pointers and procptr initialization targets. */
|
||||
if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
|
||||
{
|
||||
decl = gfc_get_extern_function_decl (sym);
|
||||
gfc_set_decl_location (decl, &sym->declared_at);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (!sym->backend_decl)
|
||||
build_function_decl (sym, false);
|
||||
decl = sym->backend_decl;
|
||||
}
|
||||
return decl;
|
||||
}
|
||||
|
||||
|
|
@ -1281,8 +1293,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
every time the procedure is entered. The TREE_STATIC is
|
||||
in this case due to -fmax-stack-var-size=. */
|
||||
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
|
||||
TREE_TYPE (decl), sym->attr.dimension,
|
||||
sym->attr.pointer || sym->attr.allocatable);
|
||||
TREE_TYPE (decl),
|
||||
sym->attr.dimension,
|
||||
sym->attr.pointer
|
||||
|| sym->attr.allocatable,
|
||||
sym->attr.proc_pointer);
|
||||
}
|
||||
|
||||
if (!TREE_STATIC (decl)
|
||||
|
|
@ -1369,9 +1384,9 @@ get_proc_pointer_decl (gfc_symbol *sym)
|
|||
{
|
||||
/* Add static initializer. */
|
||||
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
|
||||
TREE_TYPE (decl),
|
||||
sym->attr.proc_pointer ? false : sym->attr.dimension,
|
||||
sym->attr.proc_pointer);
|
||||
TREE_TYPE (decl),
|
||||
sym->attr.dimension,
|
||||
false, true);
|
||||
}
|
||||
|
||||
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
|
||||
|
|
@ -1608,9 +1623,11 @@ build_function_decl (gfc_symbol * sym, bool global)
|
|||
tree result_decl;
|
||||
gfc_formal_arglist *f;
|
||||
|
||||
gcc_assert (!sym->backend_decl);
|
||||
gcc_assert (!sym->attr.external);
|
||||
|
||||
if (sym->backend_decl)
|
||||
return;
|
||||
|
||||
/* Set the line and filename. sym->declared_at seems to point to the
|
||||
last statement for subroutines, but it'll do for now. */
|
||||
gfc_set_backend_locus (&sym->declared_at);
|
||||
|
|
@ -3806,9 +3823,10 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
|
|||
TREE_USED (decl) = 1;
|
||||
if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
|
||||
TREE_PUBLIC (decl) = 1;
|
||||
DECL_INITIAL (decl)
|
||||
= gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
|
||||
sym->attr.dimension, 0);
|
||||
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
|
||||
TREE_TYPE (decl),
|
||||
sym->attr.dimension,
|
||||
false, false);
|
||||
debug_hooks->global_decl (decl);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2574,7 +2574,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
|
|||
not to the class declared type. */
|
||||
vtab = gfc_find_derived_vtab (e->ts.u.derived);
|
||||
gcc_assert (vtab);
|
||||
gfc_trans_assign_vtab_procs (&parmse->pre, 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));
|
||||
|
|
@ -3946,11 +3945,11 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
tree
|
||||
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
|
||||
bool array, bool pointer)
|
||||
bool array, bool pointer, bool procptr)
|
||||
{
|
||||
gfc_se se;
|
||||
|
||||
if (!(expr || pointer))
|
||||
if (!(expr || pointer || procptr))
|
||||
return NULL_TREE;
|
||||
|
||||
/* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
|
||||
|
|
@ -3972,7 +3971,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
|
|||
return se.expr;
|
||||
}
|
||||
|
||||
if (array)
|
||||
if (array && !procptr)
|
||||
{
|
||||
/* Arrays need special handling. */
|
||||
if (pointer)
|
||||
|
|
@ -3983,7 +3982,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
|
|||
else
|
||||
return gfc_conv_array_initializer (type, expr);
|
||||
}
|
||||
else if (pointer)
|
||||
else if (pointer || procptr)
|
||||
{
|
||||
if (!expr || expr->expr_type == EXPR_NULL)
|
||||
return fold_convert (type, null_pointer_node);
|
||||
|
|
@ -4462,8 +4461,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
|
|||
else
|
||||
{
|
||||
val = gfc_conv_initializer (c->expr, &cm->ts,
|
||||
TREE_TYPE (cm->backend_decl), cm->attr.dimension,
|
||||
cm->attr.pointer || cm->attr.proc_pointer);
|
||||
TREE_TYPE (cm->backend_decl),
|
||||
cm->attr.dimension, cm->attr.pointer,
|
||||
cm->attr.proc_pointer);
|
||||
|
||||
/* Append it to the constructor list. */
|
||||
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
|
||||
|
|
@ -5779,63 +5779,6 @@ gfc_trans_assign (gfc_code * code)
|
|||
}
|
||||
|
||||
|
||||
/* 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, ctree, proc, cond = NULL_TREE;
|
||||
stmtblock_t body;
|
||||
|
||||
/* Point to the first procedure pointer. */
|
||||
cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
|
||||
cmp = cmp->next;
|
||||
if (!cmp)
|
||||
return;
|
||||
|
||||
vtb = gfc_get_symbol_decl (vtab);
|
||||
|
||||
ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), vtb,
|
||||
cmp->backend_decl, NULL_TREE);
|
||||
cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
|
||||
build_int_cst (TREE_TYPE (ctree), 0));
|
||||
|
||||
gfc_init_block (&body);
|
||||
for (; cmp; cmp = cmp->next)
|
||||
{
|
||||
gfc_symbol *target = NULL;
|
||||
|
||||
/* 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);
|
||||
|
||||
proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
|
||||
|
||||
gfc_add_expr_to_block (block, proc);
|
||||
}
|
||||
|
||||
|
||||
/* Special case for initializing a CLASS variable on allocation.
|
||||
A MEMCPY is needed to copy the full data of the dynamic type,
|
||||
which may be different from the declared type. */
|
||||
|
|
@ -5887,7 +5830,6 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
|
|||
gfc_symtree *st;
|
||||
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
|
||||
gcc_assert (vtab);
|
||||
gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
|
||||
rhs = gfc_get_expr ();
|
||||
rhs->expr_type = EXPR_VARIABLE;
|
||||
gfc_find_sym_tree (vtab->name, NULL, 1, &st);
|
||||
|
|
|
|||
|
|
@ -4441,7 +4441,6 @@ gfc_trans_allocate (gfc_code * code)
|
|||
{
|
||||
vtab = gfc_find_derived_vtab (ts->u.derived);
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -433,7 +433,7 @@ void gfc_set_decl_location (tree, locus *);
|
|||
tree gfc_get_symbol_decl (gfc_symbol *);
|
||||
|
||||
/* Build a static initializer. */
|
||||
tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool);
|
||||
tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool);
|
||||
|
||||
/* Assign a default initializer to a derived type. */
|
||||
void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool);
|
||||
|
|
@ -527,9 +527,6 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
|
|||
/* 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. */
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
2010-08-21 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44863
|
||||
PR fortran/45271
|
||||
PR fortran/45290
|
||||
* gfortran.dg/dynamic_dispatch_10.f03: New (PR 44863 comment #1).
|
||||
* gfortran.dg/pointer_init_5.f90: New (PR 45290 comment #6).
|
||||
* gfortran.dg/typebound_call_18.f03: New (PR 45271 comment #3).
|
||||
|
||||
2010-08-21 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/36158
|
||||
|
|
|
|||
|
|
@ -0,0 +1,171 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! [OOP] Fortran runtime error: internal error: bad hash value in dynamic dispatch
|
||||
!
|
||||
! Contributed by David Car <david.car7@gmail.com>
|
||||
|
||||
module BaseStrategy
|
||||
|
||||
type, public, abstract :: Strategy
|
||||
contains
|
||||
procedure(strategy_update), pass( this ), deferred :: update
|
||||
procedure(strategy_pre_update), pass( this ), deferred :: preUpdate
|
||||
procedure(strategy_post_update), pass( this ), deferred :: postUpdate
|
||||
end type Strategy
|
||||
|
||||
abstract interface
|
||||
subroutine strategy_update( this )
|
||||
import Strategy
|
||||
class (Strategy), target, intent(in) :: this
|
||||
end subroutine strategy_update
|
||||
end interface
|
||||
|
||||
abstract interface
|
||||
subroutine strategy_pre_update( this )
|
||||
import Strategy
|
||||
class (Strategy), target, intent(in) :: this
|
||||
end subroutine strategy_pre_update
|
||||
end interface
|
||||
|
||||
abstract interface
|
||||
subroutine strategy_post_update( this )
|
||||
import Strategy
|
||||
class (Strategy), target, intent(in) :: this
|
||||
end subroutine strategy_post_update
|
||||
end interface
|
||||
|
||||
end module BaseStrategy
|
||||
|
||||
!==============================================================================
|
||||
|
||||
module LaxWendroffStrategy
|
||||
|
||||
use BaseStrategy
|
||||
|
||||
private :: update, preUpdate, postUpdate
|
||||
|
||||
type, public, extends( Strategy ) :: LaxWendroff
|
||||
class (Strategy), pointer :: child => null()
|
||||
contains
|
||||
procedure, pass( this ) :: update
|
||||
procedure, pass( this ) :: preUpdate
|
||||
procedure, pass( this ) :: postUpdate
|
||||
end type LaxWendroff
|
||||
|
||||
contains
|
||||
|
||||
subroutine update( this )
|
||||
class (LaxWendroff), target, intent(in) :: this
|
||||
|
||||
print *, 'Calling LaxWendroff update'
|
||||
end subroutine update
|
||||
|
||||
subroutine preUpdate( this )
|
||||
class (LaxWendroff), target, intent(in) :: this
|
||||
|
||||
print *, 'Calling LaxWendroff preUpdate'
|
||||
end subroutine preUpdate
|
||||
|
||||
subroutine postUpdate( this )
|
||||
class (LaxWendroff), target, intent(in) :: this
|
||||
|
||||
print *, 'Calling LaxWendroff postUpdate'
|
||||
end subroutine postUpdate
|
||||
|
||||
end module LaxWendroffStrategy
|
||||
|
||||
!==============================================================================
|
||||
|
||||
module KEStrategy
|
||||
|
||||
use BaseStrategy
|
||||
! Uncomment the line below and it runs fine
|
||||
! use LaxWendroffStrategy
|
||||
|
||||
private :: update, preUpdate, postUpdate
|
||||
|
||||
type, public, extends( Strategy ) :: KE
|
||||
class (Strategy), pointer :: child => null()
|
||||
contains
|
||||
procedure, pass( this ) :: update
|
||||
procedure, pass( this ) :: preUpdate
|
||||
procedure, pass( this ) :: postUpdate
|
||||
end type KE
|
||||
|
||||
contains
|
||||
|
||||
subroutine init( this, other )
|
||||
class (KE), intent(inout) :: this
|
||||
class (Strategy), target, intent(in) :: other
|
||||
|
||||
this % child => other
|
||||
end subroutine init
|
||||
|
||||
subroutine update( this )
|
||||
class (KE), target, intent(in) :: this
|
||||
|
||||
if ( associated( this % child ) ) then
|
||||
call this % child % update()
|
||||
end if
|
||||
|
||||
print *, 'Calling KE update'
|
||||
end subroutine update
|
||||
|
||||
subroutine preUpdate( this )
|
||||
class (KE), target, intent(in) :: this
|
||||
|
||||
if ( associated( this % child ) ) then
|
||||
call this % child % preUpdate()
|
||||
end if
|
||||
|
||||
print *, 'Calling KE preUpdate'
|
||||
end subroutine preUpdate
|
||||
|
||||
subroutine postUpdate( this )
|
||||
class (KE), target, intent(in) :: this
|
||||
|
||||
if ( associated( this % child ) ) then
|
||||
call this % child % postUpdate()
|
||||
end if
|
||||
|
||||
print *, 'Calling KE postUpdate'
|
||||
end subroutine postUpdate
|
||||
|
||||
end module KEStrategy
|
||||
|
||||
!==============================================================================
|
||||
|
||||
program main
|
||||
|
||||
use LaxWendroffStrategy
|
||||
use KEStrategy
|
||||
|
||||
type :: StratSeq
|
||||
class (Strategy), pointer :: strat => null()
|
||||
end type StratSeq
|
||||
|
||||
type (LaxWendroff), target :: lw_strat
|
||||
type (KE), target :: ke_strat
|
||||
|
||||
type (StratSeq), allocatable, dimension( : ) :: seq
|
||||
|
||||
allocate( seq(10) )
|
||||
|
||||
call init( ke_strat, lw_strat )
|
||||
call ke_strat % preUpdate()
|
||||
call ke_strat % update()
|
||||
call ke_strat % postUpdate()
|
||||
! call lw_strat % update()
|
||||
|
||||
seq( 1 ) % strat => ke_strat
|
||||
seq( 2 ) % strat => lw_strat
|
||||
|
||||
call seq( 1 ) % strat % update()
|
||||
|
||||
do i = 1, 2
|
||||
call seq( i ) % strat % update()
|
||||
end do
|
||||
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "BaseStrategy LaxWendroffStrategy KEStrategy" } }
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 45290: [F08] pointer initialization
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
module m
|
||||
|
||||
implicit none
|
||||
|
||||
procedure(f1), pointer :: pp => f1
|
||||
|
||||
type :: t
|
||||
procedure(f2), pointer, nopass :: ppc => f2
|
||||
end type
|
||||
|
||||
contains
|
||||
|
||||
integer function f1()
|
||||
f1 = 42
|
||||
end function
|
||||
|
||||
integer function f2()
|
||||
f2 = 43
|
||||
end function
|
||||
|
||||
end module
|
||||
|
||||
|
||||
program test_ptr_init
|
||||
|
||||
use m
|
||||
implicit none
|
||||
|
||||
type (t) :: u
|
||||
|
||||
if (pp()/=42) call abort()
|
||||
if (u%ppc()/=43) call abort()
|
||||
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 45271: [OOP] Polymorphic code breaks when changing order of USE statements
|
||||
!
|
||||
! Contributed by Harald Anlauf <anlauf@gmx.de>
|
||||
|
||||
module abstract_vector
|
||||
implicit none
|
||||
type, abstract :: vector_class
|
||||
contains
|
||||
procedure(op_assign_v_v), deferred :: assign
|
||||
end type vector_class
|
||||
abstract interface
|
||||
subroutine op_assign_v_v(this,v)
|
||||
import vector_class
|
||||
class(vector_class), intent(inout) :: this
|
||||
class(vector_class), intent(in) :: v
|
||||
end subroutine
|
||||
end interface
|
||||
end module abstract_vector
|
||||
|
||||
module concrete_vector
|
||||
use abstract_vector
|
||||
implicit none
|
||||
type, extends(vector_class) :: trivial_vector_type
|
||||
contains
|
||||
procedure :: assign => my_assign
|
||||
end type
|
||||
contains
|
||||
subroutine my_assign (this,v)
|
||||
class(trivial_vector_type), intent(inout) :: this
|
||||
class(vector_class), intent(in) :: v
|
||||
write (*,*) 'Oops in concrete_vector::my_assign'
|
||||
call abort ()
|
||||
end subroutine
|
||||
end module concrete_vector
|
||||
|
||||
module concrete_gradient
|
||||
use abstract_vector
|
||||
implicit none
|
||||
type, extends(vector_class) :: trivial_gradient_type
|
||||
contains
|
||||
procedure :: assign => my_assign
|
||||
end type
|
||||
contains
|
||||
subroutine my_assign (this,v)
|
||||
class(trivial_gradient_type), intent(inout) :: this
|
||||
class(vector_class), intent(in) :: v
|
||||
write (*,*) 'concrete_gradient::my_assign'
|
||||
end subroutine
|
||||
end module concrete_gradient
|
||||
|
||||
program main
|
||||
!--- exchange these two lines to make the code work:
|
||||
use concrete_vector ! (1)
|
||||
use concrete_gradient ! (2)
|
||||
!---
|
||||
implicit none
|
||||
type(trivial_gradient_type) :: g_initial
|
||||
class(vector_class), allocatable :: g
|
||||
print *, "cg: before g%assign"
|
||||
allocate(trivial_gradient_type :: g)
|
||||
call g%assign (g_initial)
|
||||
print *, "cg: after g%assign"
|
||||
end program main
|
||||
|
||||
! { dg-final { cleanup-modules "abstract_vector concrete_vector concrete_gradient" } }
|
||||
Loading…
Reference in New Issue