gcc/ada/libgnat/s-scaval.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT RUN-TIME COMPONENTS                        --
   4 --                                                                          --
   5 --                  S Y S T E M . S C A L A R _ V A L U E S                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2003-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Unchecked_Conversion;
  33
  34 package body System.Scalar_Values is
  35
  36    use Interfaces;
  37
  38    ----------------
  39    -- Initialize --
  40    ----------------
  41
  42    procedure Initialize (Mode1 : Character; Mode2 : Character) is
  43       C1 : Character := Mode1;
  44       C2 : Character := Mode2;
  45
  46       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
  47       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
  48
  49       subtype String2 is String (1 .. 2);
  50       type String2_Ptr is access all String2;
  51
  52       Env_Value_Ptr    : aliased String2_Ptr;
  53       Env_Value_Length : aliased Integer;
  54
  55       EV_Val : aliased constant String :=
  56                  "GNAT_INIT_SCALARS" & ASCII.NUL;
  57
  58       B : Byte1;
  59
  60       EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
  61       --  Set True if we are on an x86 with 96-bit floats for extended
  62
  63       type ByteLF is array (0 .. 7) of Byte1;
  64
  65       for ByteLF'Component_Size use 8;
  66
  67       --  Type used to hold Long_Float values on all targets. On most targets
  68       --  the type is 8 bytes, and type Byte8 is used for values that are then
  69       --  converted to ByteLF.
  70
  71       function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
  72
  73       type ByteLLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
  74
  75       for ByteLLF'Component_Size use 8;
  76
  77       --  Type used to initialize Long_Long_Float values used on x86 and
  78       --  any other target with the same 80-bit floating-point values that
  79       --  GCC always stores in 96-bits. Note that we are assuming Intel
  80       --  format little-endian addressing for this type. On non-Intel
  81       --  architectures, this is the same length as Byte8 and holds
  82       --  a Long_Float value.
  83
  84       --  The following variables are used to initialize the float values
  85       --  by overlay. We can't assign directly to the float values, since
  86       --  we may be assigning signalling Nan's that will cause a trap if
  87       --  loaded into a floating-point register.
  88
  89       IV_Isf : aliased Byte4;     -- Initialize short float
  90       IV_Ifl : aliased Byte4;     -- Initialize float
  91       IV_Ilf : aliased ByteLF;    -- Initialize long float
  92       IV_Ill : aliased ByteLLF;   -- Initialize long long float
  93
  94       for IV_Isf'Address use IS_Isf'Address;
  95       for IV_Ifl'Address use IS_Ifl'Address;
  96       for IV_Ilf'Address use IS_Ilf'Address;
  97       for IV_Ill'Address use IS_Ill'Address;
  98
  99       --  The following pragmas are used to suppress initialization
 100
 101       pragma Import (Ada, IV_Isf);
 102       pragma Import (Ada, IV_Ifl);
 103       pragma Import (Ada, IV_Ilf);
 104       pragma Import (Ada, IV_Ill);
 105
 106    begin
 107       --  Acquire environment variable value if necessary
 108
 109       if C1 = 'E' and then C2 = 'V' then
 110          Get_Env_Value_Ptr
 111            (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 112
 113          --  Ignore if length is not 2
 114
 115          if Env_Value_Length /= 2 then
 116             C1 := 'I';
 117             C2 := 'N';
 118
 119          --  Length is 2, see if it is a valid value
 120
 121          else
 122             --  Acquire two characters and fold to upper case
 123
 124             C1 := Env_Value_Ptr (1);
 125             C2 := Env_Value_Ptr (2);
 126
 127             if C1 in 'a' .. 'z' then
 128                C1 := Character'Val (Character'Pos (C1) - 32);
 129             end if;
 130
 131             if C2 in 'a' .. 'z' then
 132                C2 := Character'Val (Character'Pos (C2) - 32);
 133             end if;
 134
 135             --  IN/LO/HI are ok values
 136
 137             if (C1 = 'I' and then C2 = 'N')
 138                   or else
 139                (C1 = 'L' and then C2 = 'O')
 140                   or else
 141                (C1 = 'H' and then C2 = 'I')
 142             then
 143                null;
 144
 145             --  Try for valid hex digits
 146
 147             elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
 148                      or else
 149                   (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
 150             then
 151                null;
 152
 153             --  Otherwise environment value is bad, ignore and use IN (invalid)
 154
 155             else
 156                C1 := 'I';
 157                C2 := 'N';
 158             end if;
 159          end if;
 160       end if;
 161
 162       --  IN (invalid value)
 163
 164       if C1 = 'I' and then C2 = 'N' then
 165          IS_Is1 := 16#80#;
 166          IS_Is2 := 16#8000#;
 167          IS_Is4 := 16#8000_0000#;
 168          IS_Is8 := 16#8000_0000_0000_0000#;
 169
 170          IS_Iu1 := 16#FF#;
 171          IS_Iu2 := 16#FFFF#;
 172          IS_Iu4 := 16#FFFF_FFFF#;
 173          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 174
 175          IS_Iz1 := 16#00#;
 176          IS_Iz2 := 16#0000#;
 177          IS_Iz4 := 16#0000_0000#;
 178          IS_Iz8 := 16#0000_0000_0000_0000#;
 179
 180          IV_Isf := IS_Iu4;
 181          IV_Ifl := IS_Iu4;
 182          IV_Ilf := To_ByteLF (IS_Iu8);
 183
 184          if EFloat then
 185             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
 186          end if;
 187
 188       --  LO (Low values)
 189
 190       elsif C1 = 'L' and then C2 = 'O' then
 191          IS_Is1 := 16#80#;
 192          IS_Is2 := 16#8000#;
 193          IS_Is4 := 16#8000_0000#;
 194          IS_Is8 := 16#8000_0000_0000_0000#;
 195
 196          IS_Iu1 := 16#00#;
 197          IS_Iu2 := 16#0000#;
 198          IS_Iu4 := 16#0000_0000#;
 199          IS_Iu8 := 16#0000_0000_0000_0000#;
 200
 201          IS_Iz1 := 16#00#;
 202          IS_Iz2 := 16#0000#;
 203          IS_Iz4 := 16#0000_0000#;
 204          IS_Iz8 := 16#0000_0000_0000_0000#;
 205
 206          IV_Isf := 16#FF80_0000#;
 207          IV_Ifl := 16#FF80_0000#;
 208          IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
 209
 210          if EFloat then
 211             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
 212          end if;
 213
 214       --  HI (High values)
 215
 216       elsif C1 = 'H' and then C2 = 'I' then
 217          IS_Is1 := 16#7F#;
 218          IS_Is2 := 16#7FFF#;
 219          IS_Is4 := 16#7FFF_FFFF#;
 220          IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
 221
 222          IS_Iu1 := 16#FF#;
 223          IS_Iu2 := 16#FFFF#;
 224          IS_Iu4 := 16#FFFF_FFFF#;
 225          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 226
 227          IS_Iz1 := 16#FF#;
 228          IS_Iz2 := 16#FFFF#;
 229          IS_Iz4 := 16#FFFF_FFFF#;
 230          IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
 231
 232          IV_Isf := 16#7F80_0000#;
 233          IV_Ifl := 16#7F80_0000#;
 234          IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
 235
 236          if EFloat then
 237             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
 238          end if;
 239
 240       --  -Shh (hex byte)
 241
 242       else
 243          --  Convert the two hex digits (we know they are valid here)
 244
 245          B := 16 * (Character'Pos (C1)
 246                      - (if C1 in '0' .. '9'
 247                         then Character'Pos ('0')
 248                         else Character'Pos ('A') - 10))
 249                  + (Character'Pos (C2)
 250                      - (if C2 in '0' .. '9'
 251                         then Character'Pos ('0')
 252                         else Character'Pos ('A') - 10));
 253
 254          --  Initialize data values from the hex value
 255
 256          IS_Is1 := B;
 257          IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
 258          IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
 259          IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
 260
 261          IS_Iu1 := IS_Is1;
 262          IS_Iu2 := IS_Is2;
 263          IS_Iu4 := IS_Is4;
 264          IS_Iu8 := IS_Is8;
 265
 266          IS_Iz1 := IS_Is1;
 267          IS_Iz2 := IS_Is2;
 268          IS_Iz4 := IS_Is4;
 269          IS_Iz8 := IS_Is8;
 270
 271          IV_Isf := IS_Is4;
 272          IV_Ifl := IS_Is4;
 273
 274          IV_Ilf := To_ByteLF (IS_Is8);
 275
 276          if EFloat then
 277             IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
 278          end if;
 279       end if;
 280
 281       --  If no separate Long_Long_Float, then use Long_Float value as
 282       --  Long_Long_Float initial value.
 283
 284       if not EFloat then
 285          declare
 286             pragma Warnings (Off); -- because sizes don't match
 287             function To_ByteLLF is
 288               new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
 289             pragma Warnings (On);
 290          begin
 291             IV_Ill := To_ByteLLF (IV_Ilf);
 292          end;
 293       end if;
 294    end Initialize;
 295
 296 end System.Scalar_Values;