2009-07-25 Janus Weil <janus@gcc.gnu.org>

	PR fortran/39630
	* decl.c (match_ppc_decl): Implement the PASS attribute for procedure
	pointer components.
	(match_binding_attributes): Ditto.
	* gfortran.h (gfc_component): Add member 'tb'.
	(gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const.
	* module.c (MOD_VERSION): Bump module version.
	(binding_ppc): New string constants.
	(mio_component): Only use formal args if component is a procedure
	pointer and add 'tb' member.
	(mio_typebound_proc): Include pass_arg and take care of procedure
	pointer components.
	* resolve.c (update_arglist_pass): Add argument 'name' and take care of
	optional arguments.
	(extract_ppc_passed_object): New function, analogous to
	extract_compcall_passed_object, but for procedure pointer components.
	(update_ppc_arglist): New function, analogous to
	update_compcall_arglist, but for procedure pointer components.
	(resolve_typebound_generic_call): Added argument to update_arglist_pass.
	(resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute.
	(resolve_fl_derived): Check the PASS argument for procedure pointer
	components.
	* symbol.c (verify_bind_c_derived_type): Reject procedure pointer
	components in BIND(C) types.

2009-07-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39630
	* gfortran.dg/proc_ptr_comp_3.f90: Modified.
	* gfortran.dg/proc_ptr_comp_pass_1.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_2.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_3.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_4.f90: New.
	* gfortran.dg/proc_ptr_comp_pass_5.f90: New.
	* gfortran.dg/typebound_call_10.f03: New.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150078 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 268 insertions, 50 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5f6cf27a68d..86f06624859 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+2009-07-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/39630
+	* decl.c (match_ppc_decl): Implement the PASS attribute for procedure
+	pointer components.
+	(match_binding_attributes): Ditto.
+	* gfortran.h (gfc_component): Add member 'tb'.
+	(gfc_typebound_proc): Add member 'ppc' and make 'pass_arg' const.
+	* module.c (MOD_VERSION): Bump module version.
+	(binding_ppc): New string constants.
+	(mio_component): Only use formal args if component is a procedure
+	pointer and add 'tb' member.
+	(mio_typebound_proc): Include pass_arg and take care of procedure
+	pointer components.
+	* resolve.c (update_arglist_pass): Add argument 'name' and take care of
+	optional arguments.
+	(extract_ppc_passed_object): New function, analogous to
+	extract_compcall_passed_object, but for procedure pointer components.
+	(update_ppc_arglist): New function, analogous to
+	update_compcall_arglist, but for procedure pointer components.
+	(resolve_typebound_generic_call): Added argument to update_arglist_pass.
+	(resolve_ppc_call, resolve_expr_ppc): Take care of PASS attribute.
+	(resolve_fl_derived): Check the PASS argument for procedure pointer
+	components.
+	* symbol.c (verify_bind_c_derived_type): Reject procedure pointer
+	components in BIND(C) types.
+
 2009-07-24  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/40822
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 0207683349b..392f2a57e68 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4411,14 +4411,6 @@ match_ppc_decl (void)
   if (m == MATCH_ERROR)
     return m;
 
-  /* TODO: Implement PASS.  */
-  if (!tb->nopass)
-    {
-      gfc_error ("Procedure Pointer Component with PASS at %C "
-		 "not yet implemented");
-      return MATCH_ERROR;
-    }
-
   gfc_clear_attr (&current_attr);
   current_attr.procedure = 1;
   current_attr.proc_pointer = 1;
@@ -4462,6 +4454,8 @@ match_ppc_decl (void)
       if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
 	return MATCH_ERROR;
 
+      c->tb = tb;
+
       /* Set interface.  */
       if (proc_if != NULL)
 	{
@@ -7028,7 +7022,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 {
   bool found_passing = false;
   bool seen_ptr = false;
-  match m;
+  match m = MATCH_YES;
 
   /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
      this case the defaults are in there.  */
@@ -7038,13 +7032,12 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
   ba->nopass = 0;
   ba->non_overridable = 0;
   ba->deferred = 0;
+  ba->ppc = ppc;
 
   /* If we find a comma, we believe there are binding attributes.  */
-  if (gfc_match_char (',') == MATCH_NO)
-    {
-      ba->access = gfc_typebound_default_access;
-      return MATCH_NO;
-    }
+  m = gfc_match_char (',');
+  if (m == MATCH_NO)
+    goto done;
 
   do
     {
@@ -7121,7 +7114,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 	      if (m == MATCH_ERROR)
 		goto error;
 	      if (m == MATCH_YES)
-		ba->pass_arg = xstrdup (arg);
+		ba->pass_arg = gfc_get_string (arg);
 	      gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
 
 	      found_passing = true;
@@ -7144,7 +7137,6 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 		    }
 
 		  seen_ptr = true;
-		  /*ba->ppc = 1;*/
         	  continue;
 		}
 	    }
@@ -7201,6 +7193,9 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
       goto error;
     }
 
+  m = MATCH_YES;
+
+done:
   if (ba->access == ACCESS_UNKNOWN)
     ba->access = gfc_typebound_default_access;
 
@@ -7211,10 +7206,9 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
       goto error;
     }
 
-  return MATCH_YES;
+  return m;
 
 error:
-  gfc_free (ba->pass_arg);
   return MATCH_ERROR;
 }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ce8e6fc1461..7792cfabab6 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -879,8 +879,10 @@ typedef struct gfc_component
   struct gfc_expr *initializer;
   struct gfc_component *next;
 
+  /* Needed for procedure pointer components.  */
   struct gfc_formal_arglist *formal;
   struct gfc_namespace *formal_ns;
+  struct gfc_typebound_proc *tb;
 }
 gfc_component;
 
@@ -1064,7 +1066,7 @@ typedef struct gfc_typebound_proc
   u;
 
   gfc_access access;
-  char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
+  const char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
 
   /* The overridden type-bound proc (or GENERIC with this name in the
      parent-type) or NULL if non.  */
@@ -1081,6 +1083,7 @@ typedef struct gfc_typebound_proc
   unsigned is_generic:1;
   unsigned function:1, subroutine:1;
   unsigned error:1; /* Ignore it, when an error occurred during resolution.  */
+  unsigned ppc:1;
 }
 gfc_typebound_proc;
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 425bd36275b..eff482ca686 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -77,7 +77,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, 
    if yout want it to be recognized.  */
-#define MOD_VERSION "1"
+#define MOD_VERSION "2"
 
 
 /* Structure that describes a position within a module file.  */
@@ -1719,7 +1719,12 @@ static const mstring binding_generic[] =
     minit ("GENERIC", 1),
     minit (NULL, -1)
 };
-
+static const mstring binding_ppc[] =
+{
+    minit ("NO_PPC", 0),
+    minit ("PPC", 1),
+    minit (NULL, -1)
+};
 
 /* Specialization of mio_name.  */
 DECL_MIO_NAME (ab_attribute)
@@ -2260,7 +2265,7 @@ mio_component_ref (gfc_component **cp, gfc_symbol *sym)
 
 static void mio_namespace_ref (gfc_namespace **nsp);
 static void mio_formal_arglist (gfc_formal_arglist **formal);
-
+static void mio_typebound_proc (gfc_typebound_proc** proc);
 
 static void
 mio_component (gfc_component *c)
@@ -2295,28 +2300,33 @@ mio_component (gfc_component *c)
 
   mio_expr (&c->initializer);
 
-  if (iomode == IO_OUTPUT)
+  if (c->attr.proc_pointer)
     {
-      formal = c->formal;
-      while (formal && !formal->sym)
-	formal = formal->next;
+      if (iomode == IO_OUTPUT)
+	{
+	  formal = c->formal;
+	  while (formal && !formal->sym)
+	    formal = formal->next;
 
-      if (formal)
-	mio_namespace_ref (&formal->sym->ns);
+	  if (formal)
+	    mio_namespace_ref (&formal->sym->ns);
+	  else
+	    mio_namespace_ref (&c->formal_ns);
+	}
       else
-	mio_namespace_ref (&c->formal_ns);
-    }
-  else
-    {
-      mio_namespace_ref (&c->formal_ns);
-      /* TODO: if (c->formal_ns)
 	{
-	  c->formal_ns->proc_name = c;
-	  c->refs++;
-	}*/
-    }
+	  mio_namespace_ref (&c->formal_ns);
+	  /* TODO: if (c->formal_ns)
+	    {
+	      c->formal_ns->proc_name = c;
+	      c->refs++;
+	    }*/
+	}
+
+      mio_formal_arglist (&c->formal);
 
-  mio_formal_arglist (&c->formal);
+      mio_typebound_proc (&c->tb);
+    }
 
   mio_rparen ();
 }
@@ -3265,9 +3275,9 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 
   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
+  (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
 
-  if (iomode == IO_INPUT)
-    (*proc)->pass_arg = NULL;
+  mio_pool_string (&((*proc)->pass_arg));
 
   flag = (int) (*proc)->pass_arg_num;
   mio_integer (&flag);
@@ -3304,7 +3314,7 @@ mio_typebound_proc (gfc_typebound_proc** proc)
 
       mio_rparen ();
     }
-  else
+  else if (!(*proc)->ppc)
     mio_symtree_ref (&(*proc)->u.specific);
 
   mio_rparen ();
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e09167b1be2..aaab554d4de 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4535,7 +4535,8 @@ fixup_charlen (gfc_expr *e)
    procedures at the right position.  */
 
 static gfc_actual_arglist*
-update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
+		     const char *name)
 {
   gcc_assert (argpos > 0);
 
@@ -4546,14 +4547,16 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
       result = gfc_get_actual_arglist ();
       result->expr = po;
       result->next = lst;
+      if (name)
+        result->name = name;
 
       return result;
     }
 
-  gcc_assert (lst);
-  gcc_assert (argpos > 1);
-
-  lst->next = update_arglist_pass (lst->next, po, argpos - 1);
+  if (lst)
+    lst->next = update_arglist_pass (lst->next, po, argpos - 1, name);
+  else
+    lst = update_arglist_pass (NULL, po, argpos - 1, name);
   return lst;
 }
 
@@ -4611,7 +4614,74 @@ update_compcall_arglist (gfc_expr* e)
 
   gcc_assert (tbp->pass_arg_num > 0);
   e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
-						  tbp->pass_arg_num);
+						  tbp->pass_arg_num,
+						  tbp->pass_arg);
+
+  return SUCCESS;
+}
+
+
+/* Extract the passed object from a PPC call (a copy of it).  */
+
+static gfc_expr*
+extract_ppc_passed_object (gfc_expr *e)
+{
+  gfc_expr *po;
+  gfc_ref **ref;
+
+  po = gfc_get_expr ();
+  po->expr_type = EXPR_VARIABLE;
+  po->symtree = e->symtree;
+  po->ref = gfc_copy_ref (e->ref);
+
+  /* Remove PPC reference.  */
+  ref = &po->ref;
+  while ((*ref)->next)
+    (*ref) = (*ref)->next;
+  gfc_free_ref_list (*ref);
+  *ref = NULL;
+
+  if (gfc_resolve_expr (po) == FAILURE)
+    return NULL;
+
+  return po;
+}
+
+
+/* Update the actual arglist of a procedure pointer component to include the
+   passed-object.  */
+
+static gfc_try
+update_ppc_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_component *ppc;
+  gfc_typebound_proc* tb;
+
+  if (!gfc_is_proc_ptr_comp (e, &ppc))
+    return FAILURE;
+
+  tb = ppc->tb;
+
+  if (tb->error)
+    return FAILURE;
+  else if (tb->nopass)
+    return SUCCESS;
+
+  po = extract_ppc_passed_object (e);
+  if (!po)
+    return FAILURE;
+
+  if (po->rank > 0)
+    {
+      gfc_error ("Passed-object at %L must be scalar", &e->where);
+      return FAILURE;
+    }
+
+  gcc_assert (tb->pass_arg_num > 0);
+  e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+						  tb->pass_arg_num,
+						  tb->pass_arg);
 
   return SUCCESS;
 }
@@ -4714,7 +4784,8 @@ resolve_typebound_generic_call (gfc_expr* e)
 
 	      gcc_assert (g->specific->pass_arg_num > 0);
 	      gcc_assert (!g->specific->error);
-	      args = update_arglist_pass (args, po, g->specific->pass_arg_num);
+	      args = update_arglist_pass (args, po, g->specific->pass_arg_num,
+					  g->specific->pass_arg);
 	    }
 	  resolve_actual_arglist (args, target->attr.proc,
 				  is_external_proc (target) && !target->formal);
@@ -4836,7 +4907,6 @@ resolve_ppc_call (gfc_code* c)
 
   c->resolved_sym = c->expr1->symtree->n.sym;
   c->expr1->expr_type = EXPR_VARIABLE;
-  c->ext.actual = c->expr1->value.compcall.actual;
 
   if (!comp->attr.subroutine)
     gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
@@ -4844,6 +4914,11 @@ resolve_ppc_call (gfc_code* c)
   if (resolve_ref (c->expr1) == FAILURE)
     return FAILURE;
 
+  if (update_ppc_arglist (c->expr1) == FAILURE)
+    return FAILURE;
+
+  c->ext.actual = c->expr1->value.compcall.actual;
+
   if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
 			      comp->formal == NULL) == FAILURE)
     return FAILURE;
@@ -4880,6 +4955,9 @@ resolve_expr_ppc (gfc_expr* e)
 			      comp->formal == NULL) == FAILURE)
     return FAILURE;
 
+  if (update_ppc_arglist (e) == FAILURE)
+    return FAILURE;
+
   gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
 
   return SUCCESS;
@@ -9095,6 +9173,103 @@ resolve_fl_derived (gfc_symbol *sym)
 	  c->attr.implicit_type = 1;
 	}
 
+      /* Procedure pointer components: Check PASS arg.  */
+      if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0)
+	{
+	  gfc_symbol* me_arg;
+
+	  if (c->tb->pass_arg)
+	    {
+	      gfc_formal_arglist* i;
+
+	      /* If an explicit passing argument name is given, walk the arg-list
+		and look for it.  */
+
+	      me_arg = NULL;
+	      c->tb->pass_arg_num = 1;
+	      for (i = c->formal; i; i = i->next)
+		{
+		  if (!strcmp (i->sym->name, c->tb->pass_arg))
+		    {
+		      me_arg = i->sym;
+		      break;
+		    }
+		  c->tb->pass_arg_num++;
+		}
+
+	      if (!me_arg)
+		{
+		  gfc_error ("Procedure pointer component '%s' with PASS(%s) "
+			     "at %L has no argument '%s'", c->name,
+			     c->tb->pass_arg, &c->loc, c->tb->pass_arg);
+		  c->tb->error = 1;
+		  return FAILURE;
+		}
+	    }
+	  else
+	    {
+	      /* Otherwise, take the first one; there should in fact be at least
+		one.  */
+	      c->tb->pass_arg_num = 1;
+	      if (!c->formal)
+		{
+		  gfc_error ("Procedure pointer component '%s' with PASS at %L "
+			     "must have at least one argument",
+			     c->name, &c->loc);
+		  c->tb->error = 1;
+		  return FAILURE;
+		}
+	      me_arg = c->formal->sym;
+	    }
+
+	  /* Now check that the argument-type matches.  */
+	  gcc_assert (me_arg);
+	  if (me_arg->ts.type != BT_DERIVED
+	      || me_arg->ts.derived != sym)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+			 " the derived type '%s'", me_arg->name, c->name,
+			 me_arg->name, &c->loc, sym->name);
+	      c->tb->error = 1;
+	      return FAILURE;
+	    }
+
+	  /* Check for C453.  */
+	  if (me_arg->attr.dimension)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "must be scalar", me_arg->name, c->name, me_arg->name,
+			 &c->loc);
+	      c->tb->error = 1;
+	      return FAILURE;
+	    }
+
+	  if (me_arg->attr.pointer)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "may not have the POINTER attribute", me_arg->name,
+			 c->name, me_arg->name, &c->loc);
+	      c->tb->error = 1;
+	      return FAILURE;
+	    }
+
+	  if (me_arg->attr.allocatable)
+	    {
+	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L "
+			 "may not be ALLOCATABLE", me_arg->name, c->name,
+			 me_arg->name, &c->loc);
+	      c->tb->error = 1;
+	      return FAILURE;
+	    }
+
+	  /* TODO: Make this an error once CLASS is implemented.  */
+	  if (!sym->attr.sequence)
+	    gfc_warning ("Polymorphic entities are not yet implemented,"
+			 " non-polymorphic passed-object dummy argument of '%s'"
+			 " at %L accepted", c->name, &c->loc);
+
+	}
+
       /* Check type-spec if this is not the parent-type component.  */
       if ((!sym->attr.extension || c != sym->components)
 	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index dd06e48a305..ec4afbe0209 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3452,6 +3452,15 @@ verify_bind_c_derived_type (gfc_symbol *derived_sym)
           retval = FAILURE;
         }
 
+      if (curr_comp->attr.proc_pointer != 0)
+	{
+	  gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+		     " of the BIND(C) derived type '%s' at %L", curr_comp->name,
+		     &curr_comp->loc, derived_sym->name,
+		     &derived_sym->declared_at);
+          retval = FAILURE;
+        }
+
       /* The components cannot be allocatable.
          J3/04-007, Section 15.2.3, C1505.	*/
       if (curr_comp->attr.allocatable != 0)