forked from llvm/llvm-project
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy path__fortran_builtins.f90
More file actions
230 lines (194 loc) · 8.06 KB
/
__fortran_builtins.f90
File metadata and controls
230 lines (194 loc) · 8.06 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
!===-- module/__fortran_builtins.f90 ---------------------------------------===!
!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!===------------------------------------------------------------------------===!
#include '../include/flang/Runtime/magic-numbers.h'
! These naming shenanigans prevent names from Fortran intrinsic modules
! from being usable on INTRINSIC statements, and force the program
! to USE the standard intrinsic modules in order to access the
! standard names of the procedures.
module __fortran_builtins
implicit none
! Set PRIVATE by default to explicitly only export what is meant
! to be exported by this MODULE.
private
intrinsic :: __builtin_c_loc
public :: __builtin_c_loc
intrinsic :: __builtin_c_devloc
public :: __builtin_c_devloc
intrinsic :: __builtin_c_f_pointer
public :: __builtin_c_f_pointer
intrinsic :: sizeof ! extension
public :: sizeof
intrinsic :: selected_int_kind
integer, parameter :: int64 = selected_int_kind(18)
type, bind(c), public :: __builtin_c_ptr
integer(kind=int64), private :: __address
end type
type, bind(c), public :: __builtin_c_funptr
integer(kind=int64), private :: __address
end type
type, public :: __builtin_event_type
integer(kind=int64), private :: __count = -1
end type
type, public :: __builtin_notify_type
integer(kind=int64), private :: __count = -1
end type
type, public :: __builtin_lock_type
integer(kind=int64), private :: __count = -1
end type
type, public :: __builtin_ieee_flag_type
integer(kind=1), private :: flag = 0
end type
type(__builtin_ieee_flag_type), parameter, public :: &
__builtin_ieee_invalid = &
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), &
__builtin_ieee_overflow = &
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), &
__builtin_ieee_divide_by_zero = &
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), &
__builtin_ieee_underflow = &
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), &
__builtin_ieee_inexact = &
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), &
__builtin_ieee_denorm = & ! extension
__builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM)
type, public :: __builtin_ieee_round_type
integer(kind=1), private :: mode = 0
end type
type(__builtin_ieee_round_type), parameter, public :: &
__builtin_ieee_to_zero = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), &
__builtin_ieee_nearest = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), &
__builtin_ieee_up = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), &
__builtin_ieee_down = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), &
__builtin_ieee_away = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), &
__builtin_ieee_other = &
__builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER)
type, public :: __builtin_team_type
integer(kind=int64), private :: __id = -1
end type
integer, parameter, public :: __builtin_atomic_int_kind = selected_int_kind(18)
integer, parameter, public :: &
__builtin_atomic_logical_kind = __builtin_atomic_int_kind
type, public :: __builtin_dim3
integer :: x=1, y=1, z=1
end type
type(__builtin_dim3), public :: &
__builtin_threadIdx, __builtin_blockDim, __builtin_blockIdx, &
__builtin_gridDim
integer, parameter, public :: __builtin_warpsize = 32
type, public, bind(c) :: __builtin_c_devptr
type(__builtin_c_ptr) :: cptr
end type
intrinsic :: __builtin_fma
intrinsic :: __builtin_ieee_int
intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
__builtin_ieee_is_normal
intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
__builtin_ieee_next_up
intrinsic :: scale ! for ieee_scalb
intrinsic :: __builtin_ieee_real
intrinsic :: __builtin_ieee_selected_real_kind
intrinsic :: __builtin_ieee_support_datatype, &
__builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
__builtin_ieee_support_flag, __builtin_ieee_support_halting, &
__builtin_ieee_support_inf, __builtin_ieee_support_io, &
__builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
__builtin_ieee_support_sqrt, &
__builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
__builtin_ieee_support_underflow_control
public :: __builtin_fma
public :: __builtin_ieee_int
public :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
__builtin_ieee_is_normal
public :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
__builtin_ieee_next_up
public :: __builtin_ieee_real
public :: scale ! for ieee_scalb
public :: __builtin_ieee_selected_real_kind
public :: __builtin_ieee_support_datatype, &
__builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
__builtin_ieee_support_flag, __builtin_ieee_support_halting, &
__builtin_ieee_support_inf, __builtin_ieee_support_io, &
__builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
__builtin_ieee_support_sqrt, &
__builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
__builtin_ieee_support_underflow_control
type :: __force_derived_type_instantiations
type(__builtin_c_ptr) :: c_ptr
type(__builtin_c_devptr) :: c_devptr
type(__builtin_c_funptr) :: c_funptr
type(__builtin_event_type) :: event_type
type(__builtin_lock_type) :: lock_type
type(__builtin_team_type) :: team_type
end type
intrinsic :: __builtin_compiler_options, __builtin_compiler_version
public :: __builtin_compiler_options, __builtin_compiler_version
interface operator(==)
module procedure __builtin_c_ptr_eq
end interface
public :: operator(==)
interface operator(/=)
module procedure __builtin_c_ptr_ne
end interface
public :: operator(/=)
interface __builtin_c_associated
module procedure c_associated_c_ptr
module procedure c_associated_c_funptr
end interface
public :: __builtin_c_associated
! private :: c_associated_c_ptr, c_associated_c_funptr
type(__builtin_c_ptr), parameter, public :: __builtin_c_null_ptr = __builtin_c_ptr(0)
type(__builtin_c_funptr), parameter, public :: &
__builtin_c_null_funptr = __builtin_c_funptr(0)
public :: __builtin_c_ptr_eq
public :: __builtin_c_ptr_ne
public :: __builtin_c_funloc
contains
elemental logical function __builtin_c_ptr_eq(x, y)
type(__builtin_c_ptr), intent(in) :: x, y
__builtin_c_ptr_eq = x%__address == y%__address
end function
elemental logical function __builtin_c_ptr_ne(x, y)
type(__builtin_c_ptr), intent(in) :: x, y
__builtin_c_ptr_ne = x%__address /= y%__address
end function
! Semantics has some special-case code that allows c_funloc()
! to appear in a specification expression and exempts it
! from the requirement that "x" be a pure dummy procedure.
pure 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_ptr_1, c_ptr_2)
type(__builtin_c_funptr), intent(in) :: c_ptr_1
type(__builtin_c_funptr), intent(in), optional :: c_ptr_2
if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then
c_associated_c_funptr = .false.
else if (present(c_ptr_2)) then
c_associated_c_funptr = c_ptr_1%__address == c_ptr_2%__address
else
c_associated_c_funptr = .true.
end if
end function c_associated_c_funptr
end module