llvm-project

1
!===-- module/__fortran_builtins.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
include '../include/flang/Runtime/magic-numbers.h'
10

11
! These naming shenanigans prevent names from Fortran intrinsic modules
12
! from being usable on INTRINSIC statements, and force the program
13
! to USE the standard intrinsic modules in order to access the
14
! standard names of the procedures.
15
module __fortran_builtins
16
  implicit none
17

18
  ! Set PRIVATE by default to explicitly only export what is meant
19
  ! to be exported by this MODULE.
20
  private
21

22
  intrinsic :: __builtin_c_loc
23
  public :: __builtin_c_loc
24

25
  intrinsic :: __builtin_c_f_pointer
26
  public :: __builtin_c_f_pointer
27

28
  intrinsic :: sizeof ! extension
29
  public :: sizeof
30

31
  intrinsic :: selected_int_kind
32
  integer, parameter :: int64 = selected_int_kind(18)
33

34
  type, bind(c), public :: __builtin_c_ptr
35
    integer(kind=int64), private :: __address
36
  end type
37

38
  type, bind(c), public :: __builtin_c_funptr
39
    integer(kind=int64), private :: __address
40
  end type
41

42
  type, public :: __builtin_event_type
43
    integer(kind=int64), private :: __count
44
  end type
45

46
  type, public :: __builtin_notify_type
47
    integer(kind=int64), private :: __count
48
  end type
49

50
  type, public :: __builtin_lock_type
51
    integer(kind=int64), private :: __count
52
  end type
53

54
  type, public :: __builtin_ieee_flag_type
55
    integer(kind=1), private :: flag = 0
56
  end type
57

58
  type(__builtin_ieee_flag_type), parameter, public :: &
59
    __builtin_ieee_invalid = &
60
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), &
61
    __builtin_ieee_overflow = &
62
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), &
63
    __builtin_ieee_divide_by_zero = &
64
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), &
65
    __builtin_ieee_underflow = &
66
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), &
67
    __builtin_ieee_inexact = &
68
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), &
69
    __builtin_ieee_denorm = & ! extension
70
      __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM)
71

72
  type, public :: __builtin_ieee_round_type
73
    integer(kind=1), private :: mode = 0
74
  end type
75

76
  type(__builtin_ieee_round_type), parameter, public :: &
77
    __builtin_ieee_to_zero = &
78
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), &
79
    __builtin_ieee_nearest = &
80
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), &
81
    __builtin_ieee_up = &
82
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), &
83
    __builtin_ieee_down = &
84
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), &
85
    __builtin_ieee_away = &
86
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), &
87
    __builtin_ieee_other = &
88
      __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER)
89

90
  type, public :: __builtin_team_type
91
    integer(kind=int64), private :: __id
92
  end type
93

94
  integer, parameter, public :: __builtin_atomic_int_kind = selected_int_kind(18)
95
  integer, parameter, public :: &
96
    __builtin_atomic_logical_kind = __builtin_atomic_int_kind
97

98
  type, public :: __builtin_dim3
99
    integer :: x=1, y=1, z=1
100
  end type
101
  type(__builtin_dim3), public :: &
102
    __builtin_threadIdx, __builtin_blockDim, __builtin_blockIdx, &
103
    __builtin_gridDim
104
  integer, parameter, public :: __builtin_warpsize = 32
105

106
  intrinsic :: __builtin_fma
107
  intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
108
    __builtin_ieee_is_normal
109
  intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
110
    __builtin_ieee_next_up
111
  intrinsic :: scale ! for ieee_scalb
112
  intrinsic :: __builtin_ieee_selected_real_kind
113
  intrinsic :: __builtin_ieee_support_datatype, &
114
    __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
115
    __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
116
    __builtin_ieee_support_inf, __builtin_ieee_support_io, &
117
    __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
118
    __builtin_ieee_support_sqrt, &
119
    __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
120
    __builtin_ieee_support_underflow_control
121
  public :: __builtin_fma
122
  public :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
123
    __builtin_ieee_is_normal
124
  public :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
125
    __builtin_ieee_next_up
126
  public :: scale ! for ieee_scalb
127
  public :: __builtin_ieee_selected_real_kind
128
  public :: __builtin_ieee_support_datatype, &
129
    __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
130
    __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
131
    __builtin_ieee_support_inf, __builtin_ieee_support_io, &
132
    __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
133
    __builtin_ieee_support_sqrt, &
134
    __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
135
    __builtin_ieee_support_underflow_control
136

137
  type :: __force_derived_type_instantiations
138
    type(__builtin_c_ptr) :: c_ptr
139
    type(__builtin_c_funptr) :: c_funptr
140
    type(__builtin_event_type) :: event_type
141
    type(__builtin_lock_type) :: lock_type
142
    type(__builtin_team_type) :: team_type
143
  end type
144

145
  intrinsic :: __builtin_compiler_options, __builtin_compiler_version
146
  public :: __builtin_compiler_options, __builtin_compiler_version
147

148
  interface operator(==)
149
    module procedure __builtin_c_ptr_eq
150
  end interface
151
  public :: operator(==)
152

153
  interface operator(/=)
154
    module procedure __builtin_c_ptr_ne
155
  end interface
156
  public :: operator(/=)
157

158
  interface __builtin_c_associated
159
    module procedure c_associated_c_ptr
160
    module procedure c_associated_c_funptr
161
  end interface
162
  public :: __builtin_c_associated
163
!  private :: c_associated_c_ptr, c_associated_c_funptr
164

165
  type(__builtin_c_ptr), parameter, public :: __builtin_c_null_ptr = __builtin_c_ptr(0)
166
  type(__builtin_c_funptr), parameter, public :: &
167
    __builtin_c_null_funptr = __builtin_c_funptr(0)
168

169
  public :: __builtin_c_ptr_eq
170
  public :: __builtin_c_ptr_ne
171
  public :: __builtin_c_funloc
172

173
  contains
174

175
  elemental logical function __builtin_c_ptr_eq(x, y)
176
    type(__builtin_c_ptr), intent(in) :: x, y
177
    __builtin_c_ptr_eq = x%__address == y%__address
178
  end function
179

180
  elemental logical function __builtin_c_ptr_ne(x, y)
181
    type(__builtin_c_ptr), intent(in) :: x, y
182
    __builtin_c_ptr_ne = x%__address /= y%__address
183
  end function
184

185
  ! Semantics has some special-case code that allows c_funloc()
186
  ! to appear in a specification expression and exempts it
187
  ! from the requirement that "x" be a pure dummy procedure.
188
  pure function __builtin_c_funloc(x)
189
    type(__builtin_c_funptr) :: __builtin_c_funloc
190
    external :: x
191
    __builtin_c_funloc = __builtin_c_funptr(loc(x))
192
  end function
193

194
  pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2)
195
    type(__builtin_c_ptr), intent(in) :: c_ptr_1
196
    type(__builtin_c_ptr), intent(in), optional :: c_ptr_2
197
    if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then
198
      c_associated_c_ptr = .false.
199
    else if (present(c_ptr_2)) then
200
      c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address
201
    else
202
      c_associated_c_ptr = .true.
203
    end if
204
  end function c_associated_c_ptr
205

206
  pure logical function c_associated_c_funptr(c_ptr_1, c_ptr_2)
207
    type(__builtin_c_funptr), intent(in) :: c_ptr_1
208
    type(__builtin_c_funptr), intent(in), optional :: c_ptr_2
209
    if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then
210
      c_associated_c_funptr = .false.
211
    else if (present(c_ptr_2)) then
212
      c_associated_c_funptr = c_ptr_1%__address == c_ptr_2%__address
213
    else
214
      c_associated_c_funptr = .true.
215
    end if
216
  end function c_associated_c_funptr
217

218
end module
219