From: Janus Weil Date: Tue, 25 Aug 2009 14:26:44 +0000 (+0200) Subject: re PR fortran/41139 (a procedure pointer call as actual argument) X-Git-Tag: releases/gcc-4.5.0~3853 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=23878536a6b359865599d300c214bbb8fef83a43;p=thirdparty%2Fgcc.git re PR fortran/41139 (a procedure pointer call as actual argument) 2009-08-25 Janus Weil PR fortran/41139 * primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for calls to procedure pointer components, other references to procedure pointer components are EXPR_VARIABLE. * resolve.c (resolve_actual_arglist): Bugfix (there can be calls without actual arglist). * trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp', removed argument 'se' and made static. Avoid inserting a temporary variable for calling the PPC. (conv_function_val): Renamed gfc_get_proc_ptr_comp. (gfc_conv_procedure_call): Distinguish functions returning a procedure pointer from calls to a procedure pointer. Distinguish calls to procedure pointer components from procedure pointer components as actual arguments. * trans-stmt.h (gfc_get_proc_ptr_comp): Make it static. 2009-08-25 Janus Weil PR fortran/41139 * gfortran.dg/proc_ptr_25.f90: New. * gfortran.dg/proc_ptr_comp_18.f90: New. * gfortran.dg/proc_ptr_comp_19.f90: New. From-SVN: r151081 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 15881c94ca0d..16a046dc958e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2009-08-25 Janus Weil + + PR fortran/41139 + * primary.c (gfc_match_varspec): Make sure EXPR_PPC is only used for + calls to procedure pointer components, other references to procedure + pointer components are EXPR_VARIABLE. + * resolve.c (resolve_actual_arglist): Bugfix (there can be calls without + actual arglist). + * trans-expr.c (gfc_get_proc_ptr_comp): Renamed to 'get_proc_ptr_comp', + removed argument 'se' and made static. Avoid inserting a temporary + variable for calling the PPC. + (conv_function_val): Renamed gfc_get_proc_ptr_comp. + (gfc_conv_procedure_call): Distinguish functions returning a procedure + pointer from calls to a procedure pointer. Distinguish calls to + procedure pointer components from procedure pointer components as + actual arguments. + * trans-stmt.h (gfc_get_proc_ptr_comp): Make it static. + 2009-08-24 Jerry DeLisle PR fortran/41162 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 0a917f7f048b..79db19510f22 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1839,13 +1839,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (component->attr.proc_pointer && ppc_arg && !gfc_matching_procptr_assignment) { - primary->expr_type = EXPR_PPC; - m = gfc_match_actual_arglist (component->attr.subroutine, + m = gfc_match_actual_arglist (sub_flag, &primary->value.compcall.actual); if (m == MATCH_ERROR) return MATCH_ERROR; - if (m == MATCH_NO) - primary->value.compcall.actual = NULL; + if (m == MATCH_YES) + primary->expr_type = EXPR_PPC; break; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 411e2c8d9dc4..3bc4c587da30 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1279,9 +1279,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_is_proc_ptr_comp (e, &comp)) { e->ts = comp->ts; - if (e->value.compcall.actual == NULL) - e->expr_type = EXPR_VARIABLE; - else + if (e->expr_type == EXPR_PPC) { if (comp->as != NULL) e->rank = comp->as->rank; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3f5e76d137db..a5677f70d8d1 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1502,13 +1502,29 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind) return tmp; } + +/* Return the backend_decl for a procedure pointer component. */ + +static tree +get_proc_ptr_comp (gfc_expr *e) +{ + gfc_se comp_se; + gfc_expr *e2; + gfc_init_se (&comp_se, NULL); + e2 = gfc_copy_expr (e); + e2->expr_type = EXPR_VARIABLE; + gfc_conv_expr (&comp_se, e2); + return build_fold_addr_expr_loc (input_location, comp_se.expr); +} + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; if (gfc_is_proc_ptr_comp (expr, NULL)) - tmp = gfc_get_proc_ptr_comp (se, expr); + tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) { tmp = gfc_get_symbol_decl (sym); @@ -2679,6 +2695,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result + && e->symtree->n.sym->result != e->symtree->n.sym && e->symtree->n.sym->result->attr.proc_pointer) { /* Functions returning procedure pointers. */ @@ -2695,7 +2712,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || (fsym->attr.proc_pointer && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)) - || gfc_is_proc_ptr_comp (e, NULL))) + || (e->expr_type == EXPR_VARIABLE + && gfc_is_proc_ptr_comp (e, NULL)))) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -3501,22 +3519,6 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) } -/* Return the backend_decl for a procedure pointer component. */ - -tree -gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e) -{ - gfc_se comp_se; - gfc_expr *e2; - gfc_init_se (&comp_se, NULL); - e2 = gfc_copy_expr (e); - e2->expr_type = EXPR_VARIABLE; - gfc_conv_expr (&comp_se, e2); - comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr); - return gfc_evaluate_now (comp_se.expr, &se->pre); -} - - /* Translate a function expression. */ static void diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 0b167b9f6fe3..d7307df2a82c 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -29,7 +29,6 @@ tree gfc_trans_code (gfc_code *); tree gfc_trans_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *); -tree gfc_get_proc_ptr_comp (gfc_se *, gfc_expr *); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 83b2daa1b79b..23f669b9645f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-08-25 Janus Weil + + PR fortran/41139 + * gfortran.dg/proc_ptr_25.f90: New. + * gfortran.dg/proc_ptr_comp_18.f90: New. + * gfortran.dg/proc_ptr_comp_19.f90: New. + 2009-08-24 Jerry DeLisle PR fortran/41154 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_25.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_25.f90 new file mode 100644 index 000000000000..cfa0d4434786 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_25.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Original test case by Barron Bichon +! Modified by Janus Weil + +PROGRAM test + + PROCEDURE(add), POINTER :: f + logical :: g + + ! Passing the function works + g=greater(4.,add(1.,2.)) + if (.not. g) call abort() + + ! Passing the procedure pointer fails + f => add + g=greater(4.,f(1.,2.)) + if (.not. g) call abort() + +CONTAINS + + REAL FUNCTION add(x,y) + REAL, INTENT(in) :: x,y + print *,"add:",x,y + add = x+y + END FUNCTION add + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90 new file mode 100644 index 000000000000..4b849b64e184 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_18.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Contributed by Janus Weil + +PROGRAM test + + type :: t + PROCEDURE(add), POINTER, nopass :: f + end type + type(t) :: o + logical :: g + + o%f => add + g=greater(4.,o%f(1.,2.)) + if (.not. g) call abort() + +CONTAINS + + REAL FUNCTION add(x,y) + REAL, INTENT(in) :: x,y + add = x+y + END FUNCTION add + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + print *,"greater:",x,y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test + diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90 new file mode 100644 index 000000000000..8027c82d39bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_19.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR 41139: [4.5 Regression] a procedure pointer call as actual argument +! +! Contributed by Janus Weil + +PROGRAM test + + type :: t + PROCEDURE(three), POINTER, nopass :: f + end type + type(t) :: o + logical :: g + + o%f => three + g=greater(4.,o%f()) + if (.not. g) call abort() + +CONTAINS + + REAL FUNCTION three() + three = 3. + END FUNCTION + + LOGICAL FUNCTION greater(x,y) + REAL, INTENT(in) :: x, y + print *,"greater:",x,y + greater = (x > y) + END FUNCTION greater + +END PROGRAM test +