From: Janus Weil Date: Thu, 21 Oct 2010 11:31:55 +0000 (+0200) Subject: re PR fortran/46060 ([F03] procedure pointer component referenced without argument... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=837c4b78f697de3a047f6e6dba919c02fd769809;p=gcc.git re PR fortran/46060 ([F03] procedure pointer component referenced without argument list) 2010-10-21 Janus Weil PR fortran/46060 * match.h (gfc_matching_ptr_assignment): New global variable to indicate we're currently matching a (non-proc-)pointer assignment. * decl.c (match_pointer_init): Set it. * match.c (gfc_match_pointer_assignment): Ditto. * primary.c (matching_actual_arglist): New global variable to indicate we're currently matching an actual argument list. (gfc_match_actual_arglist): Set it. (gfc_match_varspec): Reject procedure pointer component calls with missing argument list. 2010-10-21 Janus Weil PR fortran/46060 * gfortran.dg/proc_ptr_comp_25.f90: New. From-SVN: r165769 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1bc4917f29e..5ade0ecf334 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-10-21 Janus Weil + + PR fortran/46060 + * match.h (gfc_matching_ptr_assignment): New global variable to indicate + we're currently matching a (non-proc-)pointer assignment. + * decl.c (match_pointer_init): Set it. + * match.c (gfc_match_pointer_assignment): Ditto. + * primary.c (matching_actual_arglist): New global variable to indicate + we're currently matching an actual argument list. + (gfc_match_actual_arglist): Set it. + (gfc_match_varspec): Reject procedure pointer component calls with + missing argument list. + 2010-10-21 Janus Weil PR fortran/46067 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 5b4ab182ed7..009b010db26 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1673,8 +1673,10 @@ match_pointer_init (gfc_expr **init, int procptr) return m; /* Match non-NULL initialization. */ + gfc_matching_ptr_assignment = !procptr; gfc_matching_procptr_assignment = procptr; m = gfc_match_rvalue (init); + gfc_matching_ptr_assignment = 0; gfc_matching_procptr_assignment = 0; if (m == MATCH_ERROR) return MATCH_ERROR; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 836c95cc2df..efde1a6c71b 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" +int gfc_matching_ptr_assignment = 0; int gfc_matching_procptr_assignment = 0; bool gfc_matching_prefix = false; @@ -1331,6 +1332,7 @@ gfc_match_pointer_assignment (void) old_loc = gfc_current_locus; lvalue = rvalue = NULL; + gfc_matching_ptr_assignment = 0; gfc_matching_procptr_assignment = 0; m = gfc_match (" %v =>", &lvalue); @@ -1343,8 +1345,11 @@ gfc_match_pointer_assignment (void) if (lvalue->symtree->n.sym->attr.proc_pointer || gfc_is_proc_ptr_comp (lvalue, NULL)) gfc_matching_procptr_assignment = 1; + else + gfc_matching_ptr_assignment = 1; m = gfc_match (" %e%t", &rvalue); + gfc_matching_ptr_assignment = 0; gfc_matching_procptr_assignment = 0; if (m != MATCH_YES) goto cleanup; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 501049e1220..69f1d9e607b 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -31,6 +31,7 @@ extern gfc_symbol *gfc_new_block; separate. */ extern gfc_st_label *gfc_statement_label; +extern int gfc_matching_ptr_assignment; extern int gfc_matching_procptr_assignment; extern bool gfc_matching_prefix; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 054c66f35dc..9632d1c8523 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -28,6 +28,8 @@ along with GCC; see the file COPYING3. If not see #include "parse.h" #include "constructor.h" +int matching_actual_arglist = 0; + /* Matches a kind-parameter expression, which is either a named symbolic constant or a nonnegative integer constant. If successful, sets the kind value to the correct integer. */ @@ -1610,6 +1612,8 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp) return MATCH_YES; head = NULL; + matching_actual_arglist++; + for (;;) { if (head == NULL) @@ -1684,6 +1688,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp) } *argp = head; + matching_actual_arglist--; return MATCH_YES; syntax: @@ -1692,7 +1697,7 @@ syntax: cleanup: gfc_free_actual_arglist (head); gfc_current_locus = old_loc; - + matching_actual_arglist--; return MATCH_ERROR; } @@ -1883,10 +1888,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (component->attr.proc_pointer && ppc_arg && !gfc_matching_procptr_assignment) { + /* Procedure pointer component call: Look for argument list. */ m = gfc_match_actual_arglist (sub_flag, &primary->value.compcall.actual); if (m == MATCH_ERROR) return MATCH_ERROR; + + if (m == MATCH_NO && !gfc_matching_ptr_assignment + && !matching_actual_arglist) + { + gfc_error ("Procedure pointer component '%s' requires an " + "argument list at %C", component->name); + return MATCH_ERROR; + } + if (m == MATCH_YES) primary->expr_type = EXPR_PPC; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8b12fcaec46..51877d14545 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-10-21 Janus Weil + + PR fortran/46060 + * gfortran.dg/proc_ptr_comp_25.f90: New. + 2010-10-21 Richard Guenther Michael Matz diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_25.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_25.f90 new file mode 100644 index 00000000000..68355262979 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_25.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 46060: [F03] procedure pointer component referenced without argument list +! +! Contributed by Stephen J. Bespalko + +implicit none + +abstract interface + function name_func (ivar) result (res) + integer, intent(in) :: ivar + character(len=8) :: res + end function name_func +end interface + +type var_type + procedure(name_func), nopass, pointer :: name +end type var_type + +type(var_type) :: vars +character(len=8) name + +name = vars%name ! { dg-error "requires an argument list" } + +end