diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 27 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 17 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 13 | ||||
| -rw-r--r-- | gcc/fortran/trans-common.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 44 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 72 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 5 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 | 171 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/pointer_init_5.f90 | 42 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_call_18.f03 | 67 |
12 files changed, 374 insertions, 100 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 111004d3e1b..e793b421cbf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 7dc934452ef..df3a314c980 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -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); } diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index d68e868dba2..e9a8625212d 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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 diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index a19facb8317..ed659ac67e9 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -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); } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ea397096de2..3904b0d7ddb 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f7badd71b28..103bc2461f0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 019555ae7f9..44195870bcc 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d5f82aa29c6..04934e50e6d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1bdada5606d..cd60ce4e8c5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 b/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 new file mode 100644 index 00000000000..2b8e0fbc503 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dynamic_dispatch_10.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/pointer_init_5.f90 b/gcc/testsuite/gfortran.dg/pointer_init_5.f90 new file mode 100644 index 00000000000..beedad27d1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_init_5.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_call_18.f03 b/gcc/testsuite/gfortran.dg/typebound_call_18.f03 new file mode 100644 index 00000000000..bb94717ad3f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_call_18.f03 @@ -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" } } |