interface.c (gfc_procedure_use): Return gfc_try instead of

2012-07-31  Tobias Burnus  <burnus@net-b.de>

        * interface.c (gfc_procedure_use): Return gfc_try instead of
        * void.
        * gfortran.h (gfc_procedure_use): Update prototype.
        * resolve.c (gfc_iso_c_func_interface): Allow noninteroperable
        procedures for c_funloc for TS29113.
        * (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add
        diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer.

2012-07-31  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/c_funloc_tests_6.f90: New.
        * gfortran.dg/c_funloc_tests_7.f90: New.
        * gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003.

From-SVN: r190003

gcc/fortran/ChangeLog

@@ -1,3 +1,12 @@
+2012-07-31  Tobias Burnus  <burnus@net-b.de>
+
+	* interface.c (gfc_procedure_use): Return gfc_try instead of void.
+	* gfortran.h (gfc_procedure_use): Update prototype.
+	* resolve.c (gfc_iso_c_func_interface): Allow noninteroperable
+	procedures for c_funloc for TS29113.
+	* (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add
+	diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer.
+
 2012-07-30  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/51081

gcc/fortran/gfortran.h

@@ -2849,7 +2849,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *);
 int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int,
 			    char *, int, const char *, const char *);
 void gfc_check_interfaces (gfc_namespace *);
-void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
+gfc_try 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 **);

gcc/fortran/interface.c

@@ -2927,7 +2927,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
    well, the actual argument list will also end up being properly
    sorted.  */
 
-void
+gfc_try
 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
   /* Warn about calls with an implicit interface.  Special case
@@ -2954,7 +2954,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	  gfc_error("The pointer object '%s' at %L must have an explicit "
 		    "function interface or be declared as array",
 		    sym->name, where);
-	  return;
+	  return FAILURE;
 	}
 
       if (sym->attr.allocatable && !sym->attr.external)
@@ -2962,14 +2962,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	  gfc_error("The allocatable object '%s' at %L must have an explicit "
 		    "function interface or be declared as array",
 		    sym->name, where);
-	  return;
+	  return FAILURE;
 	}
 
       if (sym->attr.allocatable)
 	{
 	  gfc_error("Allocatable function '%s' at %L must have an explicit "
 		    "function interface", sym->name, where);
-	  return;
+	  return FAILURE;
 	}
 
       for (a = *ap; a; a = a->next)
@@ -3009,7 +3009,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	      && a->expr->ts.type == BT_UNKNOWN)
 	    {
 	      gfc_error ("MOLD argument to NULL required at %L", &a->expr->where);
-	      return;
+	      return FAILURE;
 	    }
 
 	  /* TS 29113, C407b.  */
@@ -3018,19 +3018,23 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	    {
 	      gfc_error ("Assumed-rank argument requires an explicit interface "
 			 "at %L", &a->expr->where);
-	      return;
+	      return FAILURE;
 	    }
 	}
 
-      return;
+      return SUCCESS;
     }
 
   if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
-    return;
+    return FAILURE;
+
+  if (check_intents (sym->formal, *ap) == FAILURE)
+    return FAILURE;
 
-  check_intents (sym->formal, *ap);
   if (gfc_option.warn_aliasing)
     check_some_aliasing (sym->formal, *ap);
+
+  return SUCCESS;
 }
 
 

gcc/fortran/resolve.c

@@ -3011,20 +3011,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
             {
               /* TODO: Update this error message to allow for procedure
                  pointers once they are implemented.  */
-              gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+              gfc_error_now ("Argument '%s' to '%s' at %L must be a "
                              "procedure",
                              args_sym->name, sym->name,
                              &(args->expr->where));
               retval = FAILURE;
             }
-	  else if (args_sym->attr.is_bind_c != 1)
+	  else if (args_sym->attr.is_bind_c != 1
-	    {
+		   && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
-	      gfc_error_now ("Parameter '%s' to '%s' at %L must be "
+				      "argument '%s' to '%s' at %L",
-			     "BIND(C)",
+				      args_sym->name, sym->name,
-			     args_sym->name, sym->name,
+				      &(args->expr->where)) == FAILURE)
-			     &(args->expr->where));
+	    retval = FAILURE;
-	      retval = FAILURE;
-	    }
         }
       
       /* for c_loc/c_funloc, the new symbol is the same as the old one */
@@ -3479,7 +3477,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
 
   /* Make sure the actual arguments are in the necessary order (based on the 
      formal args) before resolving.  */
-  gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
+  if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
+    {
+      c->resolved_sym = sym;
+      return MATCH_ERROR;
+    }
 
   if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
       (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
@@ -3490,6 +3492,15 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
 	{
 	  if (c->ext.actual != NULL && c->ext.actual->next != NULL)
 	    {
+	      if (c->ext.actual->expr->ts.type != BT_DERIVED
+		  || c->ext.actual->expr->ts.u.derived->intmod_sym_id
+		     != ISOCBINDING_PTR)
+		{
+		  gfc_error ("Argument at %L to C_F_POINTER shall have the type"
+			     " C_PTR", &c->ext.actual->expr->where);
+		  m = MATCH_ERROR;
+		}
+
 	      /* Make sure we got a third arg if the second arg has non-zero
 		 rank.	We must also check that the type and rank are
 		 correct since we short-circuit this check in
@@ -3515,7 +3526,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
 		}
 	    }
 	}
-      
+      else /* ISOCBINDING_F_PROCPOINTER.  */
+	{
+	  if (c->ext.actual
+	      && (c->ext.actual->expr->ts.type != BT_DERIVED
+		  || c->ext.actual->expr->ts.u.derived->intmod_sym_id
+		     != ISOCBINDING_FUNPTR))
+	    {
+	      gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
+	                 "C_FUNPTR", &c->ext.actual->expr->where);
+              m = MATCH_ERROR;
+	    }
+	  if (c->ext.actual && c->ext.actual->next
+	      && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
+	      && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
+				 "procedure-pointer at %L to C_F_FUNPOINTER",
+				 &c->ext.actual->next->expr->where)
+		   == FAILURE)
+	    m = MATCH_ERROR;
+	}
+
       if (m != MATCH_ERROR)
 	{
 	  /* the 1 means to add the optional arg to formal list */

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2012-07-31  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/c_funloc_tests_6.f90: New.
+	* gfortran.dg/c_funloc_tests_7.f90: New.
+	* gfortran.dg/c_funloc_tests_5.f03: Compile with -std=f2003.
+
 2012-07-31  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/53624

gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03

@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=f2003" }
 ! Test that the arg checking for c_funloc verifies the procedures are 
 ! C interoperable.
 module c_funloc_tests_5
@@ -7,9 +8,9 @@ contains
   subroutine sub0() bind(c)
     type(c_funptr) :: my_c_funptr
 
-    my_c_funptr = c_funloc(sub1) ! { dg-error "must be BIND.C." }
+    my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" }
 
-    my_c_funptr = c_funloc(func0) ! { dg-error "must be BIND.C." }
+    my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" }
   end subroutine sub0
 
   subroutine sub1() 

gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90

@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! Check relaxed TS29113 constraints for procedures
+! and c_f_*pointer argument checking for c_ptr/c_funptr.
+!
+
+use iso_c_binding
+implicit none
+type(c_ptr) :: cp
+type(c_funptr) :: cfp
+
+interface
+  subroutine sub() bind(C)
+  end subroutine sub
+end interface
+integer(c_int), pointer :: int
+procedure(sub), pointer :: fsub
+
+integer, external :: noCsub
+procedure(integer), pointer :: fint
+
+cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." })
+cfp = c_loc (int)   ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
+
+call c_f_pointer (cfp, int)     ! { dg-error "Argument at .1. to C_F_POINTER shall have the type C_PTR" }
+call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" }
+
+cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }
+call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" }
+end

gcc/testsuite/gfortran.dg/c_funloc_tests_7.f90

@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-std=f2008ts -fdump-tree-original" }
+!
+! Check relaxed TS29113 constraints for procedures
+! and c_f_*pointer argument checking for c_ptr/c_funptr.
+!
+
+use iso_c_binding
+implicit none
+type(c_funptr) :: cfp
+
+integer, external :: noCsub
+procedure(integer), pointer :: fint
+
+cfp = c_funloc (noCsub)
+call c_f_procpointer (cfp, fint)
+end
+
+! { dg-final { scan-tree-dump-times "cfp =\[^;\]+ nocsub;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "fint =\[^;\]+ cfp;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+