[Patch, Fortran, F03] PR 39630: Procedure Pointer Components with PASS

[Janus Weil <janus at gcc dot gnu dot org>]

Dear gfortran community,

after Procedure Pointer Components with NOPASS have been working on
trunk for a while now (and are already being used in a couple of
real-world codes), here finally comes my patch for PPCs with the PASS
attribute. This practically completes gfortran's support for procedure
pointers, and is expected to be my last bigger installment in this
direction (of course it is likely that a few bugfixes or corner-case
features will follow).

The PASS attribute for PPCs is quite similar to the PASS attribute for
Type-Bound Procedures (which has already been implemented by Daniel
Kraft some time ago). Consequently my patch stays quite close to
Daniel's TBP implementation, sharing with it the data structure
(gfc_typebound_proc) and quite a bit of code (such as
match_binding_attributes, mio_typebound_proc and update_arglist_pass).
Of course some parts had to be adjusted specifically to PPCs
(extract_ppc_passed_object, update_ppc_arglist, etc). Btw the patch
also contains a small bugfix for TBPs with optional arguments (cf.
typebound_call_10.f03).

I'm not 100% sure if the patch is ready for prime time yet, but at
least it pretty much contains all the features of the PASS attribute,
and I did not manage to find any open issues. This of course does
neither mean that they are not there, nor that nobody else can find
them. Therefore I would be very grateful if someone could take it for
a test drive and try to break it (actually it has already received a
bit of testing by Tobias). Also a formal review would be very welcome.

I have successfully tested for regressions on
x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-07-24  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/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.

Index: gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(revision 150046)
+++ gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90	(working copy)
@@ -16,7 +16,6 @@ end interface
 external :: aaargh
 
 type :: t
-  procedure(sub), pointer :: ptr1                ! { dg-error "not yet implemented" }
   procedure(real), pointer, nopass :: ptr2
   procedure(sub), pointer, nopass :: ptr3
   procedure(), pointer, nopass ptr4              ! { dg-error "Expected '::'" }
@@ -29,6 +28,10 @@ type :: t
   real :: y
 end type t
 
+type,bind(c) :: bct                   ! { dg-error "BIND.C. derived type" }
+  procedure(), pointer,nopass :: ptr  ! { dg-error "cannot be a member of|may not be C interoperable" }
+end type bct
+
 procedure(sub), pointer :: pp
 
 type(t) :: x
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 150047)
+++ gcc/fortran/symbol.c	(working copy)
@@ -3452,6 +3452,15 @@ verify_bind_c_derived_type (gfc_symbol *
           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)
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 150047)
+++ gcc/fortran/decl.c	(working copy)
@@ -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_
 {
   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_
   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_
 	      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_
 		    }
 
 		  seen_ptr = true;
-		  /*ba->ppc = 1;*/
         	  continue;
 		}
 	    }
@@ -7201,6 +7193,9 @@ match_binding_attributes (gfc_typebound_
       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_
       goto error;
     }
 
-  return MATCH_YES;
+  return m;
 
 error:
-  gfc_free (ba->pass_arg);
   return MATCH_ERROR;
 }
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 150047)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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;
 
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 150047)
+++ gcc/fortran/module.c	(working copy)
@@ -77,7 +77,7 @@ along with GCC; see the file COPYING3.  
 
 /* 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, g
 
 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)->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**
 
       mio_rparen ();
     }
-  else
+  else if (!(*proc)->ppc)
     mio_symtree_ref (&(*proc)->u.specific);
 
   mio_rparen ();
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 150047)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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*
       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
 
 	      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)

Attachment: proc_ptr_comp_pass_1.f90
Description: Binary data

Attachment: proc_ptr_comp_pass_2.f90
Description: Binary data

Attachment: proc_ptr_comp_pass_3.f90
Description: Binary data

Attachment: proc_ptr_comp_pass_4.f90
Description: Binary data

Attachment: proc_ptr_comp_pass_5.f90
Description: Binary data

Attachment: typebound_call_10.f03
Description: Binary data