+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
/* 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);
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);
}
}
{
/* 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);
}
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;
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)
{
static void
-mio_component_list (gfc_component **cp)
+mio_component_list (gfc_component **cp, int vtype)
{
gfc_component *c, *tail;
if (iomode == IO_OUTPUT)
{
for (c = *cp; c; c = c->next)
- mio_component (c);
+ mio_component (c, vtype);
}
else
{
break;
c = gfc_get_component ();
- mio_component (c);
+ mio_component (c, vtype);
if (tail == NULL)
*cp = c;
/* 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
{
/* 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);
}
}
+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. */
}
}
- /* 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;
}
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)
{
/* 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);
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);
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);
}
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));
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
return se.expr;
}
- if (array)
+ if (array && !procptr)
{
/* Arrays need special handling. */
if (pointer)
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);
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);
}
-/* 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. */
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);
{
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);
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);
/* 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. */
+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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
projects / platform / upstream / gcc.git / commitdiff