From 85d1c108d2214b4b329c1894066429a54ca9f6aa Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 25 May 2009 14:48:24 +0000 Subject: 2009-05-25 Janus Weil PR fortran/40176 * primary.c (gfc_match_varspec): Handle procedure pointer components with array return value. * resolve.c (resolve_expr_ppc): Ditto. (resolve_symbol): Make sure the interface of a procedure pointer has been resolved. * trans-array.c (gfc_walk_function_expr): Handle procedure pointer components with array return value. * trans-expr.c (gfc_conv_component_ref,gfc_conv_procedure_call, gfc_trans_arrayfunc_assign): Ditto. (gfc_trans_pointer_assignment): Handle procedure pointer assignments, where the rhs is a dummy argument. * trans-types.c (gfc_get_ppc_type,gfc_get_derived_type): Handle procedure pointer components with array return value. 2009-05-25 Janus Weil PR fortran/40176 * gfortran.dg/proc_ptr_18.f90: New. * gfortran.dg/proc_ptr_19.f90: New. * gfortran.dg/proc_ptr_comp_9.f90: New. * gfortran.dg/proc_ptr_comp_10.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@147850 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/trans-expr.c | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a20d3ae8892..f1f009122ef 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) se->string_length = tmp; } - if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0 - && c->ts.type != BT_CHARACTER) + if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER) + || c->attr.proc_pointer) se->expr = build_fold_indirect_ref (se->expr); } @@ -2396,6 +2396,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_symbol *fsym; stmtblock_t post; enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY}; + gfc_component *comp = NULL; arglist = NULL_TREE; retargs = NULL_TREE; @@ -2550,11 +2551,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_init_block (&post); gfc_init_interface_mapping (&mapping); + is_proc_ptr_comp (expr, &comp); need_interface_mapping = ((sym->ts.type == BT_CHARACTER && sym->ts.cl->length && sym->ts.cl->length->expr_type != EXPR_CONSTANT) - || sym->attr.dimension); + || (comp && comp->attr.dimension) + || (!comp && sym->attr.dimension)); formal = sym->formal; /* Evaluate the arguments. */ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) @@ -2825,7 +2828,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, len = cl.backend_decl; } - byref = gfc_return_by_reference (sym); + byref = (comp && comp->attr.dimension) + || (!comp && gfc_return_by_reference (sym)); if (byref) { if (se->direct_byref) @@ -4053,6 +4057,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) && expr1->symtree->n.sym->attr.dummy) lse.expr = build_fold_indirect_ref (lse.expr); + if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer + && expr2->symtree->n.sym->attr.dummy) + rse.expr = build_fold_indirect_ref (rse.expr); + gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); @@ -4284,6 +4292,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_ss *ss; gfc_ref * ref; bool seen_array_ref; + gfc_component *comp = NULL; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) @@ -4343,8 +4352,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ + is_proc_ptr_comp(expr2, &comp); gcc_assert (expr2->value.function.isym - || (gfc_return_by_reference (expr2->value.function.esym) + || (comp && comp->attr.dimension) + || (!comp && gfc_return_by_reference (expr2->value.function.esym) && expr2->value.function.esym->result->attr.dimension)); ss = gfc_walk_expr (expr1); -- cgit v1.2.3