[Fortran-Experiments]: patch
Christopher D. Rickett
crickett@lanl.gov
Mon Mar 5 20:08:00 GMT 2007
hi all,
here is another patch for the fortran-experiments branch. it primarily
contains:
- error checking of binding labels for bind(c) common blocks.
- implementation of c_funloc
- fixes for c_null_ptr and c_null_funptr
- allowing for NAME=""
- improved error checking for c_loc and c_funloc
- test cases
there are some other changes that i think were more minor, but the above
are the main ones. bootstrapped and regtested on x86 with no new
failures.
ChangeLog entry:
2007-03-05 Christopher D. Rickett <crickett@lanl.gov>
* gfortran.dg/c_funloc_tests_2.f03: New test case.
* gfortran.dg/c_funloc_tests.f03: Ditto.
* gfortran.dg/c_loc_tests_2.f03: Updated test case.
* gfortran.dg/c_assoc_2.f03: New test case.
* gfortran.dg/c_loc_tests_3.f03: Ditto.
* gfortran.dg/c_loc_tests_4.f03: Ditto.
* gfortran.dg/c_loc_tests_5.f03: Ditto.
* gfortran.dg/test_common_binding_labels.f03: Ditto.
* gfortran.dg/binding_label_tests_13_main.f03: Ditto. Used with
binding_label_tests_13.
* gfortran.dg/binding_label_tests_12.f03: New test case.
* gfortran.dg/bind_c_coms.f90: Updated test case.
* gfortran.dg/binding_label_tests_13.f03: New test case.
* gfortran.dg/test_common_binding_labels_2.f03: Ditto.
* gfortran.dg/test_common_binding_labels_3.f03: Ditto.
* gfortran.dg/test_common_binding_labels_2_main.f03: Ditto. Used
with test_common_binding_labels_2.
* gfortran.dg/bind_c_procs.f03: New test case.
* gfortran.dg/c_loc_test.f90: Updated test case.
* gfortran.dg/test_common_binding_labels_3_main.f03: New test
case. Used with test_common_binding_labels_3.
* gfortran.dg/bind_c_coms_driver.c: Updated.
* symbol.c (gen_special_c_interop_ptrs): Renamed to
gen_special_c_interop_ptr and changed arguments.
(generate_iso_c_binding_symbol): Added ISOCBINDING_NULL_PTR,
ISOCBINDING_NULL_FUNPTR, and ISOCBINDING_FUNLOC.
* decl.c (verify_c_interop_param): Added check for procedures.
(set_binding_label): Allow for NAME="".
(gfc_match_bind_c): Ditto.
(match_proc_decl): Updated for NAME="".
* trans-common.c (gfc_sym_mangled_common_id): Allow for NAME="".
* gfortran.h: Added binding label field to gfc_gsymbol.
(gfc_check_any_c_kind): Added prototype.
* iso-c-binding.def: Added ISOCBINDING_NULL_PTR,
ISOCBINDING_NULL_FUNPTR, and ISOCBINDING_FUNLOC.
* module.c (write_common): Allow for NAME="".
(write_symbol): Ditto.
(sort_iso_c_rename_list): New function to sort iso_c_binding
rename list to meet dependencies between symbols.
(import_iso_c_binding_module): Call sort_iso_c_rename_list.
* trans-types.c (gfc_check_any_c_kind): New function that returns
SUCCESS if any C kind is interoperable with given Fortran type.
* resolve.c (resolve_contained_functions): Removed verification of
BIND(C) procedures.
(is_scalar_expr_ptr): Determine if parameter to C_LOC is a scalar
expr.
(gfc_iso_c_func_interface): Changed return type to
SUCCESS/FAILURE. Added code for ISOCBINDING_FUNLOC. Added error
checking for ISOCBINDING_LOC.
(resolve_function): Moved call to gfc_iso_c_func_interface until
after resolving the argument(s).
(resolve_bind_c_comms): Verify binding labels for BIND(C) common
blocks.
(gfc_verify_binding_labels): Updated error checks.
(resolve_fl_procedure): Added verification for BIND(C)
procedures.
(resolve_symbol): Removed C interoperability checking for dummy
arguments to a BIND(C) procedure (now done in
resolve_fl_procedure).
(resolve_types): Added calls to traverse namespace and verify
binding labels for BIND(C) global symbols and common blocks.
* primary.c (gfc_match_rvalue): Removed most of the error checking
for ISOCBINDING_LOC, ISOCBINDING_FUNLOC, and
ISOCBINDING_ASSOCIATED (now done in gfc_iso_c_func_interface).
* iso_c_generated_procs.c (c_f_pointer_i1, c_f_pointer_i2,
c_f_pointer_i16): Added prototypes and function definitions.
* iso_c_binding.c (c_funloc): Added function definition.
* iso_c_binding.h (c_funloc): Added prototype.
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03 (revision 0)
@@ -0,0 +1,16 @@
+! { dg-do compile }
+module c_funloc_tests_2
+ use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+ implicit none
+
+contains
+ subroutine sub0() bind(c)
+ type(c_funptr) :: my_c_funptr
+ integer :: my_local_variable
+
+ my_c_funptr = c_funloc() ! { dg-error "Missing argument" }
+ my_c_funptr = c_funloc(sub0)
+ my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "More actual than formal" }
+ my_c_funptr = c_funloc(my_local_variable) ! { dg-error "must be a procedure" }
+ end subroutine sub0
+end module c_funloc_tests_2
Index: gcc/testsuite/gfortran.dg/c_funloc_tests.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_funloc_tests.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_funloc_tests.f03 (revision 0)
@@ -0,0 +1,21 @@
+! { dg-do run }
+! This test case simply checks that c_funloc exists, accepts arguments of
+! flavor FL_PROCEDURE, and returns the type c_funptr
+module c_funloc_tests
+ use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+
+contains
+ subroutine sub0() bind(c)
+ type(c_funptr) :: my_c_funptr
+
+ my_c_funptr = c_funloc(sub0)
+ end subroutine sub0
+end module c_funloc_tests
+
+program driver
+ use c_funloc_tests
+
+ call sub0()
+end program driver
+
+! { dg-final { cleanup-modules "c_funloc_tests" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests.f90
===================================================================
Index: gcc/testsuite/gfortran.dg/c_loc_tests_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 (revision 122521)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_2.f03 (working copy)
@@ -44,21 +44,15 @@ contains
end subroutine test0
subroutine test1() bind(c)
- integer, pointer, dimension(:) :: int_array_ptr
integer, target, dimension(100) :: int_array_tar
type(c_ptr) :: my_c_ptr_1 = c_null_ptr
type(c_ptr) :: my_c_ptr_2 = c_null_ptr
- int_array_ptr => int_array_tar
int_array_tar = 100
my_c_ptr_1 = c_loc(int_array_tar)
- my_c_ptr_2 = c_loc(int_array_ptr)
if(test_array_address(my_c_ptr_1, 100) .ne. 1) then
call abort()
end if
- if(test_array_address(my_c_ptr_2, 100) .ne. 1) then
- call abort()
- end if
end subroutine test1
subroutine test2() bind(c)
@@ -91,3 +85,4 @@ program driver
call test1()
call test2()
end program driver
+! { dg-final { cleanup-modules "c_loc_tests_2" } }
Index: gcc/testsuite/gfortran.dg/c_assoc_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_assoc_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_assoc_2.f03 (revision 0)
@@ -0,0 +1,36 @@
+! { dg-do compile }
+module c_assoc_2
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_associated
+
+contains
+ subroutine sub0(my_c_ptr) bind(c)
+ type(c_ptr), value :: my_c_ptr
+ type(c_ptr), pointer :: my_c_ptr_2
+ integer :: my_integer
+
+ if(.not. c_associated(my_c_ptr)) then
+ call abort()
+ end if
+
+ if(.not. c_associated(my_c_ptr, my_c_ptr)) then
+ call abort()
+ end if
+
+ if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "More actual than formal arguments" }
+ call abort()
+ end if
+
+ if(.not. c_associated()) then ! { dg-error "Missing argument" }
+ call abort()
+ end if ! { dg-error "Expecting END SUBROUTINE" }
+
+ if(.not. c_associated(my_c_ptr_2)) then
+ call abort()
+ end if
+
+ if(.not. c_associated(my_integer)) then ! { dg-error "Type/rank mismatch" }
+ call abort()
+ end if
+ end subroutine sub0
+
+end module c_assoc_2
Index: gcc/testsuite/gfortran.dg/c_loc_tests_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_3.f03 (revision 0)
@@ -0,0 +1,8 @@
+! { dg-do compile }
+use iso_c_binding
+implicit none
+character(kind=c_char,len=256),target :: arg
+type(c_ptr),pointer :: c
+c = c_loc(arg) ! { dg-error "must have a length of 1" }
+
+end
Index: gcc/testsuite/gfortran.dg/c_loc_tests_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_4.f03 (revision 0)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+module c_loc_tests_4
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+contains
+ subroutine sub0() bind(c)
+ integer(c_int), target, dimension(10) :: my_array
+ integer(c_int), pointer, dimension(:) :: my_array_ptr
+ type(c_ptr) :: my_c_ptr
+
+ my_array_ptr => my_array
+ my_c_ptr = c_loc(my_array_ptr) ! { dg-error "must be an associated scalar POINTER" }
+ end subroutine sub0
+end module c_loc_tests_4
Index: gcc/testsuite/gfortran.dg/c_loc_tests_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_loc_tests_5.f03 (revision 0)
@@ -0,0 +1,19 @@
+! { dg-do compile }
+module c_loc_tests_5
+ use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_loc, c_int
+
+contains
+ subroutine sub0() bind(c)
+ type(c_ptr) :: f_ptr, my_c_ptr
+ character(kind=c_char, len=20), target :: format
+ integer(c_int), dimension(:), pointer :: int_ptr
+ integer(c_int), dimension(10), target :: int_array
+
+ f_ptr = c_loc(format(1:1))
+
+ int_ptr => int_array
+ my_c_ptr = c_loc(int_ptr(0))
+
+ end subroutine sub0
+end module c_loc_tests_5
+! { dg-final { cleanup-modules "c_loc_tests_5" } }
Index: gcc/testsuite/gfortran.dg/test_common_binding_labels.f03
===================================================================
--- gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/test_common_binding_labels.f03 (revision 0)
@@ -0,0 +1,42 @@
+! { dg-do compile }
+module x
+ use, intrinsic :: iso_c_binding, only: c_double
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+end module x
+
+module y
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="") /com2/
+end module y
+
+module z
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ ! this next line is an error; if a common block is bind(c), the binding label
+ ! for it must match across all scoping units that declare it.
+ bind(c, name="my_common_block_2") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="mycom2") /com2/
+end module z
+
+! { dg-final { cleanup-modules "x y" } }
Index: gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03
===================================================================
--- gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/binding_label_tests_13_main.f03 (revision 0)
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_13.f03, which it
+! should be because dejagnu will sort the files. The module file
+! binding_label_tests_13.mod can not be removed until after this test is done.
+module binding_label_tests_13_main
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int) :: c3 ! { dg-error "collides" }
+ bind(c) c3
+
+contains
+ subroutine c_sub() BIND(c, name = "C_Sub")
+ use binding_label_tests_13 ! { dg-error "collides" }
+ end subroutine c_sub
+end module binding_label_tests_13_main
+! { dg-final { cleanup-modules "binding_label_tests_13 binding_label_tests_13_main" } }
+
Index: gcc/testsuite/gfortran.dg/binding_label_tests_12.f03
===================================================================
--- gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/binding_label_tests_12.f03 (revision 0)
@@ -0,0 +1,24 @@
+! { dg-do run }
+! This verifies that the compiler will correctly accpet the name="", write out
+! an empty string for the binding label to the module file, and then read it
+! back in. Also, during gfc_verify_binding_labels, the name="" will prevent
+! any verification (since there is no label to verify).
+module one
+contains
+ subroutine foo() bind(c)
+ end subroutine foo
+end module one
+
+module two
+contains
+ ! This procedure is only used accessed in C
+ ! as procedural pointer
+ subroutine foo() bind(c, name="")
+ end subroutine foo
+end module two
+
+use one, only: foo_one => foo
+use two, only: foo_two => foo
+end
+
+! { dg-final { cleanup-modules "one two" } }
Index: gcc/testsuite/gfortran.dg/bind_c_coms.f90
===================================================================
--- gcc/testsuite/gfortran.dg/bind_c_coms.f90 (revision 122521)
+++ gcc/testsuite/gfortran.dg/bind_c_coms.f90 (working copy)
@@ -18,6 +18,14 @@ module bind_c_coms
integer(c_long_long) :: long_long_ints
bind(c) :: /mycom2/
+ common /com2/ i, j
+ integer(c_int) :: i, j
+ bind(c, name="f03_com2") /com2/
+
+ common /com3/ m, n
+ integer(c_int) :: m, n
+ bind(c, name="") /com3/
+
contains
subroutine test_coms() bind(c)
r = r + .1d0;
@@ -25,5 +33,19 @@ contains
t = t + .1d0;
long_ints = long_ints + 1
long_long_ints = long_long_ints + 1
+ i = i + 1
+ j = j + 1
+
+ m = 1
+ n = 1
end subroutine test_coms
end module bind_c_coms
+
+module bind_c_coms_2
+ use, intrinsic :: iso_c_binding, only: c_int
+ common /com3/ m, n
+ integer(c_int) :: m, n
+ bind(c, name="") /com3/
+end module bind_c_coms_2
+
+! { dg-final { cleanup-modules "bind_c_coms bind_c_coms_2" } }
Index: gcc/testsuite/gfortran.dg/binding_label_tests_13.f03
===================================================================
--- gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/binding_label_tests_13.f03 (revision 0)
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_13_main.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_13
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int) :: c3
+ bind(c) c3
+end module binding_label_tests_13
Index: gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/test_common_binding_labels_2.f03 (revision 0)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+module test_common_binding_labels_2
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+
+ common /com2/ i
+ integer(c_int) :: i
+ bind(c, name="") /com2/
+end module test_common_binding_labels_2
+
Index: gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/test_common_binding_labels_3.f03 (revision 0)
@@ -0,0 +1,10 @@
+! { dg-do compile }
+module test_common_binding_labels_3
+ use, intrinsic :: iso_c_binding, only: c_double
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+end module test_common_binding_labels_3
Index: gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03
===================================================================
--- gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/test_common_binding_labels_2_main.f03 (revision 0)
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! This file depends on the module test_common_binding_labels_2. That module
+! must be compiled first and not be removed until after this test.
+module test_common_binding_labels_2_main
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ ! this next line is an error; if a common block is bind(c), the binding label
+ ! for it must match across all scoping units that declare it.
+ bind(c, name="my_common_block_2") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="mycom2") /com2/
+end module test_common_binding_labels_2_main
+
+program main
+ use test_common_binding_labels_2 ! { dg-error "does not match" }
+ use test_common_binding_labels_2_main
+end program main
+
+! { dg-final { cleanup-modules "test_common_binding_labels_2_main test_common_binding_labels_2" } }
Index: gcc/testsuite/gfortran.dg/bind_c_procs.f03
===================================================================
--- gcc/testsuite/gfortran.dg/bind_c_procs.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/bind_c_procs.f03 (revision 0)
@@ -0,0 +1,39 @@
+! { dg-do compile }
+module bind_c_procs
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ interface
+ ! warning for my_param possibly not being C interoperable
+ subroutine my_c_sub(my_param) bind(c) ! { dg-warning "may not be C interoperable" }
+ integer, value :: my_param
+ end subroutine my_c_sub
+
+ ! warning for my_c_func possibly not being a C interoperable kind
+ ! warning for my_param possibly not being C interoperable
+ ! error message truncated to provide an expression that both warnings
+ ! should match.
+ function my_c_func(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ integer :: my_c_func
+ end function my_c_func
+ end interface
+
+contains
+ ! warning for my_param possibly not being C interoperable
+ subroutine my_f03_sub(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ end subroutine my_f03_sub
+
+ ! warning for my_f03_func possibly not being a C interoperable kind
+ ! warning for my_param possibly not being C interoperable
+ ! error message truncated to provide an expression that both warnings
+ ! should match.
+ function my_f03_func(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ integer :: my_f03_func
+ my_f03_func = 1
+ end function my_f03_func
+
+end module bind_c_procs
+
+! { dg-final { cleanup-modules "bind_c_procs" } }
Index: gcc/testsuite/gfortran.dg/c_loc_test.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_loc_test.f90 (revision 122521)
+++ gcc/testsuite/gfortran.dg/c_loc_test.f90 (working copy)
@@ -18,6 +18,7 @@ contains
end interface
x = 100
my_c_ptr = c_loc(x)
- call test_address(my_c_ptr, x)
+ call test_address(my_c_ptr, 100)
end subroutine test0
end module c_loc_test
+! { dg-final { cleanup-modules "c_loc_test.mod" } }
Index: gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03
===================================================================
--- gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/test_common_binding_labels_3_main.f03 (revision 0)
@@ -0,0 +1,14 @@
+! { dg-do compile }
+! This file depends on the module test_common_binding_labels_3. That module
+! must be compiled first and not be removed until after this test.
+module test_common_binding_labels_3_main
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "collides" }
+end module test_common_binding_labels_3_main
+
+program main
+ use test_common_binding_labels_3_main
+ use test_common_binding_labels_3 ! { dg-error "collides" }
+end program main
+
+! { dg-final { cleanup-modules "test_common_binding_labels_3_main test_common_binding_labels_3" } }
Index: gcc/testsuite/gfortran.dg/bind_c_coms_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/bind_c_coms_driver.c (revision 122521)
+++ gcc/testsuite/gfortran.dg/bind_c_coms_driver.c (working copy)
@@ -4,31 +4,39 @@ void test_coms(void);
extern void abort(void);
-struct {double r, s; } com; /* refers to the common block "com" */
-double single; /* refers to the common block "single" */
-long int mycom; /* refers to the common block "MYCOM" */
-long long int mycom2; /* refers to the common block "MYCOM2" */
+struct {double r, s; } com; /* refers to the common block "com" */
+double single; /* refers to the common block "single" */
+long int mycom; /* refers to the common block "MYCOM" */
+long long int mycom2; /* refers to the common block "MYCOM2" */
+struct {int i, j; } f03_com2; /* refers to the common block "com2" */
int main(int argc, char **argv)
{
- com.r = 1.0;
- com.s = 2.0;
- single = 1.0;
- mycom = 1;
- mycom2 = 2;
+ com.r = 1.0;
+ com.s = 2.0;
+ single = 1.0;
+ mycom = 1;
+ mycom2 = 2;
+ f03_com2.i = 1;
+ f03_com2.j = 2;
- /* change the common block variables in F90 */
- test_coms();
+ /* change the common block variables in F90 */
+ test_coms();
- if(fabs(com.r - 1.1) > 0.00000000)
- abort();
- if(fabs(com.s - 2.1) > 0.00000000)
- abort();
- if(fabs(single - 1.1) > 0.00000000)
- abort();
- if(mycom != 2)
- abort();
- if(mycom2 != 3)
- abort();
- return 0;
+ if(fabs(com.r - 1.1) > 0.00000000)
+ abort();
+ if(fabs(com.s - 2.1) > 0.00000000)
+ abort();
+ if(fabs(single - 1.1) > 0.00000000)
+ abort();
+ if(mycom != 2)
+ abort();
+ if(mycom2 != 3)
+ abort();
+ if(f03_com2.i != 2)
+ abort();
+ if(f03_com2.j != 3)
+ abort();
+
+ return 0;
}/* end main() */
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 122521)
+++ gcc/fortran/symbol.c (working copy)
@@ -3102,117 +3102,76 @@ verify_bind_c_derived_type (gfc_symbol *
/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
static void
-gen_special_c_interop_ptrs (const char *kinds[],
- const char *module_name)
+gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
+ const char *module_name)
{
- int i;
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
- /* there should be only two possible ptr kinds; c_ptr and c_funptr */
- i = 0;
- while (kinds[i] != NULL)
- {
- /* Here, we know that we can only be given valid iso_c_binding
- constant names, because error checking already done,
- so if we don't have one, it must be the other. */
- if (strcmp(kinds[i], "c_ptr") == 0)
- /* look for symtree for c_null_ptr */
- tmp_symtree =
- gfc_find_symtree (gfc_current_ns->sym_root, "c_null_ptr");
- else
- /* look for symtree for c_null_funptr */
- tmp_symtree =
- gfc_find_symtree (gfc_current_ns->sym_root, "c_null_funptr");
- if (tmp_symtree == NULL)
- {
- /* Use the function gfc_get_sym_tree to force it to create
- the symbol in the current namespace. */
- if (strcmp(kinds[i], "c_ptr") == 0)
- gfc_get_sym_tree ("c_null_ptr", gfc_current_ns,
- &tmp_symtree);
- else
- gfc_get_sym_tree ("c_null_funptr", gfc_current_ns,
- &tmp_symtree);
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
- if (tmp_symtree != NULL)
- tmp_sym = tmp_symtree->n.sym;
- else
- {
- tmp_sym = NULL;
- gfc_internal_error ("gen_special_c_interop_ptrs(): Unable to "
- "create symbol for %s", kinds[i]);
- }
-
- /* Set up the symbol's important fields. */
- /* Save attr required so we can initialize the ptr to NULL. */
- tmp_sym->attr.save = 1;
- tmp_sym->ts.is_c_interop = 1;
- 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 (strcmp (kinds[i], "c_ptr") == 0)
- 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
- c_funptr and they're trying to use one of the procedures
- 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, kinds[i]);
- if (strcmp (kinds[i], "c_ptr") == 0)
- {
- generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
- (char *)"c_ptr");
- gfc_get_ha_symbol ("c_ptr", &(tmp_sym->ts.derived));
- }
- else
- {
- generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
- (char *)"c_funptr");
- gfc_get_ha_symbol ("c_funptr", &(tmp_sym->ts.derived));
- }
- }
-
- /* 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. */
- tmp_sym->attr.is_iso_c = 1;
-
- tmp_sym->attr.use_assoc = 1;
- tmp_sym->attr.is_bind_c = 1;
- /* set the binding_label */
- sprintf (tmp_sym->binding_label, "%s_%s", module_name,
- tmp_sym->name);
-
- /* Set the c_address field of c_null_ptr and c_null_funptr to
- the value of NULL. */
- tmp_sym->value = gfc_get_expr ();
- tmp_sym->value->expr_type = EXPR_STRUCTURE;
- tmp_sym->value->ts.type = BT_DERIVED;
- tmp_sym->value->ts.derived = tmp_sym->ts.derived;
- tmp_sym->value->value.constructor = gfc_get_constructor ();
- /* This line will initialize the c_null_ptr/c_null_funptr
- c_address field to NULL. */
- tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
- /* 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;
- }
+ if (tmp_symtree != NULL)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ {
+ tmp_sym = NULL;
+ gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
+ "create symbol for %s", ptr_name);
+ }
- /* while loop counter */
- i++;
+ /* Set up the symbol's important fields. */
+ /* Save attr required so we can initialize the ptr to NULL. */
+ tmp_sym->attr.save = 1;
+ tmp_sym->ts.is_c_interop = 1;
+ 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
+ c_funptr and they're trying to use one of the procedures
+ 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;
}
+
+ /* 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. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ tmp_sym->attr.use_assoc = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ /* set the binding_label */
+ sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+
+ /* Set the c_address field of c_null_ptr and c_null_funptr to
+ the value of NULL. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_STRUCTURE;
+ tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ tmp_sym->value->value.constructor = gfc_get_constructor ();
+ /* This line will initialize the c_null_ptr/c_null_funptr
+ c_address field to NULL. */
+ tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
+ /* 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;
}
@@ -3666,26 +3625,17 @@ generate_isocbinding_symbol (const char
/* Make it use associated (iso_c_binding module). */
tmp_sym->attr.use_assoc = 1;
-
- /* Need to decide whether to generate the symbols for c_null_ptr
- or c_null_funptr (i.e., whether c_ptr and c_funptr are defined). */
- if (s == ISOCBINDING_PTR)
- {
- /* c_ptr was created so create c_null_ptr */
- const char *ptr_kinds[2] = {"c_ptr", NULL};
- gen_special_c_interop_ptrs (ptr_kinds, mod_name);
- }
- else
- {
- /* c_funptr was created so create c_null_funptr */
- const char *ptr_kinds[2] = {"c_funptr", NULL};
- gen_special_c_interop_ptrs (ptr_kinds, mod_name);
- }
break;
+ case ISOCBINDING_NULL_PTR:
+ case ISOCBINDING_NULL_FUNPTR:
+ gen_special_c_interop_ptr (s, name, mod_name);
+ break;
+
case ISOCBINDING_F_POINTER:
case ISOCBINDING_ASSOCIATED:
case ISOCBINDING_LOC:
+ case ISOCBINDING_FUNLOC:
case ISOCBINDING_F_PROCPOINTER:
tmp_sym->attr.proc = PROC_MODULE;
@@ -3716,11 +3666,25 @@ generate_isocbinding_symbol (const char
what we expect on the stack for the address we want the
C address of. */
tmp_sym->ts.type = BT_DERIVED;
- tmp_sym->ts.derived =
- get_iso_c_binding_dt (ISOCBINDING_PTR, 1);
- if (tmp_sym->ts.derived == NULL)
- gfc_error_now ("Type C_PTR is not defined but is needed "
- "as return type of function C_LOC at %C");
+ if (s == ISOCBINDING_LOC)
+ 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)
+ {
+ 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;
+ }
/* the function result is itself (no result clause) */
tmp_sym->result = tmp_sym;
@@ -3745,7 +3709,7 @@ generate_isocbinding_symbol (const char
This will create the formal args (and the new namespace for them). */
/* Don't build an arg list for c_loc because we're going to treat c_loc
as an external procedure. */
- if (s != ISOCBINDING_LOC)
+ if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
/* the 1 says to add any optional args, if applicable */
build_formal_args (tmp_sym, tmp_sym, 1);
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 122521)
+++ gcc/fortran/decl.c (working copy)
@@ -47,6 +47,10 @@ static char curr_binding_label[GFC_MAX_B
/* Need to know how many identifiers are on the current data declaration
line in case we're given the BIND(C) attribute with a NAME= specifier. */
static int num_idents_on_line;
+/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
+ can supply a name if the curr_binding_label is nil and NAME= was not. */
+static int has_name_equals = 0;
+
/* Initializer of the previous enumerator. */
@@ -752,18 +756,23 @@ verify_c_interop_param (gfc_symbol *sym)
return SUCCESS;
/* For subroutines or functions that are passed to a BIND(C) procedure,
- they're interoperable if they're BIND(C) and their params are all
+ they're inteoperable if they're BIND(C) and they're params are all
interoperable. */
if (sym->attr.flavor == FL_PROCEDURE)
{
if (sym->attr.is_bind_c == 0)
- return FAILURE;
+ return FAILURE;
else
- return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
- sym->common_block);
+ {
+ if (sym->attr.is_c_interop == 1)
+ /* We've already checked this procedure; don't check it again. */
+ return SUCCESS;
+ else
+ return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block);
+ }
}
-
/* See if we've stored a reference to a procedure that owns sym. */
if (sym->ns != NULL && sym->ns->proc_name != NULL)
{
@@ -2764,12 +2773,10 @@ set_binding_label (char *dest_label, con
}
else
{
- /* no binding label given */
- if (sym_name != NULL)
+ /* No binding label given, and the NAME= specifier did not exist,
+ which means there was no NAME="". */
+ if (sym_name != NULL && has_name_equals == 0)
strncpy (dest_label, sym_name, strlen (sym_name) + 1);
- else
- gfc_internal_error ("set_binding_label(): Name is "
- "unexpectedly NULL!");
}
return SUCCESS;
@@ -3191,6 +3198,15 @@ match_proc_decl (void)
return MATCH_ERROR;
}
+ /* If the interface is BIND(C), we could inherit that attribute without
+ specifying it in the procedure declaration. This could prevent the
+ gfc_match_bind_c from being called, so we need to clear the
+ has_name_equals flag ourselves. */
+ /* TODO: what happens if the interface we're using in the procedure
+ declaration has a NAME= specifier that is not NAME=""? */
+ if (int_symtree->n.sym->attr.is_bind_c)
+ has_name_equals = 0;
+
/* Try and match attributes. We will match any attr here, and
report conflicts as we find them.
TODO: make sure all conflicts are caught. */
@@ -3234,7 +3250,7 @@ match_proc_decl (void)
/* or necessary current_ts info with ts from interface proc */
new_proc_sym->ts.is_c_interop |= current_ts.is_c_interop;
new_proc_sym->ts.f90_type |= current_ts.f90_type;
-
+
/* All procedure decls refer to external procedures (this may
not be right to do if it's a proc pointer..). */
new_proc_sym->attr.external = 1;
@@ -4211,6 +4227,10 @@ gfc_match_bind_c (gfc_symbol *sym)
match single_quote;
int has_name_equals = 0;
+ /* Initialize the flag that specifies whether we encountered a NAME=
+ specifier or not. */
+ has_name_equals = 0;
+
/* Init the first char to nil so we can catch if we don't have
the label (name attr) or the symbol name yet. */
binding_label[0] = '\0';
@@ -4299,11 +4319,11 @@ gfc_match_bind_c (gfc_symbol *sym)
/* No binding label, but if symbol isn't null, we
can set the label for it here. */
/* TODO: If the name= was given and no binding label (name=""), we simply
- will let fortran mangle the symbol name as it usually would.
- However, this could still let C call it if the user looked up the
- symbol in the object file. Should the name set during mangling in
- trans-decl.c be marked with characters that are invalid for C to
- prevent this? */
+ will let fortran mangle the symbol name as it usually would.
+ However, this could still let C call it if the user looked up the
+ symbol in the object file. Should the name set during mangling in
+ trans-decl.c be marked with characters that are invalid for C to
+ prevent this? */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
}
Index: gcc/fortran/trans-common.c
===================================================================
--- gcc/fortran/trans-common.c (revision 122521)
+++ gcc/fortran/trans-common.c (working copy)
@@ -252,19 +252,8 @@ gfc_sym_mangled_common_id (gfc_common_he
strcpy(name, com->name);
/* if we're suppose to do a bind(c) */
- if(com->is_bind_c == 1)
- {
- if(com->binding_label[0] != '\0')
- return get_identifier(com->binding_label);
- else
- /* for some reason the binding label hasn't been set. this
- * shouldn't happen if the common block was declared with
- * bind(c), because either the label was given or set to the
- * name in all lowercase, but check just in case. this test
- * is most likely safe to remove. --Rickett, 03.14.06
- */
- return get_identifier(com->name);
- }
+ if(com->is_bind_c == 1 && com->binding_label[0] != '\0')
+ return get_identifier(com->binding_label);
if (strcmp (name, BLANK_COMMON_NAME) == 0)
return get_identifier (name);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 122521)
+++ gcc/fortran/gfortran.h (working copy)
@@ -982,8 +982,8 @@ typedef struct gfc_common_head
char use_assoc, saved, threadprivate;
char name[GFC_MAX_SYMBOL_LEN + 1];
struct gfc_symbol *head;
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
- int is_bind_c;
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ int is_bind_c;
}
gfc_common_head;
@@ -1126,6 +1126,7 @@ typedef struct gfc_gsymbol
const char *name;
const char *sym_name;
const char *mod_name;
+ const char *binding_label;
enum { GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE,
GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA } type;
@@ -1922,6 +1923,7 @@ arith gfc_check_integer_range (mpz_t p,
/* trans-types.c */
try gfc_validate_c_kind(gfc_typespec *ts);
+try gfc_check_any_c_kind (gfc_typespec *ts);
int gfc_validate_kind (bt, int, bool);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
Index: gcc/fortran/iso-c-binding.def
===================================================================
--- gcc/fortran/iso-c-binding.def (revision 122521)
+++ gcc/fortran/iso-c-binding.def (working copy)
@@ -118,9 +118,14 @@ NAMED_CHARCST (ISOCBINDING_VERTICAL_TAB,
DERIVED_TYPE (ISOCBINDING_PTR, "c_ptr", \
get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_NULL_PTR, "c_null_ptr", \
+ get_int_kind_from_node (ptr_type_node))
DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \
get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_NULL_FUNPTR, "c_null_funptr", \
+ get_int_kind_from_node (ptr_type_node))
+
#ifndef PROCEDURE
# define PROCEDURE(a,b)
#endif
@@ -128,6 +133,7 @@ DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_fun
PROCEDURE (ISOCBINDING_F_POINTER, "c_f_pointer")
PROCEDURE (ISOCBINDING_ASSOCIATED, "c_associated")
PROCEDURE (ISOCBINDING_LOC, "c_loc")
+PROCEDURE (ISOCBINDING_FUNLOC, "c_funloc")
/* Insert c_f_procpointer, though unsupported for now. */
PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 122521)
+++ gcc/fortran/module.c (working copy)
@@ -3662,7 +3662,7 @@ write_common (gfc_symtree *st)
/* write out whether the common block is bind(c) or not */
mio_integer(&(p->is_bind_c));
/* write out the binding label, or the com name if no label given */
- if (p->is_bind_c && p->binding_label[0] != '\0')
+ if (p->is_bind_c)
{
label = p->binding_label;
mio_pool_string (&label);
@@ -3750,8 +3750,7 @@ write_symbol (int n, gfc_symbol * sym)
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
- if ((sym->attr.is_bind_c || sym->attr.is_iso_c)
- && sym->binding_label[0] != '\0')
+ if ((sym->attr.is_bind_c || sym->attr.is_iso_c))
{
label = sym->binding_label;
mio_pool_string (&label);
@@ -4023,6 +4022,55 @@ gfc_dump_module (const char *name, int d
}
+static void
+sort_iso_c_rename_list (void)
+{
+ gfc_use_rename *tmp_list = NULL;
+ gfc_use_rename *curr;
+ gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
+ int c_kind;
+ int i;
+
+ for (curr = gfc_rename_list; curr; curr = curr->next)
+ {
+ c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
+ if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", curr->use_name,
+ &curr->where);
+ }
+ else
+ /* Put it in the list. */
+ kinds_used[c_kind] = curr;
+ }
+
+ /* Make a new (sorted) rename list. */
+ i = 0;
+ while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
+ i++;
+
+ if (i < ISOCBINDING_NUMBER)
+ {
+ tmp_list = kinds_used[i];
+
+ i++;
+ curr = tmp_list;
+ for (; i < ISOCBINDING_NUMBER; i++)
+ if (kinds_used[i] != NULL)
+ {
+ curr->next = kinds_used[i];
+ curr = curr->next;
+ curr->next = NULL;
+ }
+ }
+
+ gfc_rename_list = tmp_list;
+
+ return;
+}
+
+
/* Import the instrinsic ISO_C_BINDING module, generating symbols in the
current namespace for all named constants, pointer types,
and procedures in the module unless the only clause was used
@@ -4060,20 +4108,26 @@ import_iso_c_binding_module (void)
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
if (only_flag)
- for (u = gfc_rename_list; u; u = u->next)
- {
- i = get_c_kind (u->use_name, c_interop_kinds_table);
+ {
+ /* Sort the rename list because there are dependencies between types
+ and procedures (e.g., c_loc needs c_ptr). */
+ sort_iso_c_rename_list ();
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ i = get_c_kind (u->use_name, c_interop_kinds_table);
- if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
- {
- gfc_error ("Symbol '%s' referenced at %L does not exist in "
- "intrinsic module ISO_C_BINDING.", u->use_name,
- &u->where);
- continue;
- }
+ if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", u->use_name,
+ &u->where);
+ continue;
+ }
- generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
- }
+ generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
+ }
+ }
else
{
for (i = 0; i < ISOCBINDING_NUMBER; i++)
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c (revision 122521)
+++ gcc/fortran/trans-types.c (working copy)
@@ -124,6 +124,25 @@ gfc_validate_c_kind (gfc_typespec *ts)
}
+try
+gfc_check_any_c_kind (gfc_typespec *ts)
+{
+ int i;
+
+ for (i = ISOCBINDING_INVALID; i < ISOCBINDING_NUMBER; i++)
+ {
+ /* Check for any C interoperable kind for the given type/kind in ts.
+ This can be used after verify_c_interop to make sure that the
+ Fortran kind being used exists in at least some form for C. */
+ if (c_interop_kinds_table[i].f90_type == ts->type &&
+ c_interop_kinds_table[i].value == ts->kind)
+ return SUCCESS;
+ }
+
+ return FAILURE;
+}
+
+
static int
get_real_kind_from_node (tree type)
{
@@ -1842,7 +1861,7 @@ gfc_return_by_reference (gfc_symbol * sy
&& sym->ts.type == BT_COMPLEX
&& !sym->attr.intrinsic && !sym->attr.always_explicit)
return 1;
-
+
return 0;
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 122521)
+++ gcc/fortran/resolve.c (working copy)
@@ -619,23 +619,6 @@ resolve_contained_functions (gfc_namespa
resolve_contained_fntype (child->proc_name, child);
for (el = child->entries; el; el = el->next)
resolve_contained_fntype (el->sym, child);
-
- /* The verification of BIND(C) routines is done here, and the params
- are verified in resolve_symbol. */
- if (child->proc_name != NULL && child->proc_name->attr.is_bind_c)
- {
- try proc = SUCCESS;
- proc = verify_bind_c_sym (child->proc_name, &(child->proc_name->ts),
- 0, NULL);
-
- if (proc == FAILURE)
- /* Clear the is_bind_c flag so we don't try and test the params
- or the procedure type again if it failed the first time. This
- should prevent multiple error messages from being printed. */
- child->proc_name->attr.is_bind_c = 0;
- else
- child->proc_name->attr.is_c_interop = 1;
- }
}
}
@@ -1540,24 +1523,82 @@ pure_function (gfc_expr * e, const char
}
+static try
+is_scalar_expr_ptr (gfc_expr *expr)
+{
+ try retval = SUCCESS;
+ gfc_ref *ref;
+ int start;
+ int end;
+
+ /* See if we have a gfc_ref, which means we have a substring, array
+ reference, or a component. */
+ if (expr->ref != NULL)
+ {
+ ref = expr->ref;
+ while (ref->next != NULL)
+ ref = ref->next;
+
+ switch (ref->type)
+ {
+ case REF_SUBSTRING:
+ if (ref->u.ss.length != NULL
+ && ref->u.ss.length->length != NULL
+ && ref->u.ss.start
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref->u.ss.end
+ && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ start = (int)(mpz_get_si
+ (ref->u.ss.start->value.integer));
+ end = (int)(mpz_get_si
+ (ref->u.ss.end->value.integer));
+ if (((end - start) + 1) != 1)
+ retval = FAILURE;
+ }
+ else
+ retval = FAILURE;
+ break;
+ case REF_ARRAY:
+ if (ref->u.ar.type != AR_ELEMENT)
+ retval = FAILURE;
+ break;
+ default:
+ retval = SUCCESS;
+ break;
+ }
+ }
+ else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
+ {
+ /* Character string. Make sure it's of length 1. */
+ if (expr->ts.cl == NULL
+ || expr->ts.cl->length == NULL
+ || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
+ retval = FAILURE;
+ }
+ else if (expr->rank != 0)
+ retval = FAILURE;
+
+ return retval;
+}
+
+
/* Match one of the iso_c_binding functions (c_associated or c_loc)
and, in the case of c_associated, set the binding label based on
the arguments. */
-static gfc_symbol *
-gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args)
+static try
+gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
+ gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
- gfc_symbol *new_sym = NULL;
int optional_arg = 0;
-
- /* if we weren't given args, we're in trouble. this should not be
- * reached because parameter verification should have happened already.
- */
- if (args == NULL)
- gfc_internal_error ("gfc_iso_c_func_interface(): Missing args!\n");
+ try retval = SUCCESS;
+ gfc_symbol *args_sym;
+ args_sym = args->expr->symtree->n.sym;
+
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
/* If the user gave two args then they are providing something for
@@ -1581,17 +1622,137 @@ gfc_iso_c_func_interface (gfc_symbol *sy
/* Get a new symbol for the version of c_associated that
will get called. */
- new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
+ *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
}
- else if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ else if (sym->intmod_sym_id == ISOCBINDING_LOC ||
+ sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
sprintf (binding_label, "%s", sym->binding_label);
+
+ /* Error check the call. */
if (args->next != NULL)
- gfc_error_now ("More actual than formal arguments in '%s' "
- "call at %C", name);
- /* for c_loc, the new symbol is the same as the old one */
- new_sym = sym;
+ {
+ gfc_error_now ("More actual than formal arguments in '%s' "
+ "call at %L", name, &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ {
+ /* Make sure we have either the target or pointer attribute. */
+ if (!(args->expr->symtree->n.sym->attr.target) &&
+ !(args->expr->symtree->n.sym->attr.pointer))
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
+ "a TARGET or an associated pointer",
+ args->expr->symtree->n.sym->name,
+ sym->name, &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* See if we have interoperable type and type param. */
+ if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
+ args->expr->symtree->n.sym->name,
+ &(args->expr->where)) == SUCCESS
+ || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
+ {
+ if (args_sym->attr.target == 1)
+ {
+ /* Case 1a, section 15.1.2.5, J3/04-007: variable that
+ has the target attribute and is interoperable. */
+ /* Case 1b, section 15.1.2.5, J3/04-007: allocated
+ allocatable variable that has the TARGET attribute and
+ is not an array of zero size. */
+ if (args_sym->attr.allocatable == 1)
+ {
+ if (args_sym->attr.dimension != 0
+ && (args_sym->as && args_sym->as->rank == 0))
+ {
+ gfc_error_now ("Allocatable variable '%s' used as a "
+ "parameter to '%s' at %L must not be "
+ "an array of zero size",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ else
+ {
+ /* Make sure it's not a character string. Arrays of
+ any type should be ok if the variable is of a C
+ interoperable type. */
+ if (args_sym->ts.type == BT_CHARACTER
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("CHARACTER argument '%s' to '%s' at "
+ "%L must have a length of 1",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ }
+ else if (args_sym->attr.pointer == 1
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ /* Case 1c, section 15.1.2.5, J3/04-007: an associated
+ scalar pointer. */
+ gfc_error_now ("Argument '%s' to '%s' at %L must be an "
+ "associated scalar POINTER", args_sym->name,
+ sym->name, &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ else
+ {
+ /* The parameter is not required to be C interoperable. If it
+ is not C interoperable, it must be a nonpolymorphic scalar
+ with no length type parameters. It still must have either
+ the pointer or target attribute, and it can be
+ allocatable (but must be allocated when c_loc is called). */
+ if (args_sym->attr.dimension != 0
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ "scalar", args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (args_sym->ts.type == BT_CHARACTER
+ && args_sym->ts.cl != NULL)
+ {
+ gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
+ "cannot have a length type parameter",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
+ {
+ /* TODO: Update this error message to allow for procedure
+ pointers once they are implemented. */
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ "procedure",
+ args->expr->symtree->n.sym->name, sym->name,
+ &(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;
+ }
+ }
+
+ /* for c_loc/c_funloc, the new symbol is the same as the old one */
+ *new_sym = sym;
}
else
{
@@ -1599,9 +1760,7 @@ gfc_iso_c_func_interface (gfc_symbol *sy
"iso_c_binding function: '%s'!\n", sym->name);
}
- /* Return the new_sym, which is either a resolved c_associated or
- the same sym for c_loc we were given. */
- return new_sym;
+ return retval;
}
@@ -1631,16 +1790,6 @@ resolve_function (gfc_expr * expr)
return FAILURE;
}
- /* Need to setup the call to the correct c_associated, depending on
- the number of cptrs to user gives to compare. */
- if (sym && sym->attr.is_iso_c == 1)
- {
- sym = gfc_iso_c_func_interface (sym, expr->value.function.actual);
- /* Get the symtree for the new symbol (resolved func).
- the old one will be freed later, when it's no longer used. */
- gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
- }
-
/* If the procedure is not internal, a statement function or a module
procedure,it must be external and should be checked for usage. */
if (sym && !sym->attr.dummy && !sym->attr.contained
@@ -1658,6 +1807,19 @@ resolve_function (gfc_expr * expr)
if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
return FAILURE;
+ /* Need to setup the call to the correct c_associated, depending on
+ the number of cptrs to user gives to compare. */
+ if (sym && sym->attr.is_iso_c == 1)
+ {
+ if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
+ == FAILURE)
+ return FAILURE;
+
+ /* Get the symtree for the new symbol (resolved func).
+ the old one will be freed later, when it's no longer used. */
+ gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
+ }
+
/* Resume assumed_size checking. */
need_full_assumed_size--;
@@ -5591,6 +5753,104 @@ resolve_values (gfc_symbol * sym)
}
+/* Verify the binding labels for common blocks that are BIND(C). The label
+ for a BIND(C) common block must be identical in all scoping units in which
+ the common block is declared. Further, the binding label can not collide
+ with any other global entity in the program. */
+
+static void
+resolve_bind_c_comms (gfc_symtree *comm_block_tree)
+{
+ if (comm_block_tree->n.common->is_bind_c == 1)
+ {
+ gfc_gsymbol *binding_label_gsym;
+ gfc_gsymbol *comm_name_gsym;
+
+ /* See if a global symbol exists by the common block's name. It may
+ be NULL if the common block is use-associated. */
+ comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->name);
+ if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L collides "
+ "with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ else if (comm_name_gsym != NULL &&
+ strcmp (comm_name_gsym->name,
+ comm_block_tree->n.common->name) == 0)
+ {
+ /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
+ as expected. */
+ if (comm_name_gsym->binding_label == NULL)
+ /* No binding label for common block stored yet; save this one. */
+ comm_name_gsym->binding_label =
+ comm_block_tree->n.common->binding_label;
+ else
+ if (strcmp (comm_name_gsym->binding_label,
+ comm_block_tree->n.common->binding_label) != 0)
+ {
+ /* Common block names match but binding labels do not. */
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "does not match the binding label '%s' for common "
+ "block '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->binding_label,
+ comm_name_gsym->name,
+ &(comm_name_gsym->where));
+ return;
+ }
+ }
+
+ /* There is no binding label (NAME="") so we have nothing further to
+ check and nothing to add as a global symbol for the label. */
+ if (comm_block_tree->n.common->binding_label[0] == '\0' )
+ return;
+
+ binding_label_gsym =
+ gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->binding_label);
+ if (binding_label_gsym == NULL)
+ {
+ /* Need to make a global symbol for the binding label to prevent
+ it from colliding with another. */
+ binding_label_gsym =
+ gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
+ binding_label_gsym->sym_name = comm_block_tree->n.common->name;
+ binding_label_gsym->type = GSYM_COMMON;
+ }
+ else
+ {
+ /* If comm_name_gsym is NULL, the name common block is use
+ associated and the name could be colliding. */
+ if (binding_label_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ binding_label_gsym->name,
+ &(binding_label_gsym->where));
+ else if (comm_name_gsym != NULL &&
+ (strcmp (binding_label_gsym->name,
+ comm_name_gsym->binding_label) != 0) &&
+ (strcmp (binding_label_gsym->sym_name,
+ comm_name_gsym->name) != 0))
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with global entity '%s' at %L",
+ binding_label_gsym->name, binding_label_gsym->sym_name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ }
+ }
+
+ return;
+}
+
+
/* Verify any BIND(C) derived types in the namespace so we can report errors
for them once, rather than for each variable declared of that type. */
@@ -5611,64 +5871,82 @@ resolve_bind_c_derived_types (gfc_symbol
static void
gfc_verify_binding_labels (gfc_symbol *sym)
{
- if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
- && sym->attr.flavor != FL_DERIVED)
+ int has_error = 0;
+
+ if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
{
gfc_gsymbol *bind_c_sym;
-
+
bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
- if (bind_c_sym != NULL)
- {
- if (sym->attr.if_source == IFSRC_DECL
- && bind_c_sym->type != GSYM_SUBROUTINE
- && bind_c_sym->type != GSYM_FUNCTION
- && (sym->attr.use_assoc == 0
- || (sym->attr.use_assoc == 1
- && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
- /* Make sure global procedures don't collide with anything. */
- gfc_error ("Binding label '%s' at %L collides with the global "
- "entity '%s' at %L", sym->binding_label,
- &(sym->declared_at), bind_c_sym->name,
- &(bind_c_sym->where));
- 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)
- /* Make sure procedures in interface bodies don't collide. */
- gfc_error ("Binding label '%s' in interface body at %L collides "
- "with the global entity '%s' at %L", sym->binding_label,
- &(sym->declared_at), bind_c_sym->name,
- &(bind_c_sym->where));
- else if (sym->attr.contained == 0 &&
- (sym->attr.if_source == IFSRC_UNKNOWN))
- if ((sym->attr.use_assoc
- && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
- || sym->attr.use_assoc == 0)
- gfc_error ("Binding label '%s' at %L collides with global "
- "entity '%s' at %L", sym->binding_label,
- &(sym->declared_at), bind_c_sym->name,
- &(bind_c_sym->where));
- }
- else
+ 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
+ && bind_c_sym->type != GSYM_FUNCTION)
+ && ((sym->attr.contained == 1
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ || (sym->attr.use_assoc == 1
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
+ {
+ /* Make sure global procedures don't collide with anything. */
+ gfc_error ("Binding label '%s' at %L collides with the global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ 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)
+ {
+ /* Make sure procedures in interface bodies don't collide. */
+ gfc_error ("Binding label '%s' in interface body at %L collides "
+ "with the global entity '%s' at %L",
+ sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_UNKNOWN))
+ if ((sym->attr.use_assoc
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
+ || sym->attr.use_assoc == 0)
+ {
+ gfc_error ("Binding label '%s' at %L collides with global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+
+ if (has_error != 0)
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label[0] = '\0';
+ }
+ else if (bind_c_sym == NULL)
{
bind_c_sym = gfc_get_gsymbol (sym->binding_label);
bind_c_sym->where = sym->declared_at;
bind_c_sym->sym_name = sym->name;
- if (sym->attr.use_assoc == 1)
- bind_c_sym->mod_name = sym->module;
- else
- if (sym->ns->proc_name != NULL)
- bind_c_sym->mod_name = sym->ns->proc_name->name;
+ if (sym->attr.use_assoc == 1)
+ bind_c_sym->mod_name = sym->module;
+ else
+ if (sym->ns->proc_name != NULL)
+ bind_c_sym->mod_name = sym->ns->proc_name->name;
- if (sym->attr.contained == 0)
- {
- if (sym->attr.subroutine)
- bind_c_sym->type = GSYM_SUBROUTINE;
- else if (sym->attr.function)
- bind_c_sym->type = GSYM_FUNCTION;
- }
- }
+ if (sym->attr.contained == 0)
+ {
+ if (sym->attr.subroutine)
+ bind_c_sym->type = GSYM_SUBROUTINE;
+ else if (sym->attr.function)
+ bind_c_sym->type = GSYM_FUNCTION;
+ }
+ }
}
return;
}
@@ -6149,6 +6427,41 @@ resolve_fl_procedure (gfc_symbol *sym, i
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
+
+ if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
+ {
+ gfc_formal_arglist *curr_arg;
+
+ if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block) == FAILURE)
+ {
+ /* Clear these to prevent looking at them again if there was an
+ error. */
+ sym->attr.is_bind_c = 0;
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ }
+ else
+ {
+ /* So far, no errors have been found. */
+ sym->attr.is_c_interop = 1;
+ sym->ts.is_c_interop = 1;
+ }
+
+ curr_arg = sym->formal;
+ while (curr_arg != NULL)
+ {
+ /* Skip implicitly typed dummy args here. */
+ if (curr_arg->sym->attr.implicit_type == 0 &&
+ verify_c_interop_param (curr_arg->sym) == FAILURE)
+ {
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ }
+ curr_arg = curr_arg->next;
+ }
+ }
+
return SUCCESS;
}
@@ -6560,19 +6873,6 @@ resolve_symbol (gfc_symbol * sym)
}
}
- /* If we're working on a dummy and the containing procedure is BIND(C),
- we need to verify the params. */
- if (sym->attr.dummy == 1 && sym->attr.implicit_type == 0)
- {
- /* See if the containing procedure is BIND(C) */
- if (sym->ns->proc_name->attr.is_bind_c == 1)
- {
- /* Verify the params */
- if (verify_c_interop_param (sym) == FAILURE)
- return;
- }
- }
-
/* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most
conditions that produce undefined derived types have already
@@ -7687,9 +7987,10 @@ resolve_types (gfc_namespace * ns)
iter_stack = NULL;
gfc_traverse_ns (ns, gfc_formalize_init_value);
- if (ns->parent == NULL &&
- (ns->proc_name != NULL && ns->proc_name->from_intmod == INTMOD_NONE))
- gfc_traverse_ns (ns, gfc_verify_binding_labels);
+ gfc_traverse_ns (ns, gfc_verify_binding_labels);
+
+ if (ns->common_root != NULL)
+ gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 122521)
+++ gcc/fortran/primary.c (working copy)
@@ -2167,29 +2167,20 @@ gfc_match_rvalue (gfc_expr ** result)
break;
}
+ /* Check here for the existence of at least one argument for the
+ iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
+ argument(s) given will be checked in gfc_iso_c_func_interface,
+ during resolution of the function call. */
if (sym->attr.is_iso_c == 1 &&
- strcmp (sym->name, "c_loc") == 0)
+ (sym->from_intmod == INTMOD_ISO_C_BINDING &&
+ (sym->intmod_sym_id == ISOCBINDING_LOC ||
+ sym->intmod_sym_id == ISOCBINDING_FUNLOC ||
+ sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
{
/* make sure we were given a param */
if (actual_arglist == NULL)
{
- gfc_error ("Missing argument to 'C_LOC' at %C");
- m = MATCH_ERROR;
- break;
- }
- else if (actual_arglist->next != NULL)
- {
- gfc_error ("More actual than formal args to procedure "
- "'C_LOC' at %C");
- m = MATCH_ERROR;
- break;
- }
- else if (!(actual_arglist->expr->symtree->n.sym->attr.target) &&
- !(actual_arglist->expr->symtree->n.sym->attr.pointer))
- {
- gfc_error ("Parameter '%s' to 'C_LOC' at %C must be either "
- "a TARGET or an associated pointer",
- actual_arglist->expr->symtree->n.sym->name);
+ gfc_error ("Missing argument to '%s' at %C", sym->name);
m = MATCH_ERROR;
break;
}
Index: libgfortran/intrinsics/iso_c_generated_procs.c
===================================================================
--- libgfortran/intrinsics/iso_c_generated_procs.c (revision 122521)
+++ libgfortran/intrinsics/iso_c_generated_procs.c (working copy)
@@ -9,6 +9,16 @@
*
*/
+#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);
+#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);
+#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,
@@ -19,6 +29,11 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_i8
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);
+#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,
@@ -40,6 +55,53 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_r1
const array_t *shape);
#endif
+
+#ifdef HAVE_GFC_INTEGER_1
+/* 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=1. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given 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_i1) (c_ptr_t 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));
+ return;
+}
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_2
+/* 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=2. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given 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)
+{
+ /* 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
@@ -68,6 +130,7 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_i4
}
#endif
+
#ifdef HAVE_GFC_INTEGER_8
/**
* Set the given Fortran pointer, <code>f_ptr_out</code>, to point
@@ -97,6 +160,29 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_i8
#endif
+#ifdef HAVE_GFC_INTEGER_16
+/* 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=16. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given 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)
+{
+ /* 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));
+ return;
+}
+#endif
+
+
#ifdef HAVE_GFC_REAL_4
/**
* Set the given Fortran pointer, <code>f_ptr_out</code>, to point
Index: libgfortran/intrinsics/iso_c_binding.c
===================================================================
--- libgfortran/intrinsics/iso_c_binding.c (revision 122521)
+++ libgfortran/intrinsics/iso_c_binding.c (working copy)
@@ -262,3 +262,25 @@ c_ptr_t ISO_C_BINDING_PREFIX(c_loc)(void
/* the "C" address should be the address of the object in Fortran */
return my_c_ptr;
}/* end ISO_C_BINDING_PREFIX(c_loc)() */
+
+
+/* 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. */
+c_funptr_t
+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();
+ }
+
+ my_c_funptr.c_address = f90_obj;
+
+ /* the "C" address should be the address of the object in Fortran */
+ return my_c_funptr;
+}/* end ISO_C_BINDING_PREFIX(c_funloc)() */
Index: libgfortran/intrinsics/iso_c_binding.h
===================================================================
--- libgfortran/intrinsics/iso_c_binding.h (revision 122521)
+++ libgfortran/intrinsics/iso_c_binding.h (working copy)
@@ -38,6 +38,7 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_d0
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);
#endif
More information about the Fortran
mailing list