[Fortran-Experiments]: patch for c_ptr/c_funptr
Christopher D. Rickett
crickett@lanl.gov
Thu Mar 8 00:04:00 GMT 2007
hi all,
i've attached a patch that does the following:
- convert the iso_c_binding derived types to void * ptrs.
- changed the procedures in iso_c_binding to expect void * ptrs and
return them (if applicable).
- fixed whitespace and coding style issues in the
libgfortran/intrinsics/iso_c_* files.
- fixed a couple bugs listed on the wiki.
- new test cases.
the patch is fairly large, but the majority of it is simply whitespace and
style changes in the libgfortran/intrinsics/iso_c_* files. the goal of
this patch is to convert the iso_c_binding derived types into void ptrs.
this patch should at least be a start to that.
bootstrapped and regtested on x86 with no new failures.
ChangeLog entry:
2007-03-07 Christopher D. Rickett <crickett@lanl.gov>
* gfortran.dg/c_funloc_tests_3.f03: New test case.
* gfortran.dg/c_ptr_tests_7.f03: Ditto.
* gfortran.dg/c_ptr_tests_8.f03: Ditto.
* gfortran.dg/c_ptr_tests_9.f03: Ditto.
* gfortran.dg/c_loc_tests_7.f03: Ditto.
* gfortran.dg/c_funloc_tests_3_funcs.c: C functions for new test
case c_funloc_tests_3.
* gfortran.dg/binding_label_tests_14.f03: New test case.
* gfortran.dg/c_ptr_tests_10.f03: Ditto.
* gfortran.dg/c_ptr_tests_8_funcs.c: C functions for new test case
c_ptr_tests_8.
* gfortran.dg/c_ptr_tests_7_driver.c: C Driver for c_ptr_tests_7.
* trans-expr.c (gfc_conv_initializer): Convert expressions that
use C_NULL_PTR or C_NULL_FUNPTR to constant expressions for NULL.
(gfc_conv_expr): Convert typespecs for iso_c_binding derived types
to INTEGER(kind=gfc_index_integer_kind) (size of void *).
* symbol.c (gen_special_c_interop_ptr): Create C_PTR or C_FUNPTR
if not listed by user in only clause and are needed.
(generate_isocbinding_symbol): Create C_PTR or C_FUNPTR if not
listed by user in only clause and are needed.
* decl.c (verify_c_interop_param): Report error for procedures
that are not BIND(C) but need to be a C interoperable parameter.
* trans-const.c (gfc_conv_constant): Convert expressions for
C_NULL_PTR and C_NULL_FUNPTR to constant expressions for NULL.
* trans-types.c (gfc_typenode_for_spec): Convert typespecs for
iso_c_binding derived types.
(gfc_get_derived_type): Set the backend_decl of the iso_c_binding
derived types to ptr_type_nodes (void *), of type
INTEGER(kind=gfc_index_integer_kind), and f90_type of BT_VOID.
Removed code that was used when the tree for the iso_c_binding
derived types represented derived types instead of ptr_type_node.
* resolve.c (is_scalar_expr_ptr): Allow for arrays of size 1.
(gfc_verify_binding_labels): Fixed ICE caused by NULL pointer.
(resolve_fl_procedure): Clear the is_bind_c attribute if the
symbol has an error (prevents duplicate messages).
* trans-decl.c (gfc_create_module_variable): Make sure the
typespecs for iso_c_binding derived types are converted for
ptr_type_node.
(generate_local_decl): Ditto.
* trans-io.c (transfer_expr): Convert expressions for
iso_c_binding derived types.
* iso_c_generated_procs.c (c_f_pointer_i1): Made C pointer
parameter of type (void *). Fixed whitespace and coding style.
(c_f_pointer_i2): Ditto.
(c_f_pointer_i4): Ditto.
(c_f_pointer_i8): Ditto.
(c_f_pointer_i16): Ditto.
(c_f_pointer_r4): Ditto.
(c_f_pointer_r8): Ditto.
(c_f_pointer_r10): Ditto.
(c_f_pointer_r16): Ditto.
* iso_c_binding.c (c_f_pointer): Made C pointer parameter of type
(void *). Fixed whitespace and coding style.
(c_f_pointer_u0): Ditto.
(c_f_pointer_d0): Ditto.
(c_f_procpointer): Ditto.
(c_associated_1): Ditto. Converted return type to void *.
(c_associated_2): Ditto.
(c_loc): Ditto.
(c_funloc): Ditto.
* iso_c_binding.h: Updated prototypes.
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/c_ptr_tests.f90
===================================================================
Index: gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_3.f03 (revision 0)
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-additional-sources c_funloc_tests_3_funcs.c }
+! This testcase tests c_funloc and c_funptr from iso_c_binding. It uses
+! functions defined in c_funloc_tests_3_funcs.c.
+module c_funloc_tests_3
+ implicit none
+contains
+ function ffunc(j) bind(c)
+ use iso_c_binding, only: c_funptr, c_int
+ integer(c_int) :: ffunc
+ integer(c_int), value :: j
+ ffunc = -17*j
+ end function ffunc
+end module c_funloc_tests_3
+program main
+ use iso_c_binding, only: c_funptr, c_funloc
+ use c_funloc_tests_3, only: ffunc
+ implicit none
+ interface
+ function returnFunc() bind(c,name="returnFunc")
+ use iso_c_binding, only: c_funptr
+ type(c_funptr) :: returnFunc
+ end function returnFunc
+ subroutine callFunc(func,pass,compare) bind(c,name="callFunc")
+ use iso_c_binding, only: c_funptr, c_int
+ type(c_funptr), value :: func
+ integer(c_int), value :: pass,compare
+ end subroutine callFunc
+ end interface
+ type(c_funptr) :: p
+ p = returnFunc()
+ call callFunc(p, 13,3*13)
+ p = c_funloc(ffunc)
+ call callFunc(p, 21,-17*21)
+end program main
+! { dg-final { cleanup-modules "c_funloc_tests_3" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_7.f03 (revision 0)
@@ -0,0 +1,12 @@
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_7_driver.c }
+module c_ptr_tests_7
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+contains
+ function func0() bind(c)
+ type(c_ptr) :: func0
+ func0 = c_null_ptr
+ end function func0
+end module c_ptr_tests_7
+! { dg-final { cleanup-modules "c_ptr_tests_7" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_8.f03 (revision 0)
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_8_funcs.c }
+program main
+use iso_c_binding, only: c_ptr
+implicit none
+interface
+ function create() bind(c)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr) :: create
+ end function create
+ subroutine show(a) bind(c)
+ import :: c_ptr
+ type(c_ptr), VALUE :: a
+ end subroutine show
+end interface
+
+type(c_ptr) :: ptr
+ptr = create()
+call show(ptr)
+end program main
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 (revision 0)
@@ -0,0 +1,31 @@
+! { dg-do run }
+! This test is pretty simple but is here just to make sure that the changes
+! done to c_ptr and c_funptr (translating them to void *) works in the case
+! where a component of a type is of type c_ptr or c_funptr.
+module c_ptr_tests_9
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+ type myF90Derived
+ type(c_ptr) :: my_c_ptr
+ end type myF90Derived
+
+contains
+ subroutine sub0() bind(c)
+ type(myF90Derived), target :: my_f90_type
+ type(myF90Derived), pointer :: my_f90_type_ptr
+
+ my_f90_type%my_c_ptr = c_null_ptr
+ print *, 'my_f90_type is: ', my_f90_type
+ my_f90_type_ptr => my_f90_type
+ print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
+ end subroutine sub0
+end module c_ptr_tests_9
+
+
+program main
+ use c_ptr_tests_9
+
+ call sub0()
+end program main
+
+! { dg-final { cleanup-modules "c_ptr_tests_9" } }
Index: gcc/testsuite/gfortran.dg/c_loc_tests_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_7.f03 (revision 0)
@@ -0,0 +1,11 @@
+! { dg-do compile }
+module c_loc_tests_7
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+ TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+ CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR
+ argv(1)=C_LOC(empty_string)
+END SUBROUTINE
+end module c_loc_tests_7
+! { dg-final { cleanup-modules "c_loc_tests_7" } }
Index: gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_3_funcs.c (revision 0)
@@ -0,0 +1,25 @@
+/* These functions support the test case c_funloc_tests_3. */
+#include <stdlib.h>
+#include <stdio.h>
+
+int printIntC(int i)
+{
+ return 3*i;
+}
+
+int (*returnFunc(void))(int)
+{
+ return &printIntC;
+}
+
+void callFunc(int(*func)(int), int pass, int compare)
+{
+ int result = (*func)(pass);
+ if(result != compare)
+ {
+ printf("FAILED: Got %d, expected %d\n", result, compare);
+ abort();
+ }
+ else
+ printf("SUCCESS: Got %d, expected %d\n", result, compare);
+}
Index: gcc/testsuite/gfortran.dg/binding_label_tests_14.f03
===================================================================
--- gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/binding_label_tests_14.f03 (revision 0)
@@ -0,0 +1,12 @@
+! { dg-do run }
+subroutine display() bind(c)
+ implicit none
+end subroutine display
+
+program main
+ implicit none
+ interface
+ subroutine display() bind(c)
+ end subroutine display
+ end interface
+end program main
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 (revision 0)
@@ -0,0 +1,18 @@
+! { dg-run }
+! This test case exists because gfortran had an error in converting the
+! expressions for the derived types from iso_c_binding in some cases.
+module c_ptr_tests_10
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+contains
+ subroutine sub0() bind(c)
+ print *, 'c_null_ptr is: ', c_null_ptr
+ end subroutine sub0
+end module c_ptr_tests_10
+
+program main
+ use c_ptr_tests_10
+ call sub0()
+end program main
+
+! { dg-final { cleanup-modules "c_ptr_tests_10" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_8_funcs.c (revision 0)
@@ -0,0 +1,26 @@
+/* This file provides auxilliary functions for c_ptr_tests_8. */
+
+#include <malloc.h>
+#include <stdio.h>
+
+extern void abort (void);
+
+void *create (void)
+{
+ int *a;
+ a = malloc (sizeof (a));
+ *a = 444;
+ return a;
+
+}
+
+void show (int *a)
+{
+ if (*a == 444)
+ printf ("SUCCESS (%d)\n", *a);
+ else
+ {
+ printf ("FAILED: Expected 444, received %d\n", *a);
+ abort ();
+ }
+}
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_7_driver.c (revision 0)
@@ -0,0 +1,14 @@
+/* This is the driver for c_ptr_test_7. */
+extern void abort(void);
+
+void *func0();
+
+int main(int argc, char **argv)
+{
+ /* The Fortran module c_ptr_tests_7 contains function func0, which has
+ return type of c_ptr, and should set the return value to c_null_ptr. */
+ if (func0() != 0)
+ abort();
+
+ return 0;
+}
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 122595)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2696,6 +2696,12 @@ gfc_conv_initializer (gfc_expr * expr, g
if (!(expr || pointer))
return NULL_TREE;
+ if (expr != NULL && expr->ts.type == BT_DERIVED
+ && expr->ts.is_iso_c && expr->ts.derived)
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ expr = gfc_int_expr (0);
+
if (array)
{
/* Arrays need special handling. */
@@ -3084,6 +3090,31 @@ gfc_conv_expr (gfc_se * se, gfc_expr * e
return;
}
+ /* We need to convert the expressions for the iso_c_binding derived types.
+ C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
+ null_pointer_node. C_PTR and C_FUNPTR are converted to match the
+ typespec for the C_PTR and C_FUNPTR symbols, which has already been
+ updated to be an integer with a kind equal to the size of a (void *). */
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived
+ && expr->ts.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Try simply setting expr_type to EXPR_NUL, which should result
+ in null_pointer_node being used below. */
+ expr->expr_type = EXPR_NULL;
+ }
+ else
+ {
+ /* Update the type/kind of the expression to be what the new
+ type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
+ expr->ts.type = expr->ts.derived->ts.type;
+ expr->ts.f90_type = expr->ts.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.derived->ts.kind;
+ }
+ }
+
switch (expr->expr_type)
{
case EXPR_OP:
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 122595)
+++ gcc/fortran/symbol.c (working copy)
@@ -3101,7 +3101,7 @@ verify_bind_c_derived_type (gfc_symbol *
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
-static void
+static try
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
const char *module_name)
{
@@ -3126,14 +3126,13 @@ gen_special_c_interop_ptr (int ptr_id, c
tmp_sym->attr.is_c_interop = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
-
+
/* The c_ptr and c_funptr derived types will provide the
definition for c_null_ptr and c_null_funptr, respectively. */
if (ptr_id == ISOCBINDING_NULL_PTR)
tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR, 1);
else
tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR, 1);
-
if (tmp_sym->ts.derived == NULL)
{
/* This can occur if the user forgot to declare c_ptr or
@@ -3141,13 +3140,16 @@ gen_special_c_interop_ptr (int ptr_id, c
that has arg(s) of the missing type. In this case, a
regular version of the thing should have been put in the
current ns. */
- gfc_error_now ("'%s' at %C requires '%s' to be defined",
- tmp_sym->name, ptr_name);
- gfc_free_symbol (tmp_sym);
- return;
+ generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
+ (char *)(ptr_id == ISOCBINDING_NULL_PTR
+ ? "c_ptr" : "c_funptr"));
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR, 1);
}
-
- /* module name is some mangled version of iso_c_binding. */
+
+ /* Module name is some mangled version of iso_c_binding. */
tmp_sym->module = gfc_get_string (module_name);
/* Say it's from the iso_c_binding module. */
@@ -3171,8 +3173,8 @@ gen_special_c_interop_ptr (int ptr_id, c
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
-
- return;
+
+ return SUCCESS;
}
@@ -3583,6 +3585,8 @@ generate_isocbinding_symbol (const char
the binding label is not used. */
tmp_sym->attr.is_bind_c = 1;
+ tmp_sym->attr.referenced = 1;
+
tmp_sym->ts.derived = tmp_sym;
/* Add the symbol created for the derived type to the current ns. */
@@ -3674,15 +3678,17 @@ generate_isocbinding_symbol (const char
if (tmp_sym->ts.derived == NULL)
{
- gfc_error_now ("Type '%s' is not defined but is needed "
- "as return type of function '%s' at %C",
- (s == ISOCBINDING_LOC ?
- "C_PTR" : "C_FUNPTR"),
- c_interop_kinds_table[s].name);
- /* Remove the procedure symbol since it's invalid without
- the necessary type. */
- gfc_free_symbol (tmp_sym);
- return;
+ /* Create the necessary derived type so we can continue
+ processing the file. */
+ generate_isocbinding_symbol
+ (mod_name, s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR : ISOCBINDING_FUNPTR,
+ (char *)(s == ISOCBINDING_FUNLOC
+ ? "c_funptr" : "c_ptr"));
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR
+ : ISOCBINDING_PTR, 1);
}
/* The function result is itself (no result clause). */
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 122595)
+++ gcc/fortran/decl.c (working copy)
@@ -761,7 +761,13 @@ verify_c_interop_param (gfc_symbol *sym)
if (sym->attr.flavor == FL_PROCEDURE)
{
if (sym->attr.is_bind_c == 0)
- return FAILURE;
+ {
+ gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
+ "attribute to be C interoperable", sym->name,
+ &(sym->declared_at));
+
+ return FAILURE;
+ }
else
{
if (sym->attr.is_c_interop == 1)
Index: gcc/fortran/trans-const.c
===================================================================
--- gcc/fortran/trans-const.c (revision 122595)
+++ gcc/fortran/trans-const.c (working copy)
@@ -345,6 +345,20 @@ gfc_conv_constant_to_tree (gfc_expr * ex
void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
+ /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
+ so, they expr_type will not yet be an EXPR_CONSTANT. We need to make
+ it so here. */
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived
+ && expr->ts.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Create a new EXPR_CONSTANT expression for our local uses. */
+ expr = gfc_int_expr (0);
+ }
+ }
+
gcc_assert (expr->expr_type == EXPR_CONSTANT);
if (se->ss != NULL)
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (revision 122595)
+++ gcc/fortran/trans-types.c (working copy)
@@ -80,10 +80,6 @@ gfc_real_info gfc_real_kinds[MAX_REAL_KI
static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
-#define NUM_C_DERIVED_TYPES 2 /* c_ptr and c_funptr */
-#define C_PTR_TYPE_INDEX 0 /* index of c_ptr type tree */
-#define C_FUNPTR_TYPE_INDEX 1 /* index of c_funptr type tree */
-static tree gfc_iso_c_derived_types[NUM_C_DERIVED_TYPES];
/* The integer kind to use for array indices. This will be set to the
proper value based on target information from the backend. */
@@ -837,7 +833,13 @@ gfc_typenode_for_spec (gfc_typespec * sp
gcc_unreachable ();
case BT_INTEGER:
- basetype = gfc_get_int_type (spec->kind);
+ /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
+ 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;
+ else
+ basetype = gfc_get_int_type (spec->kind);
break;
case BT_REAL:
@@ -858,11 +860,21 @@ gfc_typenode_for_spec (gfc_typespec * sp
case BT_DERIVED:
basetype = gfc_get_derived_type (spec->derived);
+
+ /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
+ type and kind to fit a (void *) and the basetype returned was a
+ ptr_type_node. We need to pass up this new information to the
+ symbol that was declared of type C_PTR or C_FUNPTR. */
+ if (spec->derived->attr.is_iso_c)
+ {
+ spec->type = spec->derived->ts.type;
+ spec->kind = spec->derived->ts.kind;
+ spec->f90_type = spec->derived->ts.f90_type;
+ }
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.
- */
+ /* 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;
break;
default:
@@ -1575,42 +1587,6 @@ gfc_add_field_to_struct (tree *fieldlist
}
-/* Check whether the given derived type is from the iso_c_binding
- intrinsic module. Returns 1 if is from the iso_c_binding module; 0
- if not. */
-
-static int
-check_iso_c_derived (gfc_symbol *derived)
-{
- /* this should only be 1 for c_ptr and c_funptr; 0 otherwise */
- return derived->attr.is_iso_c;
-}
-
-
-/* Get the stored iso_c_binding derived type for either c_ptr or
- c_funptr. A reference is stored to the first of these created for
- a given namespace because when the expressions they are used in are
- being generated, the types are checked to see if they are the same.
- The checks are limited to if they point to the same object. Even
- if the fields are all identical in type, the derived types could
- not be used in expressions for each other, such as assigning one to
- the other. Therefore, to allow this to work, they will share an
- underlying derived type definition, so the definitions for these
- are stored to be used for all variables declared of type c_ptr or
- c_funptr. Returns the tree that was created for the given ISO C
- derived type. */
-
-static tree
-get_iso_c_derived (gfc_symbol *derived)
-{
- if (derived->from_intmod == INTMOD_ISO_C_BINDING &&
- derived->intmod_sym_id == ISOCBINDING_PTR)
- return gfc_iso_c_derived_types[C_PTR_TYPE_INDEX];
- else
- return gfc_iso_c_derived_types[C_FUNPTR_TYPE_INDEX];
-}
-
-
/* Copy the backend_decl and component backend_decls if
the two derived type symbols are "equal", as described
in 4.4.2 and resolved by gfc_compare_derived_types. */
@@ -1660,18 +1636,22 @@ gfc_get_derived_type (gfc_symbol * deriv
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
gfc_component *c;
- tree iso_c_tree = NULL;
gfc_dt_list *dt;
gfc_namespace * ns;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
- /* see if it's one of the iso_c_binding derived types */
- if(check_iso_c_derived(derived) == 1)
+ /* See if it's one of the iso_c_binding derived types. */
+ if (derived->attr.is_iso_c == 1)
{
- iso_c_tree = get_iso_c_derived (derived);
- if (iso_c_tree != NULL && derived->backend_decl == NULL)
- derived->backend_decl = iso_c_tree;
+ derived->backend_decl = ptr_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
+ BT_INTEGER that needs to fit a void * for the purpose of the
+ iso_c_binding derived types. */
+ derived->ts.f90_type = BT_VOID;
+ return derived->backend_decl;
}
/* derived->backend_decl != 0 means we saw it before, but its
@@ -1680,18 +1660,7 @@ gfc_get_derived_type (gfc_symbol * deriv
{
/* Its components' backend_decl have been built. */
if (TYPE_FIELDS (derived->backend_decl))
- if (iso_c_tree != NULL)
- {
- if (!(derived->components->backend_decl))
- /* If we're working on building this for an iso c
- type in a different ns than when we started, this
- may not have been set yet. */
- derived->components->backend_decl =
- iso_c_tree->type.values;
- return iso_c_tree;
- }
- else
- return derived->backend_decl;
+ return derived->backend_decl;
else
typenode = derived->backend_decl;
}
@@ -1732,29 +1701,10 @@ gfc_get_derived_type (gfc_symbol * deriv
}
/* We see this derived type first time, so build the type node. */
- if(iso_c_tree != NULL)
- {
- derived->backend_decl = iso_c_tree;
- }
- else
- {
- typenode = make_node (RECORD_TYPE);
- TYPE_NAME (typenode) = get_identifier (derived->name);
- TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
- derived->backend_decl = typenode;
-
- /* there should be a cleaner way to do this..
- * --Rickett, 06.12.06
- */
- if ((derived->from_intmod == INTMOD_ISO_C_BINDING &&
- derived->intmod_sym_id == ISOCBINDING_PTR) &&
- gfc_iso_c_derived_types[C_PTR_TYPE_INDEX] == NULL)
- gfc_iso_c_derived_types[C_PTR_TYPE_INDEX] = typenode;
- else if ((derived->from_intmod == INTMOD_ISO_C_BINDING &&
- derived->intmod_sym_id == ISOCBINDING_FUNPTR) &&
- gfc_iso_c_derived_types[C_FUNPTR_TYPE_INDEX] == NULL)
- gfc_iso_c_derived_types[C_FUNPTR_TYPE_INDEX] = typenode;
- }
+ typenode = make_node (RECORD_TYPE);
+ TYPE_NAME (typenode) = get_identifier (derived->name);
+ TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
+ derived->backend_decl = typenode;
}
/* Go through the derived type components, building them as
@@ -1769,6 +1719,16 @@ gfc_get_derived_type (gfc_symbol * deriv
if (!c->pointer || c->ts.derived->backend_decl == NULL)
c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+
+ if (c->ts.derived && c->ts.derived->attr.is_iso_c)
+ {
+ /* Need to copy the modified ts from the derived type. The
+ typespec was modified because C_PTR/C_FUNPTR are translated
+ into (void *) from derived types. */
+ c->ts.type = c->ts.derived->ts.type;
+ c->ts.kind = c->ts.derived->ts.kind;
+ c->ts.f90_type = c->ts.derived->ts.f90_type;
+ }
}
if (TYPE_FIELDS (derived->backend_decl))
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 122595)
+++ gcc/fortran/resolve.c (working copy)
@@ -1558,7 +1558,33 @@ is_scalar_expr_ptr (gfc_expr *expr)
retval = FAILURE;
break;
case REF_ARRAY:
- if (ref->u.ar.type != AR_ELEMENT)
+ if (ref->u.ar.type == AR_ELEMENT)
+ retval = SUCCESS;
+ else if (ref->u.ar.type == AR_FULL)
+ {
+ /* The user can give a full array if the array is of size 1. */
+ if (ref->u.ar.as != NULL
+ && ref->u.ar.as->rank == 1
+ && ref->u.ar.as->type == AS_EXPLICIT
+ && ref->u.ar.as->lower[0] != NULL
+ && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
+ && ref->u.ar.as->upper[0] != NULL
+ && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
+ {
+ /* We have constant lower and upper bounds. If the
+ difference between is 1, it can be considered a
+ scalar. */
+ start = (int) mpz_get_si
+ (ref->u.ar.as->lower[0]->value.integer);
+ end = (int) mpz_get_si
+ (ref->u.ar.as->upper[0]->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
+ else
+ retval = FAILURE;
+ }
+ else
retval = FAILURE;
break;
default:
@@ -5877,8 +5903,8 @@ gfc_verify_binding_labels (gfc_symbol *s
gfc_gsymbol *bind_c_sym;
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
- if (bind_c_sym != NULL
- && strcmp (bind_c_sym->name, sym->binding_label) == 0)
+ if (bind_c_sym != NULL
+ && strcmp (bind_c_sym->name, sym->binding_label) == 0)
{
if (sym->attr.if_source == IFSRC_DECL
&& (bind_c_sym->type != GSYM_SUBROUTINE
@@ -5898,7 +5924,8 @@ gfc_verify_binding_labels (gfc_symbol *s
else if (sym->attr.contained == 0
&& (sym->attr.if_source == IFSRC_IFBODY
&& sym->attr.flavor == FL_PROCEDURE)
- && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ && (bind_c_sym->sym_name != NULL
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0))
{
/* Make sure procedures in interface bodies don't collide. */
gfc_error ("Binding label '%s' in interface body at %L collides "
@@ -6453,8 +6480,12 @@ resolve_fl_procedure (gfc_symbol *sym, i
if (curr_arg->sym->attr.implicit_type == 0
&& verify_c_interop_param (curr_arg->sym) == FAILURE)
{
+ /* If something is found to fail, mark the symbol for the
+ procedure as not being BIND(C) to try and prevent multiple
+ errors being reported. */
sym->attr.is_c_interop = 0;
sym->ts.is_c_interop = 0;
+ sym->attr.is_bind_c = 0;
}
curr_arg = curr_arg->next;
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 122595)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -2796,6 +2796,12 @@ gfc_create_module_variable (gfc_symbol *
if (sym->attr.entry)
return;
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
@@ -3074,6 +3080,12 @@ generate_local_decl (gfc_symbol * sym)
if (sym->attr.value == 1 && sym->backend_decl != NULL)
set_tree_decl_type_code (sym);
}
+
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
}
static void
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 122595)
+++ gcc/fortran/trans-io.c (working copy)
@@ -1686,6 +1686,17 @@ transfer_expr (gfc_se * se, gfc_typespec
gfc_component *c;
int kind;
+ /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
+ the user says something like: print *, 'c_null_ptr: ', c_null_ptr
+ We need to translate the expression to a constant if it's either
+ C_NULL_PTR or C_NULL_FUNPTR. */
+ if (ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+ {
+ ts->type = ts->derived->ts.type;
+ ts->kind = ts->derived->ts.kind;
+ ts->f90_type = ts->derived->ts.f90_type;
+ }
+
kind = ts->kind;
function = NULL;
arg2 = NULL;
Index: libgfortran/intrinsics/iso_c_generated_procs.c
===================================================================
--- libgfortran/intrinsics/iso_c_generated_procs.c (revision 122595)
+++ libgfortran/intrinsics/iso_c_generated_procs.c (working copy)
@@ -10,49 +10,49 @@
*/
#ifdef HAVE_GFC_INTEGER_1
-void ISO_C_BINDING_PREFIX(c_f_pointer_i1) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_INTEGER_2
-void ISO_C_BINDING_PREFIX(c_f_pointer_i2) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_INTEGER_4
-void ISO_C_BINDING_PREFIX(c_f_pointer_i4)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_INTEGER_8
-void ISO_C_BINDING_PREFIX(c_f_pointer_i8)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_INTEGER_16
-void ISO_C_BINDING_PREFIX(c_f_pointer_i16) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_REAL_4
-void ISO_C_BINDING_PREFIX(c_f_pointer_r4)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_REAL_8
-void ISO_C_BINDING_PREFIX(c_f_pointer_r8)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_REAL_10
-void ISO_C_BINDING_PREFIX(c_f_pointer_r10)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
#ifdef HAVE_GFC_REAL_16
-void ISO_C_BINDING_PREFIX(c_f_pointer_r16)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape);
+void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape);
#endif
@@ -65,15 +65,16 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_r1
address, if applicable. 'shape' is an optional parameter in
Fortran, so if the user does not provide it, it will come in here
as NULL. */
+
void
-ISO_C_BINDING_PREFIX (c_f_pointer_i1) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an integer(kind=1). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
- (int) GFC_DTYPE_INTEGER,
- (int) sizeof (GFC_INTEGER_1));
+ (int)GFC_DTYPE_INTEGER,
+ (int)sizeof(GFC_INTEGER_1));
return;
}
#endif
@@ -88,72 +89,51 @@ ISO_C_BINDING_PREFIX (c_f_pointer_i1) (c
address, if applicable. 'shape' is an optional parameter in
Fortran, so if the user does not provide it, it will come in here
as NULL. */
+
void
-ISO_C_BINDING_PREFIX (c_f_pointer_i2) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
- /* here we have an integer(kind=2) */
- ISO_C_BINDING_PREFIX(c_f_pointer) (c_ptr_in, f_ptr_out, shape,
- (int) GFC_DTYPE_INTEGER,
- (int) sizeof (GFC_INTEGER_2));
+ /* Here we have an integer(kind=2). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int)GFC_DTYPE_INTEGER,
+ (int)sizeof(GFC_INTEGER_2));
return;
}
#endif
#ifdef HAVE_GFC_INTEGER_4
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>integer</code> and <code>kind=4</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_i4) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type integer and
+ kind=4. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an integer(kind=4). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
(int) GFC_DTYPE_INTEGER,
(int) sizeof (GFC_INTEGER_4));
- return;
+ return;
}
#endif
#ifdef HAVE_GFC_INTEGER_8
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>integer</code> and <code>kind=8</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_i8) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type integer and
+ kind=8. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
- /* here we have an integer(kind=8) */
+ /* Here we have an integer(kind=8). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
(int) GFC_DTYPE_INTEGER,
(int) sizeof (GFC_INTEGER_8));
@@ -171,40 +151,30 @@ ISO_C_BINDING_PREFIX (c_f_pointer_i8) (c
address, if applicable. 'shape' is an optional parameter in
Fortran, so if the user does not provide it, it will come in here
as NULL. */
+
void
-ISO_C_BINDING_PREFIX (c_f_pointer_i16) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an integer(kind=16). */
- ISO_C_BINDING_PREFIX(c_f_pointer) (c_ptr_in, f_ptr_out, shape,
- (int) GFC_DTYPE_INTEGER,
- (int) sizeof (GFC_INTEGER_16));
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int)GFC_DTYPE_INTEGER,
+ (int)sizeof(GFC_INTEGER_16));
return;
}
#endif
#ifdef HAVE_GFC_REAL_4
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>real</code> and <code>kind=4</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_r4) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=4. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an real(kind=4). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
@@ -216,27 +186,16 @@ ISO_C_BINDING_PREFIX (c_f_pointer_r4) (c
#ifdef HAVE_GFC_REAL_8
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>real</code> and <code>kind=8</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_r8) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=8. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
- /* here we have an real(kind=8) */
+ /* Here we have an real(kind=8). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
(int) GFC_DTYPE_REAL,
(int) sizeof (GFC_REAL_8));
@@ -246,55 +205,33 @@ ISO_C_BINDING_PREFIX (c_f_pointer_r8) (c
#ifdef HAVE_GFC_REAL_10
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>real</code> and <code>kind=10</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_r10) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=10. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an real(kind=10). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
- (int) GFC_DTYPE_REAL,
- (int) sizeof(GFC_REAL_10));
+ (int) GFC_DTYPE_REAL,
+ (int) sizeof(GFC_REAL_10));
return;
}
#endif
#ifdef HAVE_GFC_REAL_16
-/**
- * Set the given Fortran pointer, <code>f_ptr_out</code>, to point
- * to the given C address, <code>c_ptr_in</code>. The Fortran pointer
- * is of type <code>real</code> and <code>kind=16</code>. The
- * function <code>c_f_pointer</code> is used to set up the pointer
- * descriptor.
- *
- * @param c_ptr_in The C address to associate the Fortran pointer with.
- * @param f_ptr_out The Fortran pointer to associate with the given
- * C address.
- * @param shape One-dimensional array of integers specifying the upper
- * bounds of the array pointed to by the given C address, if applicable.
- * @note: This is an optional parameter in Fortran, so if the user does
- * not provide it, it will come in here as <code>NULL</code>.
- */
-void
-ISO_C_BINDING_PREFIX (c_f_pointer_r16) (c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=16. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
/* Here we have an real(kind=16). */
ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
Index: libgfortran/intrinsics/iso_c_binding.c
===================================================================
--- libgfortran/intrinsics/iso_c_binding.c (revision 122595)
+++ libgfortran/intrinsics/iso_c_binding.c (working copy)
@@ -10,257 +10,200 @@
#include "iso_c_binding.h"
-/**
- * Set the fields of a Fortran pointer descriptor to point to the
- * given C address. It uses <code>c_f_pointer_u0</code> for the
- * common fields, and will set up the information necessary if this
- * C address is to an array (i.e., offset, type, element size).
- *
- * @param c_ptr_in The <code>c_ptr_t</code> representing the C address
- * to have Fortran point to.
- * @param f_ptr_out The Fortran pointer to have point to the given C
- * address.
- * @param shape One-dimensional array of integers specifying the upper
- * bound(s) of the array pointed to by the given C address, if applicable.
- * @note: this parameter is optional in Fortran, which will cause it to
- * come in here as <code>NULL</code>.
- * @param type The type of the data being pointed to. @see libgfortran.h
- * where the <code>GFC_DTYPE_*</code> are defined.
- * @param elem_size The size, in bytes, of the data element being
- * pointed to. If the address is for an array, then the size needs to
- * be the size of a single element (i.e., for an array of doubles, it
- * needs to be the number of bytes for the size of one double).
- * @return none
- */
-void ISO_C_BINDING_PREFIX(c_f_pointer)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape,
- int type, int elemSize)
+/* Set the fields of a Fortran pointer descriptor to point to the
+ given C address. It uses <code>c_f_pointer_u0</code> for the common
+ fields, and will set up the information necessary if this C address
+ is to an array (i.e., offset, type, element size). The parameter
+ c_ptr_in represents the C address to have Fortran point to. The
+ parameter f_ptr_out is the Fortran pointer to associate with the C
+ address. The parameter shape is a one-dimensional array of integers
+ specifying the upper bound(s) of the array pointed to by the given C
+ address, if applicable. The shape parameter is optional in Fortran,
+ which will cause it to come in here as NULL. The parameter type is
+ the type of the data being pointed to (i.e.,libgfortran.h). The
+ elem_size parameter is the size, in bytes, of the data element being
+ pointed to. If the address is for an array, then the size needs to
+ be the size of a single element (i.e., for an array of doubles, it
+ needs to be the number of bytes for the size of one double). */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape,
+ int type, int elemSize)
{
- if(shape != NULL)
- {
+ if (shape != NULL)
+ {
f_ptr_out->offset = 0;
- /* set the necessary dtype field for all pointers */
+ /* Set the necessary dtype field for all pointers. */
f_ptr_out->dtype = 0;
- /* put in the element size */
+ /* Put in the element size. */
f_ptr_out->dtype = f_ptr_out->dtype |
- (elemSize << GFC_DTYPE_SIZE_SHIFT);
- /* set the data type (e.g., GFC_DTYPE_INTEGER) */
+ (elemSize << GFC_DTYPE_SIZE_SHIFT);
+ /* Set the data type (e.g., GFC_DTYPE_INTEGER). */
f_ptr_out->dtype = f_ptr_out->dtype | (type << GFC_DTYPE_TYPE_SHIFT);
- }/* end if(shape arg was given) */
-
- /* use generic version of c_f_pointer to set common fields */
- ISO_C_BINDING_PREFIX(c_f_pointer_u0)(c_ptr_in, f_ptr_out, shape);
+ }
+
+ /* Use the generic version of c_f_pointer to set common fields. */
+ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
+
+ return;
+}
- return;
-}/* end ISO_C_BINDING_PREFIX(c_f_pointer)() */
+/* A generic function to set the common fields of all descriptors, no
+ matter whether it's to a scalar or an array. Fields set are: data,
+ and if appropriate, rank, offset, dim[*].lbound, dim[*].ubound, and
+ dim[*].stride. Parameter shape is a rank 1 array of integers
+ containing the upper bound of each dimension of what f_ptr_out
+ points to. The length of this array must be EXACTLY the rank of
+ what f_ptr_out points to, as required by the draft (J3/04-007). If
+ f_ptr_out points to a scalar, then this parameter will be NULL. */
-/**
- * A generic function to set the common fields of all descriptors,
- * no matter whether it's to a scalar or an array. Fields set are:
- *
- * <code>data</code>
- * <code>rank</code> (if appropriate)
- * <code>offset</code> (if appropriate)
- * <code>dim[*].lbound</code> (if appropriate)
- * <code>dim[*].ubound</code> (if appropriate)
- * <code>dim[*].stride</code> (if appropriate)
- *
- * All other fields are left unchanged.
- *
- * @param c_ptr_in C address to associate <code>f_ptr_out</code> with.
- * @param f_ptr_out Fortran descriptor, as described in libgfortran.h,
- * representing a variable declared with the <code>pointer</code>
- * attribute. Upon exit, it will be associated with the given
- * C address.
- * @param shape A rank 1 array of integers containing the upper bound
- * of each dimension of what <code>f_ptr_out</code> points to. The
- * length of this array must be EXACTLY the rank of what
- * <code>f_ptr_out</code> points to, as required by the draft (J3/04-007).
- * If <code>f_ptr_out</code> points to a scalar, then this parameter will
- * be <code>NULL</code>. If <code>f_ptr_out</code> does not point to a
- * scalar, then this parameter is required, as previously stated.
- * @return none
- */
-void ISO_C_BINDING_PREFIX(c_f_pointer_u0)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
- int i = 0;
- int shapeSize = 0;
+ int i = 0;
+ int shapeSize = 0;
- GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in.c_address;
+ GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;
- if(shape != NULL)
- {
+ if (shape != NULL)
+ {
f_ptr_out->offset = 0;
shapeSize = 0;
/* shape's length (rank of the output array) */
shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
- for(i = 0; i < shapeSize; i++)
- {
- /* lower bound is 1, as specified by the draft */
- f_ptr_out->dim[i].lbound = 1;
- f_ptr_out->dim[i].ubound = ((int *)(shape->data))[i];
- }/* end for(rank of output array) */
-
- /* set the offset and strides */
- /* offset is (sum of (dim[i].lbound * dim[i].stride) for all dims)
- * the -1 means we'll back the data pointer up that much
- * perhaps we could just realign the data pointer and not
- * change the offset?
- * --Rickett, 02.28.06
- */
+ for (i = 0; i < shapeSize; i++)
+ {
+ /* Lower bound is 1, as specified by the draft. */
+ f_ptr_out->dim[i].lbound = 1;
+ f_ptr_out->dim[i].ubound = ((int *)(shape->data))[i];
+ }
+
+ /* Set the offset and strides. */
+ /* offset is (sum of (dim[i].lbound * dim[i].stride) for all
+ dims) the -1 means we'll back the data pointer up that much
+ perhaps we could just realign the data pointer and not change
+ the offset? */
f_ptr_out->dim[0].stride = 1;
f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
- for(i = 1; i < shapeSize; i++)
- {
- f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound+1)
+ for (i = 1; i < shapeSize; i++)
+ {
+ f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound+1)
- f_ptr_out->dim[i-1].lbound;
- f_ptr_out->offset += f_ptr_out->dim[i].lbound
+ f_ptr_out->offset += f_ptr_out->dim[i].lbound
* f_ptr_out->dim[i].stride;
- }/* end for(each dim of f_ptr_out) */
+ }
f_ptr_out->offset *= -1;
- /* all we know is the rank, so set it, leaving the rest alone.
- * make NO assumptions about the state of dtype coming in!!
- * if we shift right by TYPE_SHIFT bits we'll throw away the
- * existing rank. then, shift left by the same number to shift
- * in zeros and or with the new rank.
- */
+ /* All we know is the rank, so set it, leaving the rest alone.
+ Make NO assumptions about the state of dtype coming in! If we
+ shift right by TYPE_SHIFT bits we'll throw away the existing
+ rank. Then, shift left by the same number to shift in zeros
+ and or with the new rank. */
f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
- << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
- }/* end if(shape array not null) */
+ << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
+ }
+
+ return;
+}
- return;
-}/* end ISO_C_BINDING_PREFIX(c_f_pointer_u0)() */
+/* Sets the descriptor fields for a Fortran pointer to a derived type,
+ using c_f_pointer_u0 for the majority of the work. */
-/**
- * Sets the descriptor fields for a <code>pointer</code> to a derived
- * type, using <code>c_f_pointer_u0</code> for the majority of the
- * work.
- *
- * @param c_ptr_in The C address to point to.
- * @param f_ptr_out The Fortran pointer out.
- * @param shape One dimensional array of integers describing the bounds
- * of the array of derived types to point the Fortran pointer to, if
- * given. @note: This is an optional parameter in Fortran, so the
- * paramater here may be NULL.
- */
-void ISO_C_BINDING_PREFIX(c_f_pointer_d0)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out,
- const array_t *shape)
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
{
- /* set the common fields */
- ISO_C_BINDING_PREFIX(c_f_pointer_u0)(c_ptr_in, f_ptr_out, shape);
+ /* Set the common fields. */
+ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
- /* preserve the size and rank bits, but reset the type */
- if(shape != NULL)
- {
+ /* Preserve the size and rank bits, but reset the type. */
+ if (shape != NULL)
+ {
f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK);
f_ptr_out->dtype = f_ptr_out->dtype |
- (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT);
- }
+ (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT);
+ }
+
+ return;
+}
- return;
-}/* end ISO_C_BINDING_PREFIX(c_f_pointer_d0)() */
+/* This function will change, once there is an actual f90 type for the
+ procedure pointer. */
-/* this function will change, once there is an actual f90 type for the
- * proc pointer. --Rickett, 01.04.06
- */
-void ISO_C_BINDING_PREFIX(c_f_procpointer)(c_ptr_t c_ptr_in,
- gfc_array_void *f_ptr_out)
+void
+ISO_C_BINDING_PREFIX (c_f_procpointer) (void * c_ptr_in,
+ gfc_array_void *f_ptr_out)
{
- GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in.c_address;
+ GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in;
- return;
-}/* end ISO_C_BINDING_PREFIX(c_f_procpointer)() */
+ return;
+}
-/**
- * Test if the given <code>c_ptr_t</code> is associated or not. This
- * function is called if the user only supplied one <code>c_ptr</code>
- * parameter to the <code>c_associated</code> function. The second
- * argument is optional, and the Fortran compiler will resolve the
- * function to this version if only one arg was given. Associated
- * here simply means whether or not the <code>c_ptr_t</code> is
- * <code>NULL</code> or not.
- *
- * @param c_ptr_in_1 The <code>c_ptr_t</code> to test for association.
- * @return 1 if given pointer is associated; 0 if not.
- * @see #gfc_iso_c_func_interface()
- */
-GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_1)(c_ptr_t c_ptr_in_1)
-{
- if(c_ptr_in_1.c_address != NULL)
- return 1;
- else
- return 0;
-}/* end ISO_C_BINDING_PREFIX(c_associated_1)() */
-
-/**
- * Test if the two <code>c_ptr_t</code> args are associated with
- * one another. This version of the <code>c_associated</code> function
- * is called if the user supplied two <code>c_ptr</code> args in the
- * Fortran source. According to the draft standard (J3/04-007), if
- * <code>c_ptr_in_1</code> is <code>NULL</code>, the two pointers are
- * NOT associated. If <code>c_ptr_in_1</code> is <code>non-NULL</code>
- * and it is not equal to <code>c_ptr_in_2</code>, then either
- * <code>c_ptr_in_2</code> is <code>NULL</code> or is associated with
- * another address; either way, the two pointers are not associated
- * with each other then.
- *
- * @param c_ptr_in_1 <code>c_ptr</code> to test for assocation.
- * @param c_ptr_in_2 <code>c_ptr</code> to test for assocation.
- * @return 1 if the two given <code>c_ptr</code> args are associated;
- * 0 if not.
- * @see #gfc_iso_c_func_interface()
- */
-GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_2)(c_ptr_t c_ptr_in_1,
- c_ptr_t c_ptr_in_2)
-{
- /* since we have the second arg, if it doesn't equal the first,
- * return false; true otherwise. however, if the first one is null,
- * then return false; otherwise compare the two ptrs for equality.
- */
- if(c_ptr_in_1.c_address == NULL)
- return 0;
- else if(c_ptr_in_1.c_address != c_ptr_in_2.c_address)
- return 0;
- else
- return 1;
-}/* end ISO_C_BINDING_PREFIX(c_associated_2)() */
-
-
-/**
- * Return the C address of the given Fortran allocatable object. This
- * routine is expected to return a derived type of type <code>C_PTR</code>,
- * which represents the C address of the given Fortran object.
- *
- * @param f90_obj The Fortran allocatable object that the user is
- * requesting the C address for.
- * @return C address for the given Fortran object.
- */
-c_ptr_t ISO_C_BINDING_PREFIX(c_loc)(void *f90_obj)
-{
- c_ptr_t my_c_ptr;
-
- if(f90_obj == NULL)
- {
- runtime_error("C_LOC: Attempt to get C address for Fortran object"
- " that has not been allocated or associated");
- abort();
- }
+/* Test if the given c_ptr is associated or not. This function is
+ called if the user only supplied one c_ptr parameter to the
+ c_associated function. The second argument is optional, and the
+ Fortran compiler will resolve the function to this version if only
+ one arg was given. Associated here simply means whether or not the
+ c_ptr is NULL or not. */
+
+GFC_LOGICAL_4
+ISO_C_BINDING_PREFIX (c_associated_1) (void * c_ptr_in_1)
+{
+ if (c_ptr_in_1 != NULL)
+ return 1;
+ else
+ return 0;
+}
+
+/* Test if the two c_ptr arguments are associated with one another.
+ This version of the c_associated function is called if the user
+ supplied two c_ptr args in the Fortran source. According to the
+ draft standard (J3/04-007), if c_ptr_in_1 is NULL, the two pointers
+ are NOT associated. If c_ptr_in_1 is non-NULL and it is not equal
+ to c_ptr_in_2, then either c_ptr_in_2 is NULL or is associated with
+ another address; either way, the two pointers are not associated
+ with each other then. */
+
+GFC_LOGICAL_4
+ISO_C_BINDING_PREFIX (c_associated_2) (void * c_ptr_in_1, void * c_ptr_in_2)
+{
+ /* Since we have the second arg, if it doesn't equal the first,
+ return false; true otherwise. However, if the first one is null,
+ then return false; otherwise compare the two ptrs for equality. */
+ if (c_ptr_in_1 == NULL)
+ return 0;
+ else if (c_ptr_in_1 != c_ptr_in_2)
+ return 0;
+ else
+ return 1;
+}
- my_c_ptr.c_address = f90_obj;
+
+/* Return the C address of the given Fortran allocatable object. */
+
+void *
+ISO_C_BINDING_PREFIX (c_loc) (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 my_c_ptr;
+ /* the "C" address should be the address of the object in Fortran */
+ return f90_obj;
}
@@ -268,20 +211,16 @@ c_ptr_t ISO_C_BINDING_PREFIX(c_loc)(void
routine is expected to return a derived type of type C_FUNPTR,
which represents the C address of the given Fortran object. */
-c_funptr_t
+void *
ISO_C_BINDING_PREFIX (c_funloc) (void *f90_obj)
{
- c_funptr_t my_c_funptr;
-
- if (f90_obj == NULL)
- {
- runtime_error ("C_LOC: Attempt to get C address for Fortran object "
- "that has not been allocated or associated");
- abort ();
- }
+ if (f90_obj == NULL)
+ {
+ runtime_error ("C_LOC: Attempt to get C address for Fortran object"
+ " that has not been allocated or associated");
+ abort ();
+ }
- my_c_funptr.c_address = f90_obj;
-
- /* The "C" address should be the address of the object in Fortran. */
- return my_c_funptr;
+ /* 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 122595)
+++ libgfortran/intrinsics/iso_c_binding.h (working copy)
@@ -5,40 +5,39 @@
typedef struct c_ptr
{
- void *c_address;
+ void *c_address;
}c_ptr_t;
typedef struct c_funptr
{
- void *c_address;
+ void *c_address;
}c_funptr_t;
#define ISO_C_BINDING_PREFIX(a) __iso_c_binding_##a
-void ISO_C_BINDING_PREFIX(c_f_pointer)(c_ptr_t c_ptr_in,
+void ISO_C_BINDING_PREFIX(c_f_pointer)(void * c_ptr_in,
gfc_array_void *f_ptr_out,
const array_t *shape,
int type, int elemSize);
/* The second param here may change, once procedure pointers are
implemented. */
-void ISO_C_BINDING_PREFIX(c_f_procpointer)(c_ptr_t c_ptr_in,
+void ISO_C_BINDING_PREFIX(c_f_procpointer)(void * c_ptr_in,
gfc_array_void *f_ptr_out);
-GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_1)(c_ptr_t c_ptr_in_1);
-GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_2)(c_ptr_t c_ptr_in_1,
- c_ptr_t c_ptr_in_2);
+GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_1)(void * c_ptr_in_1);
+GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_2)(void * c_ptr_in_1,
+ void * c_ptr_in_2);
-void ISO_C_BINDING_PREFIX(c_f_pointer_u0)(c_ptr_t c_ptr_in,
+void ISO_C_BINDING_PREFIX(c_f_pointer_u0)(void * c_ptr_in,
gfc_array_void *f_ptr_out,
const array_t *shape);
-
-void ISO_C_BINDING_PREFIX(c_f_pointer_d0)(c_ptr_t c_ptr_in,
+void ISO_C_BINDING_PREFIX(c_f_pointer_d0)(void * c_ptr_in,
gfc_array_void *f_ptr_out,
const array_t *shape);
-c_ptr_t ISO_C_BINDING_PREFIX(c_loc)(void *f90_obj);
-c_funptr_t ISO_C_BINDING_PREFIX(c_funloc) (void *f90_obj);
+void * ISO_C_BINDING_PREFIX(c_loc) (void *f90_obj);
+void * ISO_C_BINDING_PREFIX(c_funloc) (void *f90_obj);
#endif
More information about the Fortran
mailing list