re PR fortran/32600 ([ISO Bind C] C_F_POINTER w/o SHAPE should not be a library function)

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
	    Tobias Burnus  <burnus@net-b.de>

	PR fortran/32600
	* trans-expr.c (gfc_conv_function_call): Handle c_funloc.
	* trans-types.c: Add pfunc_type_node.
	(gfc_init_types,gfc_typenode_for_spec): Use it.
	* resolve.c (gfc_iso_c_func_interface): Fix whitespace and
	improve error message.

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32600
	* intrinsics/iso_c_binding.c (c_funloc): Remove.
	* intrinsics/iso_c_binding.h: Remove c_funloc.
	* gfortran.map: Ditto.

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32600
	* gfortran.dg/c_funloc_tests_5.f03: New.
	* gfortran.dg/c_funloc_tests_5.f04: New.
	* gfortran.dg/c_funloc_tests_4_driver.c: New.


Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r126835

gcc/fortran/ChangeLog

@@ -1,3 +1,13 @@
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32600
+	* trans-expr.c (gfc_conv_function_call): Handle c_funloc.
+	* trans-types.c: Add pfunc_type_node.
+	(gfc_init_types,gfc_typenode_for_spec): Use it.
+	* resolve.c (gfc_iso_c_func_interface): Fix whitespace and
+	improve error message.
+
 2007-07-22  Daniel Franke  <franke.daniel@gmail.com>
 
 	PR fortran/32710

gcc/fortran/resolve.c

@@ -1904,14 +1904,14 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
                              &(args->expr->where));
               retval = FAILURE;
             }
-          else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
-            {
-              gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
-                             "interoperable",
-                             args->expr->symtree->n.sym->name, sym->name,
-                             &(args->expr->where));
-              retval = FAILURE;
-            }
+	  else if (args->expr->symtree->n.sym->attr.is_bind_c != 1)
+	    {
+	      gfc_error_now ("Parameter '%s' to '%s' at %L must be "
+			     "BIND(C)",
+			     args->expr->symtree->n.sym->name, sym->name,
+			     &(args->expr->where));
+	      retval = FAILURE;
+	    }
         }
       
       /* for c_loc/c_funloc, the new symbol is the same as the old one */

gcc/fortran/trans-expr.c

@@ -2060,31 +2060,40 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   var = NULL_TREE;
   len = NULL_TREE;
 
-  if (sym->from_intmod == INTMOD_ISO_C_BINDING
-      && sym->intmod_sym_id == ISOCBINDING_LOC)
+  if (sym->from_intmod == INTMOD_ISO_C_BINDING)
     {
-      if (arg->expr->rank == 0)
+      if (sym->intmod_sym_id == ISOCBINDING_LOC)
 	{
-	  gfc_conv_expr_reference (se, arg->expr);
-	}
-      else
-	{
-	  int f;
-	  /* This is really the actual arg because no formal arglist is
-	     created for C_LOC.	 */
-	  fsym = arg->expr->symtree->n.sym;
+	  if (arg->expr->rank == 0)
+	    gfc_conv_expr_reference (se, arg->expr);
+	  else
+	    {
+	      int f;
+	      /* This is really the actual arg because no formal arglist is
+		 created for C_LOC.	 */
+	      fsym = arg->expr->symtree->n.sym;
 
-	  /* We should want it to do g77 calling convention.  */
-	  f = (fsym != NULL)
-	    && !(fsym->attr.pointer || fsym->attr.allocatable)
-	    && fsym->as->type != AS_ASSUMED_SHAPE;
-	  f = f || !sym->attr.always_explicit;
+	      /* We should want it to do g77 calling convention.  */
+	      f = (fsym != NULL)
+		&& !(fsym->attr.pointer || fsym->attr.allocatable)
+		&& fsym->as->type != AS_ASSUMED_SHAPE;
+	      f = f || !sym->attr.always_explicit;
 	  
-	  argss = gfc_walk_expr (arg->expr);
-	  gfc_conv_array_parameter (se, arg->expr, argss, f);
-	}
+	      argss = gfc_walk_expr (arg->expr);
+	      gfc_conv_array_parameter (se, arg->expr, argss, f);
+	    }
 
-      return 0;
+	  return 0;
+	}
+      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+	{
+	  arg->expr->ts.type = sym->ts.derived->ts.type;
+	  arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
+	  arg->expr->ts.kind = sym->ts.derived->ts.kind;
+	  gfc_conv_expr_reference (se, arg->expr);
+      
+	  return 0;
+	}
     }
   
   if (se->ss != NULL)

gcc/fortran/trans-types.c

@@ -60,6 +60,7 @@ tree gfc_character1_type_node;
 tree pvoid_type_node;
 tree ppvoid_type_node;
 tree pchar_type_node;
+tree pfunc_type_node;
 
 tree gfc_charlen_type_node;
 
@@ -733,6 +734,8 @@ gfc_init_types (void)
   pvoid_type_node = build_pointer_type (void_type_node);
   ppvoid_type_node = build_pointer_type (pvoid_type_node);
   pchar_type_node = build_pointer_type (gfc_character1_type_node);
+  pfunc_type_node
+    = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
 
   gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
   /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
@@ -842,7 +845,13 @@ gfc_typenode_for_spec (gfc_typespec * spec)
          has been resolved.  This is done so we can convert C_PTR and
          C_FUNPTR to simple variables that get translated to (void *).  */
       if (spec->f90_type == BT_VOID)
-        basetype = ptr_type_node;
+	{
+	  if (spec->derived
+	      && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+	    basetype = ptr_type_node;
+	  else
+	    basetype = pfunc_type_node;
+	}
       else
         basetype = gfc_get_int_type (spec->kind);
       break;
@@ -878,9 +887,17 @@ gfc_typenode_for_spec (gfc_typespec * spec)
         }
       break;
     case BT_VOID:
-       /* This is for the second arg to c_f_pointer and c_f_procpointer
-          of the iso_c_binding module, to accept any ptr type.  */
-       basetype = ptr_type_node;
+      /* This is for the second arg to c_f_pointer and c_f_procpointer
+         of the iso_c_binding module, to accept any ptr type.  */
+      basetype = ptr_type_node;
+      if (spec->f90_type == BT_VOID)
+	{
+	  if (spec->derived
+	      && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+	    basetype = ptr_type_node;
+	  else
+	    basetype = pfunc_type_node;
+	}
        break;
     default:
       gcc_unreachable ();
@@ -1653,7 +1670,10 @@ gfc_get_derived_type (gfc_symbol * derived)
   /* See if it's one of the iso_c_binding derived types.  */
   if (derived->attr.is_iso_c == 1)
     {
-      derived->backend_decl = ptr_type_node;
+      if (derived->intmod_sym_id == ISOCBINDING_PTR)
+	derived->backend_decl = ptr_type_node;
+      else
+	derived->backend_decl = pfunc_type_node;
       derived->ts.kind = gfc_index_integer_kind;
       derived->ts.type = BT_INTEGER;
       /* Set the f90_type to BT_VOID as a way to recognize something of type

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32600
+	* gfortran.dg/c_funloc_tests_5.f03: New.
+	* gfortran.dg/c_funloc_tests_5.f04: New.
+	* gfortran.dg/c_funloc_tests_4_driver.c: New.
+
 2007-07-22  Nathan Sidwell  <nathan@codesourcery.com>
 
 	PR c++/32839

gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03

@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-additional-sources c_funloc_tests_4_driver.c }
+! Test that the inlined c_funloc works.
+module c_funloc_tests_4
+  use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr
+  interface
+     subroutine c_sub0(fsub_ptr) bind(c)
+       use, intrinsic :: iso_c_binding, only: c_funptr
+       type(c_funptr), value :: fsub_ptr
+     end subroutine c_sub0
+     subroutine c_sub1(ffunc_ptr) bind(c)
+       use, intrinsic :: iso_c_binding, only: c_funptr
+       type(c_funptr), value :: ffunc_ptr
+     end subroutine c_sub1
+  end interface
+contains
+  subroutine sub0() bind(c)
+    type(c_funptr) :: my_c_funptr
+
+    my_c_funptr = c_funloc(sub1)
+    call c_sub0(my_c_funptr)
+
+    my_c_funptr = c_funloc(func0)
+    call c_sub1(my_c_funptr)
+  end subroutine sub0
+
+  subroutine sub1() bind(c)
+    print *, 'hello from sub1'
+  end subroutine sub1
+
+  function func0(desired_retval) bind(c)
+    use, intrinsic :: iso_c_binding, only: c_int
+    integer(c_int), value :: desired_retval
+    integer(c_int) :: func0
+    print *, 'hello from func0'
+    func0 = desired_retval
+  end function func0
+end module c_funloc_tests_4
+! { dg-final { cleanup-modules "c_funloc_tests_4" } }
+

gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c

@@ -0,0 +1,39 @@
+#include <stdio.h>
+
+void sub0(void);
+void c_sub0(void (*sub)(void));
+void c_sub1(int (*func)(int));
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+  printf("hello from C main\n");
+  
+  sub0();
+  return 0;
+}
+
+void c_sub0(void (*sub)(void))
+{
+  printf("hello from c_sub0\n");
+  sub();
+  
+  return;
+}
+
+void c_sub1(int (*func)(int))
+{
+  int retval;
+  
+  printf("hello from c_sub1\n");
+
+  retval = func(10);
+  if(retval != 10)
+  {
+    fprintf(stderr, "Fortran function did not return expected value!\n");
+    abort();
+  }
+
+  return;
+}

gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03

@@ -0,0 +1,26 @@
+! { dg-do compile }
+! Test that the arg checking for c_funloc verifies the procedures are 
+! C interoperable.
+module c_funloc_tests_5
+  use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr
+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(func0) ! { dg-error "must be BIND.C." }
+  end subroutine sub0
+
+  subroutine sub1() 
+  end subroutine sub1
+
+  function func0(desired_retval) 
+    use, intrinsic :: iso_c_binding, only: c_int
+    integer(c_int), value :: desired_retval
+    integer(c_int) :: func0
+    func0 = desired_retval
+  end function func0
+end module c_funloc_tests_5
+
+

libgfortran/ChangeLog

@@ -1,3 +1,10 @@
+2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32600
+	* intrinsics/iso_c_binding.c (c_funloc): Remove.
+	* intrinsics/iso_c_binding.h: Remove c_funloc.
+	* gfortran.map: Ditto.
+
 2007-07-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	* io/read.c (convert_real): Generate error only on EINVAL.

libgfortran/gfortran.map

@@ -1027,7 +1027,6 @@ GFORTRAN_1.0 {
     __iso_c_binding_c_f_pointer_l8;
     __iso_c_binding_c_f_pointer_u0;
     __iso_c_binding_c_f_procpointer;
-    __iso_c_binding_c_funloc;
   local:
     *;
 };

libgfortran/intrinsics/iso_c_binding.c

@@ -232,22 +232,3 @@ ISO_C_BINDING_PREFIX (c_associated_2) (void *c_ptr_in_1, void *c_ptr_in_2)
   else
     return 1;
 }
-
-
-/*  Return the C address of the given Fortran procedure.  This
-    routine is expected to return a derived type of type C_FUNPTR,
-    which represents the C address of the given Fortran object.  */
-
-void *
-ISO_C_BINDING_PREFIX (c_funloc) (void *f90_obj)
-{
-  if (f90_obj == NULL)
-    {
-      runtime_error ("C_LOC: Attempt to get C address for Fortran object"
-                     " that has not been allocated or associated");
-      abort ();
-    }
-
-  /* The "C" address should be the address of the object in Fortran.  */
-  return f90_obj;
-}

libgfortran/intrinsics/iso_c_binding.h

@@ -64,6 +64,4 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *,
 void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *,
 					   const array_t *);
 
-void *ISO_C_BINDING_PREFIX(c_funloc) (void *);
-
 #endif