flang/module/iso_c_binding.f90

   1 !===-- module/iso_c_binding.f90 --------------------------------------------===!
   2 !
   3 ! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 ! See https://llvm.org/LICENSE.txt for license information.
   5 ! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 !
   7 !===------------------------------------------------------------------------===!
   8
   9 ! See Fortran 2018, clause 18.2
  10
  11 module iso_c_binding
  12
  13   use __Fortran_builtins, only: &
  14     c_f_pointer => __builtin_c_f_pointer, &
  15     c_ptr => __builtin_c_ptr, &
  16     c_funptr => __builtin_c_funptr, &
  17     c_sizeof => sizeof, &
  18     c_loc => __builtin_c_loc
  19
  20   type(c_ptr), parameter :: c_null_ptr = c_ptr(0)
  21   type(c_funptr), parameter :: c_null_funptr = c_funptr(0)
  22
  23   ! Table 18.2 (in clause 18.3.1)
  24   ! TODO: Specialize (via macros?) for alternative targets
  25   integer, parameter :: &
  26     c_int8_t = 1, &
  27     c_int16_t = 2, &
  28     c_int32_t = 4, &
  29     c_int64_t = 8, &
  30     c_int128_t = 16 ! anticipating future addition
  31   integer, parameter :: &
  32     c_int = c_int32_t, &
  33     c_short = c_int16_t, &
  34     c_long = c_int64_t, &
  35     c_long_long = c_int64_t, &
  36     c_signed_char = c_int8_t, &
  37     c_size_t = kind(c_sizeof(1)), &
  38     c_intmax_t = c_int128_t, &
  39     c_intptr_t = c_size_t, &
  40     c_ptrdiff_t = c_size_t
  41   integer, parameter :: &
  42     c_int_least8_t = c_int8_t, &
  43     c_int_fast8_t = c_int8_t, &
  44     c_int_least16_t = c_int16_t, &
  45     c_int_fast16_t = c_int16_t, &
  46     c_int_least32_t = c_int32_t, &
  47     c_int_fast32_t = c_int32_t, &
  48     c_int_least64_t = c_int64_t, &
  49     c_int_fast64_t = c_int64_t, &
  50     c_int_least128_t = c_int128_t, &
  51     c_int_fast128_t = c_int128_t
  52
  53   integer, parameter :: &
  54     c_float = 4, &
  55     c_double = 8, &
  56 #if __x86_64__
  57     c_long_double = 10
  58 #else
  59     c_long_double = 16
  60 #endif
  61
  62   integer, parameter :: &
  63     c_float_complex = c_float, &
  64     c_double_complex = c_double, &
  65     c_long_double_complex = c_long_double
  66
  67   integer, parameter :: c_bool = 1
  68   integer, parameter :: c_char = 1
  69
  70   ! C characters with special semantics
  71   character(kind=c_char, len=1), parameter :: c_null_char = achar(0)
  72   character(kind=c_char, len=1), parameter :: c_alert = achar(7)
  73   character(kind=c_char, len=1), parameter :: c_backspace = achar(8)
  74   character(kind=c_char, len=1), parameter :: c_form_feed = achar(12)
  75   character(kind=c_char, len=1), parameter :: c_new_line = achar(10)
  76   character(kind=c_char, len=1), parameter :: c_carriage_return = achar(13)
  77   character(kind=c_char, len=1), parameter :: c_horizontal_tab = achar(9)
  78   character(kind=c_char, len=1), parameter :: c_vertical_tab =  achar(11)
  79
  80   interface c_associated
  81     module procedure c_associated_c_ptr
  82     module procedure c_associated_c_funptr
  83   end interface
  84   private :: c_associated_c_ptr, c_associated_c_funptr
  85
  86   interface c_f_procpointer
  87     module procedure c_f_procpointer
  88   end interface
  89
  90   ! gfortran extensions
  91   integer, parameter :: &
  92     c_float128 = 16, &
  93     c_float128_complex = c_float128
  94
  95  contains
  96
  97   pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2)
  98     type(c_ptr), intent(in) :: c_ptr_1
  99     type(c_ptr), intent(in), optional :: c_ptr_2
 100     if (c_ptr_1%__address == c_null_ptr%__address) then
 101       c_associated_c_ptr = .false.
 102     else if (present(c_ptr_2)) then
 103       c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address
 104     else
 105       c_associated_c_ptr = .true.
 106     end if
 107   end function c_associated_c_ptr
 108
 109   pure logical function c_associated_c_funptr(c_funptr_1, c_funptr_2)
 110     type(c_funptr), intent(in) :: c_funptr_1
 111     type(c_funptr), intent(in), optional :: c_funptr_2
 112     if (c_funptr_1%__address == c_null_ptr%__address) then
 113       c_associated_c_funptr = .false.
 114     else if (present(c_funptr_2)) then
 115       c_associated_c_funptr = c_funptr_1%__address == c_funptr_2%__address
 116     else
 117       c_associated_c_funptr = .true.
 118     end if
 119   end function c_associated_c_funptr
 120
 121   function c_funloc(x)
 122     type(c_funptr) :: c_funloc
 123     external :: x
 124     c_funloc = c_funptr(loc(x))
 125   end function c_funloc
 126
 127   subroutine c_f_procpointer(cptr, fptr)
 128     type(c_funptr), intent(in) :: cptr
 129     procedure(), pointer, intent(out) :: fptr
 130     ! TODO: implement
 131   end subroutine c_f_procpointer
 132
 133 end module iso_c_binding