aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog10
-rw-r--r--gcc/fortran/resolve.c16
-rw-r--r--gcc/fortran/trans-expr.c49
-rw-r--r--gcc/fortran/trans-types.c30
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/c_funloc_tests_4.f0340
-rw-r--r--gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c39
-rw-r--r--gcc/testsuite/gfortran.dg/c_funloc_tests_5.f0326
-rw-r--r--libgfortran/ChangeLog7
-rw-r--r--libgfortran/gfortran.map1
-rw-r--r--libgfortran/intrinsics/iso_c_binding.c19
-rw-r--r--libgfortran/intrinsics/iso_c_binding.h2
12 files changed, 191 insertions, 55 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1ad6866..8db51b8 100644
--- a/gcc/fortran/ChangeLog
+++ b/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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 45a49e2..891f9cf 100644
--- a/gcc/fortran/resolve.c
+++ b/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 */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 16148cb..1446d2b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/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);
+ 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)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 5af85f1..2edb65a 100644
--- a/gcc/fortran/trans-types.c
+++ b/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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2cf110b..54cc7ac 100644
--- a/gcc/testsuite/ChangeLog
+++ b/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
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
index 0000000..0733c5e
--- /dev/null
+++ b/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" } }
+
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
index 0000000..17e4e65
--- /dev/null
+++ b/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;
+}
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
index 0000000..bbb418d
--- /dev/null
+++ b/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
+
+
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 7cad67e..ae9d6b0 100644
--- a/libgfortran/ChangeLog
+++ b/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.
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index f118bf3..c16dd1e 100644
--- a/libgfortran/gfortran.map
+++ b/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:
*;
};
diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c
index 101cc4e0..29fb518 100644
--- a/libgfortran/intrinsics/iso_c_binding.c
+++ b/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;
-}
diff --git a/libgfortran/intrinsics/iso_c_binding.h b/libgfortran/intrinsics/iso_c_binding.h
index 1e51ad5..206359a 100644
--- a/libgfortran/intrinsics/iso_c_binding.h
+++ b/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
generated by cgit v1.1 at 2025-02-26 19:54:10 +0000