re PR fortran/46060 ([F03] procedure pointer component referenced without argument list)

2010-10-21  Janus Weil  <janus@gcc.gnu.org>

	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  <janus@gcc.gnu.org>

	PR fortran/46060
	* gfortran.dg/proc_ptr_comp_25.f90: New.

From-SVN: r165769

5 files changed, 37 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1bc4917f29e..5ade0ecf334 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,18 @@
 2010-10-21  Janus Weil  <janus@gcc.gnu.org>
 
+	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  <janus@gcc.gnu.org>
+
 	PR fortran/46067
 	* interface.c (gfc_compare_interfaces): Switch arguments of type
 	comparison (important for polymorphic variables).
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;