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

1 files changed, 183 insertions, 8 deletions

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)