flang/module/__fortran_builtins.f90

   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   type, public, bind(c) :: __builtin_c_devptr
 107     type(__builtin_c_ptr) :: cptr
 108   end type
 109
 110   intrinsic :: __builtin_fma
 111   intrinsic :: __builtin_ieee_int
 112   intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
 113     __builtin_ieee_is_normal
 114   intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
 115     __builtin_ieee_next_up
 116   intrinsic :: scale ! for ieee_scalb
 117   intrinsic :: __builtin_ieee_real
 118   intrinsic :: __builtin_ieee_selected_real_kind
 119   intrinsic :: __builtin_ieee_support_datatype, &
 120     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
 121     __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
 122     __builtin_ieee_support_inf, __builtin_ieee_support_io, &
 123     __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
 124     __builtin_ieee_support_sqrt, &
 125     __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
 126     __builtin_ieee_support_underflow_control
 127   public :: __builtin_fma
 128   public :: __builtin_ieee_int
 129   public :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
 130     __builtin_ieee_is_normal
 131   public :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
 132     __builtin_ieee_next_up
 133   public :: __builtin_ieee_real
 134   public :: scale ! for ieee_scalb
 135   public :: __builtin_ieee_selected_real_kind
 136   public :: __builtin_ieee_support_datatype, &
 137     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &
 138     __builtin_ieee_support_flag, __builtin_ieee_support_halting, &
 139     __builtin_ieee_support_inf, __builtin_ieee_support_io, &
 140     __builtin_ieee_support_nan, __builtin_ieee_support_rounding, &
 141     __builtin_ieee_support_sqrt, &
 142     __builtin_ieee_support_standard, __builtin_ieee_support_subnormal, &
 143     __builtin_ieee_support_underflow_control
 144
 145   type :: __force_derived_type_instantiations
 146     type(__builtin_c_ptr) :: c_ptr
 147     type(__builtin_c_funptr) :: c_funptr
 148     type(__builtin_event_type) :: event_type
 149     type(__builtin_lock_type) :: lock_type
 150     type(__builtin_team_type) :: team_type
 151   end type
 152
 153   intrinsic :: __builtin_compiler_options, __builtin_compiler_version
 154   public :: __builtin_compiler_options, __builtin_compiler_version
 155
 156   interface operator(==)
 157     module procedure __builtin_c_ptr_eq
 158   end interface
 159   public :: operator(==)
 160
 161   interface operator(/=)
 162     module procedure __builtin_c_ptr_ne
 163   end interface
 164   public :: operator(/=)
 165
 166   interface __builtin_c_associated
 167     module procedure c_associated_c_ptr
 168     module procedure c_associated_c_funptr
 169   end interface
 170   public :: __builtin_c_associated
 171 !  private :: c_associated_c_ptr, c_associated_c_funptr
 172
 173   type(__builtin_c_ptr), parameter, public :: __builtin_c_null_ptr = __builtin_c_ptr(0)
 174   type(__builtin_c_funptr), parameter, public :: &
 175     __builtin_c_null_funptr = __builtin_c_funptr(0)
 176
 177   public :: __builtin_c_ptr_eq
 178   public :: __builtin_c_ptr_ne
 179   public :: __builtin_c_funloc
 180
 181   contains
 182
 183   elemental logical function __builtin_c_ptr_eq(x, y)
 184     type(__builtin_c_ptr), intent(in) :: x, y
 185     __builtin_c_ptr_eq = x%__address == y%__address
 186   end function
 187
 188   elemental logical function __builtin_c_ptr_ne(x, y)
 189     type(__builtin_c_ptr), intent(in) :: x, y
 190     __builtin_c_ptr_ne = x%__address /= y%__address
 191   end function
 192
 193   ! Semantics has some special-case code that allows c_funloc()
 194   ! to appear in a specification expression and exempts it
 195   ! from the requirement that "x" be a pure dummy procedure.
 196   pure function __builtin_c_funloc(x)
 197     type(__builtin_c_funptr) :: __builtin_c_funloc
 198     external :: x
 199     __builtin_c_funloc = __builtin_c_funptr(loc(x))
 200   end function
 201
 202   pure logical function c_associated_c_ptr(c_ptr_1, c_ptr_2)
 203     type(__builtin_c_ptr), intent(in) :: c_ptr_1
 204     type(__builtin_c_ptr), intent(in), optional :: c_ptr_2
 205     if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then
 206       c_associated_c_ptr = .false.
 207     else if (present(c_ptr_2)) then
 208       c_associated_c_ptr = c_ptr_1%__address == c_ptr_2%__address
 209     else
 210       c_associated_c_ptr = .true.
 211     end if
 212   end function c_associated_c_ptr
 213
 214   pure logical function c_associated_c_funptr(c_ptr_1, c_ptr_2)
 215     type(__builtin_c_funptr), intent(in) :: c_ptr_1
 216     type(__builtin_c_funptr), intent(in), optional :: c_ptr_2
 217     if (c_ptr_1%__address == __builtin_c_null_ptr%__address) then
 218       c_associated_c_funptr = .false.
 219     else if (present(c_ptr_2)) then
 220       c_associated_c_funptr = c_ptr_1%__address == c_ptr_2%__address
 221     else
 222       c_associated_c_funptr = .true.
 223     end if
 224   end function c_associated_c_funptr
 225
 226 end module