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. 15module __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_devloc 26 public :: __builtin_c_devloc 27 28 intrinsic :: __builtin_c_f_pointer 29 public :: __builtin_c_f_pointer 30 31 intrinsic :: sizeof ! extension 32 public :: sizeof 33 34 intrinsic :: selected_int_kind 35 integer, parameter :: int64 = selected_int_kind(18) 36 37 type, bind(c), public :: __builtin_c_ptr 38 integer(kind=int64), private :: __address 39 end type 40 41 type, bind(c), public :: __builtin_c_funptr 42 integer(kind=int64), private :: __address 43 end type 44 45 type, public :: __builtin_event_type 46 integer(kind=int64), private :: __count = -1 47 end type 48 49 type, public :: __builtin_notify_type 50 integer(kind=int64), private :: __count = -1 51 end type 52 53 type, public :: __builtin_lock_type 54 integer(kind=int64), private :: __count = -1 55 end type 56 57 type, public :: __builtin_ieee_flag_type 58 integer(kind=1), private :: flag = 0 59 end type 60 61 type(__builtin_ieee_flag_type), parameter, public :: & 62 __builtin_ieee_invalid = & 63 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), & 64 __builtin_ieee_overflow = & 65 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), & 66 __builtin_ieee_divide_by_zero = & 67 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), & 68 __builtin_ieee_underflow = & 69 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), & 70 __builtin_ieee_inexact = & 71 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), & 72 __builtin_ieee_denorm = & ! extension 73 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM) 74 75 type, public :: __builtin_ieee_round_type 76 integer(kind=1), private :: mode = 0 77 end type 78 79 type(__builtin_ieee_round_type), parameter, public :: & 80 __builtin_ieee_to_zero = & 81 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), & 82 __builtin_ieee_nearest = & 83 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), & 84 __builtin_ieee_up = & 85 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), & 86 __builtin_ieee_down = & 87 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), & 88 __builtin_ieee_away = & 89 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), & 90 __builtin_ieee_other = & 91 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER) 92 93 type, public :: __builtin_team_type 94 integer(kind=int64), private :: __id = -1 95 end type 96 97 integer, parameter, public :: __builtin_atomic_int_kind = selected_int_kind(18) 98 integer, parameter, public :: & 99 __builtin_atomic_logical_kind = __builtin_atomic_int_kind 100 101 type, public :: __builtin_dim3 102 integer :: x=1, y=1, z=1 103 end type 104 type(__builtin_dim3), public :: & 105 __builtin_threadIdx, __builtin_blockDim, __builtin_blockIdx, & 106 __builtin_gridDim 107 integer, parameter, public :: __builtin_warpsize = 32 108 109 type, public, bind(c) :: __builtin_c_devptr 110 type(__builtin_c_ptr) :: cptr 111 end type 112 113 intrinsic :: __builtin_fma 114 intrinsic :: __builtin_ieee_int 115 intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, & 116 __builtin_ieee_is_normal 117 intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, & 118 __builtin_ieee_next_up 119 intrinsic :: scale ! for ieee_scalb 120 intrinsic :: __builtin_ieee_real 121 intrinsic :: __builtin_ieee_selected_real_kind 122 intrinsic :: __builtin_ieee_support_datatype, & 123 __builtin_ieee_support_denormal, __builtin_ieee_support_divide, & 124 __builtin_ieee_support_flag, __builtin_ieee_support_halting, & 125 __builtin_ieee_support_inf, __builtin_ieee_support_io, & 126 __builtin_ieee_support_nan, __builtin_ieee_support_rounding, & 127 __builtin_ieee_support_sqrt, & 128 __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, & 129 __builtin_ieee_support_underflow_control 130 public :: __builtin_fma 131 public :: __builtin_ieee_int 132 public :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, & 133 __builtin_ieee_is_normal 134 public :: __builtin_ieee_next_after, __builtin_ieee_next_down, & 135 __builtin_ieee_next_up 136 public :: __builtin_ieee_real 137 public :: scale ! for ieee_scalb 138 public :: __builtin_ieee_selected_real_kind 139 public :: __builtin_ieee_support_datatype, & 140 __builtin_ieee_support_denormal, __builtin_ieee_support_divide, & 141 __builtin_ieee_support_flag, __builtin_ieee_support_halting, & 142 __builtin_ieee_support_inf, __builtin_ieee_support_io, & 143 __builtin_ieee_support_nan, __builtin_ieee_support_rounding, & 144 __builtin_ieee_support_sqrt, & 145 __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, & 146 __builtin_ieee_support_underflow_control 147 148 type :: __force_derived_type_instantiations 149 type(__builtin_c_ptr) :: c_ptr 150 type(__builtin_c_devptr) :: c_devptr 151 type(__builtin_c_funptr) :: c_funptr 152 type(__builtin_event_type) :: event_type 153 type(__builtin_lock_type) :: lock_type 154 type(__builtin_team_type) :: team_type 155 end type 156 157 intrinsic :: __builtin_compiler_options, __builtin_compiler_version 158 public :: __builtin_compiler_options, __builtin_compiler_version 159 160 interface operator(==) 161 module procedure __builtin_c_ptr_eq 162 end interface 163 public :: operator(==) 164 165 interface operator(/=) 166 module procedure __builtin_c_ptr_ne 167 end interface 168 public :: operator(/=) 169 170 interface __builtin_c_associated 171 module procedure c_associated_c_ptr 172 module procedure c_associated_c_funptr 173 end interface 174 public :: __builtin_c_associated 175! private :: c_associated_c_ptr, c_associated_c_funptr 176 177 type(__builtin_c_ptr), parameter, public :: __builtin_c_null_ptr = __builtin_c_ptr(0) 178 type(__builtin_c_funptr), parameter, public :: & 179 __builtin_c_null_funptr = __builtin_c_funptr(0) 180 181 public :: __builtin_c_ptr_eq 182 public :: __builtin_c_ptr_ne 183 public :: __builtin_c_funloc 184 185 contains 186 187 elemental logical function __builtin_c_ptr_eq(x, y) 188 type(__builtin_c_ptr), intent(in) :: x, y 189 __builtin_c_ptr_eq = x%__address == y%__address 190 end function 191 192 elemental logical function __builtin_c_ptr_ne(x, y) 193 type(__builtin_c_ptr), intent(in) :: x, y 194 __builtin_c_ptr_ne = x%__address /= y%__address 195 end function 196 197 ! Semantics has some special-case code that allows c_funloc() 198 ! to appear in a specification expression and exempts it 199 ! from the requirement that "x" be a pure dummy procedure. 200 pure function __builtin_c_funloc(x) 201 type(__builtin_c_funptr) :: __builtin_c_funloc 202 external :: x 203 __builtin_c_funloc = __builtin_c_funptr(loc(x)) 204 end function 205 206 pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2) 207 type(__builtin_c_ptr), intent(in) :: c_ptr_1 208 type(__builtin_c_ptr), intent(in), optional :: c_ptr_2 209 if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then 210 c_associated_c_ptr = .false. 211 else if (present(c_ptr_2)) then 212 c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address 213 else 214 c_associated_c_ptr = .true. 215 end if 216 end function c_associated_c_ptr 217 218 pure logical function c_associated_c_funptr(c_ptr_1, c_ptr_2) 219 type(__builtin_c_funptr), intent(in) :: c_ptr_1 220 type(__builtin_c_funptr), intent(in), optional :: c_ptr_2 221 if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then 222 c_associated_c_funptr = .false. 223 else if (present(c_ptr_2)) then 224 c_associated_c_funptr = c_ptr_1%__address == c_ptr_2%__address 225 else 226 c_associated_c_funptr = .true. 227 end if 228 end function c_associated_c_funptr 229 230end module 231