234 lines · plain
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-exception6!7!===------------------------------------------------------------------------===!8 9#include '../include/flang/Runtime/magic-numbers.h'10 11! These naming shenanigans prevent names from Fortran intrinsic modules12! from being usable on INTRINSIC statements, and force the program13! to USE the standard intrinsic modules in order to access the14! standard names of the procedures.15module __fortran_builtins16 implicit none17 18 ! Set PRIVATE by default to explicitly only export what is meant19 ! to be exported by this MODULE.20 private21 22 intrinsic :: __builtin_c_loc23 public :: __builtin_c_loc24 25 intrinsic :: __builtin_c_devloc26 public :: __builtin_c_devloc27 28 intrinsic :: __builtin_c_f_pointer29 public :: __builtin_c_f_pointer30 31 intrinsic :: __builtin_show_descriptor32 public :: __builtin_show_descriptor33 34 intrinsic :: sizeof ! extension35 public :: sizeof36 37 intrinsic :: selected_int_kind38 integer, parameter :: int64 = selected_int_kind(18)39 40 type, bind(c), public :: __builtin_c_ptr41 integer(kind=int64), private :: __address42 end type43 44 type, bind(c), public :: __builtin_c_funptr45 integer(kind=int64), private :: __address46 end type47 48 type, public :: __builtin_event_type49 integer(kind=int64), private :: __count = -150 end type51 52 type, public :: __builtin_notify_type53 integer(kind=int64), private :: __count = -154 end type55 56 type, public :: __builtin_lock_type57 integer(kind=int64), private :: __count = -158 end type59 60 type, public :: __builtin_ieee_flag_type61 integer(kind=1), private :: flag = 062 end type63 64 type(__builtin_ieee_flag_type), parameter, public :: &65 __builtin_ieee_invalid = &66 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INVALID), &67 __builtin_ieee_overflow = &68 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_OVERFLOW), &69 __builtin_ieee_divide_by_zero = &70 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DIVIDE_BY_ZERO), &71 __builtin_ieee_underflow = &72 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_UNDERFLOW), &73 __builtin_ieee_inexact = &74 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_INEXACT), &75 __builtin_ieee_denorm = & ! extension76 __builtin_ieee_flag_type(_FORTRAN_RUNTIME_IEEE_DENORM)77 78 type, public :: __builtin_ieee_round_type79 integer(kind=1), private :: mode = 080 end type81 82 type(__builtin_ieee_round_type), parameter, public :: &83 __builtin_ieee_to_zero = &84 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_TO_ZERO), &85 __builtin_ieee_nearest = &86 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_NEAREST), &87 __builtin_ieee_up = &88 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_UP), &89 __builtin_ieee_down = &90 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_DOWN), &91 __builtin_ieee_away = &92 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_AWAY), &93 __builtin_ieee_other = &94 __builtin_ieee_round_type(_FORTRAN_RUNTIME_IEEE_OTHER)95 96 type, public :: __builtin_team_type97 integer(kind=int64), private :: __id = -198 end type99 100 integer, parameter, public :: __builtin_atomic_int_kind = selected_int_kind(18)101 integer, parameter, public :: &102 __builtin_atomic_logical_kind = __builtin_atomic_int_kind103 104 type, public :: __builtin_dim3105 integer :: x=1, y=1, z=1106 end type107 type(__builtin_dim3), public :: &108 __builtin_threadIdx, __builtin_blockDim, __builtin_blockIdx, &109 __builtin_gridDim110 integer, parameter, public :: __builtin_warpsize = 32111 112 type, public, bind(c) :: __builtin_c_devptr113 type(__builtin_c_ptr) :: cptr114 end type115 116 intrinsic :: __builtin_fma117 intrinsic :: __builtin_ieee_int118 intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &119 __builtin_ieee_is_normal120 intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &121 __builtin_ieee_next_up122 intrinsic :: scale ! for ieee_scalb123 intrinsic :: __builtin_ieee_real124 intrinsic :: __builtin_ieee_selected_real_kind125 intrinsic :: __builtin_ieee_support_datatype, &126 __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &127 __builtin_ieee_support_flag, __builtin_ieee_support_halting, &128 __builtin_ieee_support_inf, __builtin_ieee_support_io, &129 __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &130 __builtin_ieee_support_sqrt, &131 __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &132 __builtin_ieee_support_underflow_control133 public :: __builtin_fma134 public :: __builtin_ieee_int135 public :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &136 __builtin_ieee_is_normal137 public :: __builtin_ieee_next_after, __builtin_ieee_next_down, &138 __builtin_ieee_next_up139 public :: __builtin_ieee_real140 public :: scale ! for ieee_scalb141 public :: __builtin_ieee_selected_real_kind142 public :: __builtin_ieee_support_datatype, &143 __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &144 __builtin_ieee_support_flag, __builtin_ieee_support_halting, &145 __builtin_ieee_support_inf, __builtin_ieee_support_io, &146 __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &147 __builtin_ieee_support_sqrt, &148 __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &149 __builtin_ieee_support_underflow_control150 151 type :: __force_derived_type_instantiations152 type(__builtin_c_ptr) :: c_ptr153 type(__builtin_c_devptr) :: c_devptr154 type(__builtin_c_funptr) :: c_funptr155 type(__builtin_event_type) :: event_type156 type(__builtin_lock_type) :: lock_type157 type(__builtin_team_type) :: team_type158 end type159 160 intrinsic :: __builtin_compiler_options, __builtin_compiler_version161 public :: __builtin_compiler_options, __builtin_compiler_version162 163 interface operator(==)164 module procedure __builtin_c_ptr_eq165 end interface166 public :: operator(==)167 168 interface operator(/=)169 module procedure __builtin_c_ptr_ne170 end interface171 public :: operator(/=)172 173 interface __builtin_c_associated174 module procedure c_associated_c_ptr175 module procedure c_associated_c_funptr176 end interface177 public :: __builtin_c_associated178! private :: c_associated_c_ptr, c_associated_c_funptr179 180 type(__builtin_c_ptr), parameter, public :: __builtin_c_null_ptr = __builtin_c_ptr(0)181 type(__builtin_c_funptr), parameter, public :: &182 __builtin_c_null_funptr = __builtin_c_funptr(0)183 184 public :: __builtin_c_ptr_eq185 public :: __builtin_c_ptr_ne186 public :: __builtin_c_funloc187 188 contains189 190 elemental logical function __builtin_c_ptr_eq(x, y)191 type(__builtin_c_ptr), intent(in) :: x, y192 __builtin_c_ptr_eq = x%__address == y%__address193 end function194 195 elemental logical function __builtin_c_ptr_ne(x, y)196 type(__builtin_c_ptr), intent(in) :: x, y197 __builtin_c_ptr_ne = x%__address /= y%__address198 end function199 200 ! Semantics has some special-case code that allows c_funloc()201 ! to appear in a specification expression and exempts it202 ! from the requirement that "x" be a pure dummy procedure.203 pure function __builtin_c_funloc(x)204 type(__builtin_c_funptr) :: __builtin_c_funloc205 external :: x206 __builtin_c_funloc = __builtin_c_funptr(loc(x))207 end function208 209 pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2)210 type(__builtin_c_ptr), intent(in) :: c_ptr_1211 type(__builtin_c_ptr), intent(in), optional :: c_ptr_2212 if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then213 c_associated_c_ptr = .false.214 else if (present(c_ptr_2)) then215 c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address216 else217 c_associated_c_ptr = .true.218 end if219 end function c_associated_c_ptr220 221 pure logical function c_associated_c_funptr(c_ptr_1, c_ptr_2)222 type(__builtin_c_funptr), intent(in) :: c_ptr_1223 type(__builtin_c_funptr), intent(in), optional :: c_ptr_2224 if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then225 c_associated_c_funptr = .false.226 else if (present(c_ptr_2)) then227 c_associated_c_funptr = c_ptr_1%__address == c_ptr_2%__address228 else229 c_associated_c_funptr = .true.230 end if231 end function c_associated_c_funptr232 233end module234