re PR fortran/40427 ([F03] Procedure Pointer Components with OPTIONAL arguments)

2009-06-24  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 (MOD_VERSION): Bump module version.
	(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-24  Janus Weil  <janus@gcc.gnu.org>

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

From-SVN: r148906

gcc/fortran/ChangeLog

+2009-06-24  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 (MOD_VERSION): Bump module version.
+	(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-22  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/37254

gcc/fortran/gfortran.h

@@ -855,6 +855,7 @@ typedef struct gfc_component
   struct gfc_component *next;
 
   struct gfc_formal_arglist *formal;
+  struct gfc_namespace *formal_ns;
 }
 gfc_component;
 
@@ -2409,6 +2410,7 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 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  */
 
@@ -2580,6 +2582,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *);
 int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, 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 *);

gcc/fortran/interface.c

@@ -2397,6 +2397,50 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 }
 
 
+/* 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.  */

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 "0"
+#define MOD_VERSION "1"
 
 
 /* Structure that describes a position within a module file.  */
@@ -2262,11 +2262,16 @@ 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_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 **ap)
 /* 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);

gcc/fortran/resolve.c

@@ -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;
 }
@@ -9040,7 +9037,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;
@@ -9051,7 +9048,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++)
@@ -9066,7 +9063,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)
 		    {

gcc/fortran/symbol.c

@@ -3944,6 +3944,60 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
 }
 
 
+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

gcc/testsuite/ChangeLog

+2009-06-24  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/40427
+	* gfortran.dg/proc_ptr_comp_11.f90: New.
+
 2009-06-24  Andreas Krebbel  <krebbel1@de.ibm.com>
 
 	* gcc.dg/pr40501.c: New testcase.

gcc/testsuite/gfortran.dg/proc_ptr_comp_11.f90

+! { 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
+