[Patch, Fortran] PR40427: [F03] Procedure Pointer Components with OPTIONAL arguments

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

Hi all,

here is my patch for PR 40427, which makes PPCs with OPTIONAL components work.

On the way to this aim it also checks off some of the TODO items that
my initial PPC patch left open: It copies the formal args from the
interface to the PPC and it checks the actual vs the formal args.
Unfortunately this is mainly accomplished by duplicating code that
works on normal procedures or procedure pointers (e.g.
gfc_procedure_use or gfc_copy_formal_args), since I did not find a
more elegant solution to this (if anyone has an idea for a more
unified design, I'd be happy to hear it).

The patch also adds a 'formal_ns' member to gfc_component, which is
the namespace in which the formal arguments reside. However, there is
one problem connected to this: For normal procedures/procedure
pointers the namespace itself points back to the procedure through the
'proc_name' member. Since this is a pointer to a gfc_symbol, this
mechanism cannot be extended to PPCs (which are gfc_components of
course). Right now I'm not sure how to solve this or if it is
necesssary for PPCs at all, therefore I left this topic open, leaving
the proc_name unset for PPCs (and marking the respective places with
TODOs). Does anyone have an idea how to handle this?

The patch is regression-tested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2009-06-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40427
	* gfortran.h (gfc_component): New member 'formal_ns'.
	(gfc_copy_formal_args_ppc,void gfc_ppc_use): New.
	* interface.c (gfc_ppc_use): New function, analogous to
	gfc_procedure_use, but for procedure pointer components.
	* module.c (mio_component): Treat formal arguments.
	(mio_formal_arglist): Changed argument from gfc_symbol to
	gfc_formal_arglist.
	(mio_symbol): Changed argument of mio_formal_arglist.
	* resolve.c (resolve_ppc_call,resolve_expr_ppc): Call gfc_ppc_use,
	to check actual arguments and treat formal args correctly.
	(resolve_fl_derived): Copy formal args of procedure pointer components
	from their interface.
	* symbol.c (gfc_copy_formal_args_ppc): New function, analogous to
	gfc_copy_formal_args, but for procedure pointer components.


2009-06-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40427
	* gfortran.dg/proc_ptr_comp_11.f90: New

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 148472)
+++ gcc/fortran/interface.c	(working copy)
@@ -2361,6 +2361,50 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
 }
 
 
+/* Check how a procedure pointer component is used against its interface.
+   If all goes well, the actual argument list will also end up being properly
+   sorted. Completely analogous to gfc_procedure_use.  */
+
+void
+gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
+{
+
+  /* Warn about calls with an implicit interface.  Special case
+     for calling a ISO_C_BINDING becase c_loc and c_funloc
+     are pseudo-unknown.  */
+  if (gfc_option.warn_implicit_interface
+      && comp->attr.if_source == IFSRC_UNKNOWN
+      && !comp->attr.is_iso_c)
+    gfc_warning ("Procedure pointer component '%s' called with an implicit "
+		 "interface at %L", comp->name, where);
+
+  if (comp->attr.if_source == IFSRC_UNKNOWN)
+    {
+      gfc_actual_arglist *a;
+      for (a = *ap; a; a = a->next)
+	{
+	  /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
+	  if (a->name != NULL && a->name[0] != '%')
+	    {
+	      gfc_error("Keyword argument requires explicit interface "
+			"for procedure pointer component '%s' at %L",
+			comp->name, &a->expr->where);
+	      break;
+	    }
+	}
+
+      return;
+    }
+
+  if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
+    return;
+
+  check_intents (comp->formal, *ap);
+  if (gfc_option.warn_aliasing)
+    check_some_aliasing (comp->formal, *ap);
+}
+
+
 /* Try if an actual argument list matches the formal list of a symbol,
    respecting the symbol's attributes like ELEMENTAL.  This is used for
    GENERIC resolution.  */
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 148472)
+++ gcc/fortran/symbol.c	(working copy)
@@ -3944,6 +3944,60 @@ gfc_copy_formal_args_intr (gfc_symbol *d
 }
 
 
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_formal_arglist *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  /* TODO: gfc_current_ns->proc_name = dest;*/
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->attr = curr_arg->sym->attr;
+      formal_arg->sym->ts = curr_arg->sym->ts;
+      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  dest->formal = head;
+  dest->attr.if_source = IFSRC_DECL;
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
+
+
 /* Builds the parameter list for the iso_c_binding procedure
    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
    generic version of either the c_f_pointer or c_f_procpointer
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 148472)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -855,6 +855,7 @@ typedef struct gfc_component
   struct gfc_component *next;
 
   struct gfc_formal_arglist *formal;
+  struct gfc_namespace *formal_ns;
 }
 gfc_component;
 
@@ -2399,6 +2400,7 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_sy
 
 void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
 void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
+void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *);
 
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
@@ -2570,6 +2572,7 @@ int gfc_compare_types (gfc_typespec *, g
 int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
+void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
 gfc_symbol *gfc_search_interface (gfc_interface *, int,
 				  gfc_actual_arglist **);
 gfc_try gfc_extend_expr (gfc_expr *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 148472)
+++ gcc/fortran/module.c	(working copy)
@@ -2262,11 +2262,16 @@ 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_component (gfc_component *c)
 {
   pointer_info *p;
   int n;
+  gfc_formal_arglist *formal;
 
   mio_lparen ();
 
@@ -2293,6 +2298,30 @@ mio_component (gfc_component *c)
   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
 
   mio_expr (&c->initializer);
+
+  if (iomode == IO_OUTPUT)
+    {
+      formal = c->formal;
+      while (formal && !formal->sym)
+	formal = formal->next;
+
+      if (formal)
+	mio_namespace_ref (&formal->sym->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_formal_arglist (&c->formal);
+
   mio_rparen ();
 }
 
@@ -2386,7 +2415,7 @@ mio_actual_arglist (gfc_actual_arglist *
 /* Read and write formal argument lists.  */
 
 static void
-mio_formal_arglist (gfc_symbol *sym)
+mio_formal_arglist (gfc_formal_arglist **formal)
 {
   gfc_formal_arglist *f, *tail;
 
@@ -2394,20 +2423,20 @@ mio_formal_arglist (gfc_symbol *sym)
 
   if (iomode == IO_OUTPUT)
     {
-      for (f = sym->formal; f; f = f->next)
+      for (f = *formal; f; f = f->next)
 	mio_symbol_ref (&f->sym);
     }
   else
     {
-      sym->formal = tail = NULL;
+      *formal = tail = NULL;
 
       while (peek_atom () != ATOM_RPAREN)
 	{
 	  f = gfc_get_formal_arglist ();
 	  mio_symbol_ref (&f->sym);
 
-	  if (sym->formal == NULL)
-	    sym->formal = f;
+	  if (*formal == NULL)
+	    *formal = f;
 	  else
 	    tail->next = f;
 
@@ -3436,7 +3465,7 @@ mio_symbol (gfc_symbol *sym)
   /* Save/restore common block links.  */
   mio_symbol_ref (&sym->common_next);
 
-  mio_formal_arglist (sym);
+  mio_formal_arglist (&sym->formal);
 
   if (sym->attr.flavor == FL_PARAMETER)
     mio_expr (&sym->value);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 148472)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4847,9 +4847,7 @@ resolve_ppc_call (gfc_code* c)
 			      comp->formal == NULL) == FAILURE)
     return FAILURE;
 
-  /* TODO: Check actual arguments.
-     gfc_procedure_use (stree->n.sym, &c->expr1->value.compcall.actual,
-			&c->expr1->where);*/
+  gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
 
   return SUCCESS;
 }
@@ -4881,8 +4879,7 @@ resolve_expr_ppc (gfc_expr* e)
 			      comp->formal == NULL) == FAILURE)
     return FAILURE;
 
-  /* TODO: Check actual arguments.
-     gfc_procedure_use (stree->n.sym, &e->value.compcall.actual, &e->where);  */
+  gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
 
   return SUCCESS;
 }
@@ -9032,7 +9029,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	      c->ts.interface = ifc;
 	      c->attr.function = ifc->attr.function;
 	      c->attr.subroutine = ifc->attr.subroutine;
-	      /* TODO: gfc_copy_formal_args (c, ifc);  */
+	      gfc_copy_formal_args_ppc (c, ifc);
 
 	      c->attr.allocatable = ifc->attr.allocatable;
 	      c->attr.pointer = ifc->attr.pointer;
@@ -9043,7 +9040,7 @@ resolve_fl_derived (gfc_symbol *sym)
 	      c->attr.always_explicit = ifc->attr.always_explicit;
 	      /* Copy array spec.  */
 	      c->as = gfc_copy_array_spec (ifc->as);
-	      /*if (c->as)
+	      /* TODO: if (c->as)
 		{
 		  int i;
 		  for (i = 0; i < c->as->rank; i++)
@@ -9058,7 +9055,7 @@ resolve_fl_derived (gfc_symbol *sym)
 		  c->ts.cl = gfc_get_charlen();
 	          c->ts.cl->resolved = ifc->ts.cl->resolved;
 		  c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
-		  /*gfc_expr_replace_symbols (c->ts.cl->length, c);*/
+		  /* TODO: gfc_expr_replace_symbols (c->ts.cl->length, c);*/
 		  /* Add charlen to namespace.  */
 		  /*if (c->formal_ns)
 		    {

! { dg-do run }
!
! PR 40427: Procedure Pointer Components with OPTIONAL arguments
!
! Original test case by John McFarland <john.mcfarland@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM prog

 ABSTRACT INTERFACE
 SUBROUTINE sub_template(i,j,o)
   INTEGER, INTENT(in) :: i
   INTEGER, INTENT(in), OPTIONAL :: j, o
 END SUBROUTINE sub_template
 END INTERFACE

 TYPE container
   PROCEDURE(sub_template), POINTER, NOPASS :: s
 END TYPE container

 PROCEDURE(sub_template), POINTER :: f
 TYPE (container) :: c

 c%s => sub
 f => sub

 CALL f(2,o=4)
 CALL c%s(3,o=6)

CONTAINS

 SUBROUTINE sub(i,arg2,arg3)
   INTEGER, INTENT(in) :: i
   INTEGER, INTENT(in), OPTIONAL :: arg2, arg3
   if (present(arg2)) call abort()
   if (.not. present(arg3)) call abort()
   if (2*i/=arg3) call abort()
 END SUBROUTINE sub

END PROGRAM prog