diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -21,23 +21,23 @@ integer, parameter, private :: int64 = selected_int_kind(18) type, bind(c) :: __builtin_c_ptr - integer(kind=int64) :: __address + integer(kind=int64), private :: __address end type type, bind(c) :: __builtin_c_funptr - integer(kind=int64) :: __address + integer(kind=int64), private :: __address end type type :: __builtin_event_type - integer(kind=int64) :: __count + integer(kind=int64), private :: __count end type type :: __builtin_lock_type - integer(kind=int64) :: __count + integer(kind=int64), private :: __count end type type :: __builtin_team_type - integer(kind=int64) :: __id + integer(kind=int64), private :: __id end type integer, parameter :: __builtin_atomic_int_kind = selected_int_kind(18) @@ -83,6 +83,15 @@ module procedure __builtin_c_ptr_eq end interface + interface __builtin_c_associated + module procedure c_associated_c_ptr + module procedure c_associated_c_funptr + end interface + private :: c_associated_c_ptr, c_associated_c_funptr + + type(__builtin_c_ptr), parameter :: __builtin_c_null_ptr = __builtin_c_ptr(0) + type(__builtin_c_funptr), parameter :: __builtin_c_null_funptr = __builtin_c_funptr(0) + contains elemental logical function __builtin_c_ptr_eq(x, y) @@ -95,4 +104,34 @@ __builtin_c_ptr_ne = x%__address /= y%__address end function + function __builtin_c_funloc(x) + type(__builtin_c_funptr) :: __builtin_c_funloc + external :: x + __builtin_c_funloc = __builtin_c_funptr(loc(x)) + end function + + pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2) + type(__builtin_c_ptr), intent(in) :: c_ptr_1 + type(__builtin_c_ptr), intent(in), optional :: c_ptr_2 + if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then + c_associated_c_ptr = .false. + else if (present(c_ptr_2)) then + c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address + else + c_associated_c_ptr = .true. + end if + end function c_associated_c_ptr + + pure logical function c_associated_c_funptr(c_funptr_1, c_funptr_2) + type(__builtin_c_funptr), intent(in) :: c_funptr_1 + type(__builtin_c_funptr), intent(in), optional :: c_funptr_2 + if (c_funptr_1%__address == __builtin_c_null_ptr%__address) then + c_associated_c_funptr = .false. + else if (present(c_funptr_2)) then + c_associated_c_funptr = c_funptr_1%__address == c_funptr_2%__address + else + c_associated_c_funptr = .true. + end if + end function c_associated_c_funptr + end module diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90 --- a/flang/module/iso_c_binding.f90 +++ b/flang/module/iso_c_binding.f90 @@ -11,16 +11,17 @@ module iso_c_binding use __Fortran_builtins, only: & + c_associated => __builtin_c_associated, & + c_funloc => __builtin_c_funloc, & + c_funptr => __builtin_c_funptr, & c_f_pointer => __builtin_c_f_pointer, & + c_loc => __builtin_c_loc, & + c_null_funptr => __builtin_c_null_funptr, & + c_null_ptr => __builtin_c_null_ptr, & c_ptr => __builtin_c_ptr, & - c_funptr => __builtin_c_funptr, & c_sizeof => sizeof, & - c_loc => __builtin_c_loc, & operator(==), operator(/=) - type(c_ptr), parameter :: c_null_ptr = c_ptr(0) - type(c_funptr), parameter :: c_null_funptr = c_funptr(0) - ! Table 18.2 (in clause 18.3.1) ! TODO: Specialize (via macros?) for alternative targets integer, parameter :: & @@ -78,12 +79,6 @@ character(kind=c_char, len=1), parameter :: c_horizontal_tab = achar(9) character(kind=c_char, len=1), parameter :: c_vertical_tab = achar(11) - interface c_associated - module procedure c_associated_c_ptr - module procedure c_associated_c_funptr - end interface - private :: c_associated_c_ptr, c_associated_c_funptr - interface c_f_procpointer module procedure c_f_procpointer end interface @@ -95,36 +90,6 @@ contains - pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2) - type(c_ptr), intent(in) :: c_ptr_1 - type(c_ptr), intent(in), optional :: c_ptr_2 - if (c_ptr_1%__address == c_null_ptr%__address) then - c_associated_c_ptr = .false. - else if (present(c_ptr_2)) then - c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address - else - c_associated_c_ptr = .true. - end if - end function c_associated_c_ptr - - pure logical function c_associated_c_funptr(c_funptr_1, c_funptr_2) - type(c_funptr), intent(in) :: c_funptr_1 - type(c_funptr), intent(in), optional :: c_funptr_2 - if (c_funptr_1%__address == c_null_ptr%__address) then - c_associated_c_funptr = .false. - else if (present(c_funptr_2)) then - c_associated_c_funptr = c_funptr_1%__address == c_funptr_2%__address - else - c_associated_c_funptr = .true. - end if - end function c_associated_c_funptr - - function c_funloc(x) - type(c_funptr) :: c_funloc - external :: x - c_funloc = c_funptr(loc(x)) - end function c_funloc - subroutine c_f_procpointer(cptr, fptr) type(c_funptr), intent(in) :: cptr procedure(), pointer, intent(out) :: fptr diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90 --- a/flang/test/Semantics/c_loc01.f90 +++ b/flang/test/Semantics/c_loc01.f90 @@ -9,6 +9,7 @@ type(*), target :: assumedType class(*), target :: poly type(c_ptr) cp + type(c_funptr) cfp real notATarget procedure(sin), pointer :: pptr real, target :: arr(3) @@ -33,5 +34,13 @@ !WARNING: C_LOC() argument has non-interoperable intrinsic type, kind, or length cp = c_loc(ch) cp = c_loc(ch(1:1)) ! ok) + !ERROR: PRIVATE name '__address' is only accessible within module '__fortran_builtins' + cp = c_ptr(0) + !ERROR: PRIVATE name '__address' is only accessible within module '__fortran_builtins' + cfp = c_funptr(0) + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_ptr) and TYPE(c_funptr) + cp = cfp + !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_funptr) and TYPE(c_ptr) + cfp = cp end end module