This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH,fortran]: [Fwd: fix part of PR 32600] - c_funloc


This patch - by Chris - fixes the another part of PR 32600 - this time
for c_funloc.

Still missing are c_f_pointer (for the scalars) and c_associated (and
c_f_funpointer once procedure pointers are supported).

In a nutshell does this patch:
* Use a function pointer instead of "void *"
* Do the assignment directly and not via a library function.

Old dump (excerpt):
  void * t;
  t = c_funloc (sub1);
  t = c_funloc (sub2);

(Does anyone understand why this is not prefixed by __iso_c_binding_ ?
"nm libgfortran.a" shows that c_associated_* and c_f_pointer exist only
in properly prefixed form?)

New dump:
  void (*<T3a>) (void) t;
  t = sub1;
  t = (void (*<T3a>) (void)) sub2;

Build & regression tested on x86 Linux by Chris.
Build & regression tested on x86-64 Linux by me.

As I think the patch is OK (except for the leftover of another patch in
libgfortran/gfortran.map; there only the __iso_c_binding_c_funloc should
be removed), I plan to commit it in Monday unless there were any
objections until then.

Tobias

Changelog (spaces probably messed up by mail client):

2007-07-21  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.


2007-07-21  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-21  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.


-------- Original message --------
Subject: 	Re: c_funloc (was: [PATCH,fortran]: fix part of PR 32600)
Date: 	Fri, 20 Jul 2007 10:14:25 -0600 (MDT)
From: 	Christopher D. Rickett <crickett@lanl.gov>
To: 	Tobias Burnus <burnus@net-b.de>


hi Tobias,

i got a little time to look at this sooner than i expected.  your code for 
trans-types.c was very useful; it seems to correctly type the c_funptr as 
a function ptr now, rather than what i'd done with a simple void *.

i updated the places in trans-types.c where i set the type of c_funptr to 
use the funtion ptr decl you created.  also, i added code to trans-expr.c 
that seems to work for inlining c_funloc (but certainly could be tested 
more thoroughly).  i also modified the arg checking for c_funloc to ensure 
it's parameter is bind(c) (which requires it to be C interoperable).

i've bootstrapped and regtested on x86 linux with no new failures.  i 
haven't had time to test in on x86_64.  it would be appreciated if you 
could give it a try and see if it works as you'd expect.  if so, you're 
more than welcome to submit it as a patch to the list; i probably won't 
have time until the first part of next week.  i think you should 
definitely be included in the patch when it's submitted.

i apologize if the patch doesn't apply cleanly; my copy of trunk has 5 or 
so pending patches right now, so it's hard to come up with perfect, 
reduced-size patches.  ;-)

thanks again for your help.  i hope the patch works for you.  :-)
Chris

Index: gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c	(revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c	(revision 0)
@@ -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;
+}
Index: gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03	(revision 0)
@@ -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" } }
+
Index: gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03	(revision 0)
@@ -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
+
+
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 126797)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2060,31 +2055,40 @@ gfc_conv_function_call (gfc_se * se, gfc
   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);
+	  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;
+	  
+	      argss = gfc_walk_expr (arg->expr);
+	      gfc_conv_array_parameter (se, arg->expr, argss, f);
+	    }
+
+	  return 0;
 	}
-      else
+      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
 	{
-	  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;
-	  
-	  argss = gfc_walk_expr (arg->expr);
-	  gfc_conv_array_parameter (se, arg->expr, argss, f);
+	  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;
 	}
-
-      return 0;
     }
   
   if (se->ss != NULL)
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 126797)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -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 * sp
          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 * sp
         }
       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 * deriv
   /* 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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 126797)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1870,14 +1904,14 @@ gfc_iso_c_func_interface (gfc_symbol *sy
                              &(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 */
Index: libgfortran/intrinsics/iso_c_binding.c
===================================================================
--- libgfortran/intrinsics/iso_c_binding.c	(revision 126797)
+++ libgfortran/intrinsics/iso_c_binding.c	(working copy)
@@ -211,22 +232,3 @@ ISO_C_BINDING_PREFIX (c_associated_2) (v
   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;
-}
Index: libgfortran/intrinsics/iso_c_binding.h
===================================================================
--- libgfortran/intrinsics/iso_c_binding.h	(revision 126797)
+++ libgfortran/intrinsics/iso_c_binding.h	(working copy)
@@ -64,6 +64,4 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_u0
 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
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 126797)
+++ libgfortran/gfortran.map	(working copy)
@@ -1016,9 +1016,17 @@ GFORTRAN_1.0 {
     __iso_c_binding_c_f_pointer_r8;
     __iso_c_binding_c_f_pointer_r10;
     __iso_c_binding_c_f_pointer_r16;
+    __iso_c_binding_c_f_pointer_c4;
+    __iso_c_binding_c_f_pointer_c8;
+    __iso_c_binding_c_f_pointer_c10;
+    __iso_c_binding_c_f_pointer_c16;
+    __iso_c_binding_c_f_pointer_s0;
+    __iso_c_binding_c_f_pointer_l1;
+    __iso_c_binding_c_f_pointer_l2;
+    __iso_c_binding_c_f_pointer_l4;
+    __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:
     *;
 };
 
 

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]