diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 61278ba76bd..32c3192d297 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +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-24 Jerry DeLisle Dominique Dhumieres diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 4d39c1aa93c..1a03165fcbe 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1726,7 +1726,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = NULL; gfc_gobble_whitespace (); - if ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension) + if ((equiv_flag && gfc_peek_ascii_char () == '(') + || (sym->attr.dimension && !sym->attr.proc_pointer)) { /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -1843,7 +1844,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, break; } - if (component->as != NULL) + if (component->as != NULL && !component->attr.proc_pointer) { tail = extend_ref (primary, tail); tail->type = REF_ARRAY; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 39eb0432af8..8158b71ee4f 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4868,6 +4868,8 @@ resolve_expr_ppc (gfc_expr* e) e->value.function.isym = NULL; e->value.function.actual = e->value.compcall.actual; e->ts = comp->ts; + if (comp->as != NULL) + e->rank = comp->as->rank; if (!comp->attr.function) gfc_add_function (&comp->attr, comp->name, &e->where); @@ -9414,6 +9416,7 @@ resolve_symbol (gfc_symbol *sym) || sym->ts.interface->attr.intrinsic) { gfc_symbol *ifc = sym->ts.interface; + resolve_symbol (ifc); if (ifc->attr.intrinsic) resolve_intrinsic (ifc, &ifc->declared_at); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 36a99a4b9d1..7dea22253f4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -6295,6 +6295,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) gfc_ss *newss; gfc_intrinsic_sym *isym; gfc_symbol *sym; + gfc_component *comp = NULL; isym = expr->value.function.isym; @@ -6307,7 +6308,9 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) sym = expr->symtree->n.sym; /* A function that returns arrays. */ - if (gfc_return_by_reference (sym) && sym->result->attr.dimension) + is_proc_ptr_comp (expr, &comp); + if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) + || (comp && comp->attr.dimension)) { newss = gfc_get_ss (); newss->type = GFC_SS_FUNCTION; 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); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b40af411136..e945fcbf7b5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1875,7 +1875,7 @@ tree gfc_get_ppc_type (gfc_component* c) { tree t; - if (c->attr.function) + if (c->attr.function && !c->attr.dimension) t = gfc_typenode_for_spec (&c->ts); else t = void_type_node; @@ -1997,7 +1997,7 @@ gfc_get_derived_type (gfc_symbol * derived) /* This returns an array descriptor type. Initialization may be required. */ - if (c->attr.dimension) + if (c->attr.dimension && !c->attr.proc_pointer) { if (c->attr.pointer || c->attr.allocatable) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 097317c4f15..a5025a3a592 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +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. + 2009-05-25 Richard Guenther * gcc.dg/tree-ssa/ssa-fre-14.c: Adjust. diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_18.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_18.f90 new file mode 100644 index 00000000000..79cd68a513f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_18.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + PROCEDURE(triple), POINTER :: f + + f => triple + if (sum(f(2.,4.)-triple(2.,4.))>1E-3) call abort() + +CONTAINS + + FUNCTION triple(a,b) RESULT(tre) + REAL, INTENT(in) :: a, b + REAL :: tre(2) + tre(1) = 3.*a + tre(2) = 3.*b + END FUNCTION triple + +END PROGRAM test_prog + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_19.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_19.f90 new file mode 100644 index 00000000000..a78a8d46432 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_19.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! This example tests for a bug in procedure pointer assignments, +! where the rhs is a dummy. +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + PROCEDURE(add), POINTER :: forig, fset + + forig => add + + CALL set_ptr(forig,fset) + + if (forig(1,2) /= fset(1,2)) call abort() + +CONTAINS + + SUBROUTINE set_ptr(f1,f2) + PROCEDURE(add), POINTER :: f1, f2 + f2 => f1 + END SUBROUTINE set_ptr + + FUNCTION add(a,b) + INTEGER :: a,b,add + add = a+b + + END FUNCTION add + +END PROGRAM test_prog + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90 new file mode 100644 index 00000000000..382f4125533 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_10.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Contributed by Janus Weil + +module m + +abstract interface + function ai() + real, dimension(3) :: ai + end function +end interface + +type t + procedure(ai), pointer, nopass :: ppc +end type + +procedure(ai), pointer :: pp + +end module + +program test +use m +type(t) :: obj +obj%ppc => pp +pp => obj%ppc +end + +! { dg-final { cleanup-modules "m" } } + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90 new file mode 100644 index 00000000000..951db485fb0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_9.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR 40176: Fortran 2003: Procedure pointers with array return value +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test_prog + + TYPE ProcPointerType + PROCEDURE(triple), POINTER, NOPASS :: f + END TYPE ProcPointerType + + TYPE (ProcPointerType) :: ppt + PROCEDURE(triple), POINTER :: f + REAL :: tres(2) + + ppt%f => triple + f => ppt%f + tres = f(2,[2.,4.]) + if (abs(tres(1)-6.)>1E-3) call abort() + if (abs(tres(2)-12.)>1E-3) call abort() + tres = ppt%f(2,[3.,5.]) + if (abs(tres(1)-9.)>1E-3) call abort() + if (abs(tres(2)-15.)>1E-3) call abort() + +CONTAINS + + FUNCTION triple(n,x) RESULT(tre) + INTEGER, INTENT(in) :: n + REAL, INTENT(in) :: x(2) + REAL :: tre(2) + tre = 3.*x + END FUNCTION triple + +END PROGRAM test_prog +