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
11module 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 ! TODO: or default LOGICAL?
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  ! gfortran extensions
87  integer, parameter :: &
88    c_float128 = 16, &
89    c_float128_complex = c_float128
90
91 contains
92
93  logical function c_associated_c_ptr(c_ptr_1, c_ptr_2)
94    type(c_ptr), intent(in) :: c_ptr_1
95    type(c_ptr), intent(in), optional :: c_ptr_2
96    if (c_ptr_1%__address == c_null_ptr%__address) then
97      c_associated_c_ptr = .false.
98    else if (present(c_ptr_2)) then
99      c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address
100    else
101      c_associated_c_ptr = .true.
102    end if
103  end function c_associated_c_ptr
104
105  logical function c_associated_c_funptr(c_funptr_1, c_funptr_2)
106    type(c_funptr), intent(in) :: c_funptr_1
107    type(c_funptr), intent(in), optional :: c_funptr_2
108    if (c_funptr_1%__address == c_null_ptr%__address) then
109      c_associated_c_funptr = .false.
110    else if (present(c_funptr_2)) then
111      c_associated_c_funptr = c_funptr_1%__address == c_funptr_2%__address
112    else
113      c_associated_c_funptr = .true.
114    end if
115  end function c_associated_c_funptr
116
117  function c_funloc(x)
118    type(c_funptr) :: c_funloc
119    external :: x
120    c_funloc = c_funptr(loc(x))
121  end function c_funloc
122
123  ! TODO c_f_procpointer
124
125end module iso_c_binding
126