OSDN Git Service

2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 23 Jul 2007 06:03:33 +0000 (06:03 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 23 Jul 2007 06:03:33 +0000 (06:03 +0000)
    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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126835 138bc75d-0d04-0410-961f-82ee72b054a4

12 files changed:
gcc/fortran/ChangeLog
gcc/fortran/resolve.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-types.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c [new file with mode: 0644]
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/gfortran.map
libgfortran/intrinsics/iso_c_binding.c
libgfortran/intrinsics/iso_c_binding.h

index 1ad6866..8db51b8 100644 (file)
@@ -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
index 45a49e2..891f9cf 100644 (file)
@@ -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 */
index 16148cb..1446d2b 100644 (file)
@@ -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);
+         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 5af85f1..2edb65a 100644 (file)
@@ -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
index 2cf110b..54cc7ac 100644 (file)
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03
new file mode 100644 (file)
index 0000000..0733c5e
--- /dev/null
@@ -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" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c b/gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c
new file mode 100644 (file)
index 0000000..17e4e65
--- /dev/null
@@ -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;
+}
diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
new file mode 100644 (file)
index 0000000..bbb418d
--- /dev/null
@@ -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 7cad67e..ae9d6b0 100644 (file)
@@ -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.
index f118bf3..c16dd1e 100644 (file)
@@ -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:
     *;
 };
index 101cc4e..29fb518 100644 (file)
@@ -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;
-}
index 1e51ad5..206359a 100644 (file)
@@ -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