gcc/ada/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-2009, 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    ----------------
  37    -- Initialize --
  38    ----------------
  39
  40    procedure Initialize (Mode1 : Character; Mode2 : Character) is
  41       C1 : Character := Mode1;
  42       C2 : Character := Mode2;
  43
  44       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
  45       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
  46
  47       subtype String2 is String (1 .. 2);
  48       type String2_Ptr is access all String2;
  49
  50       Env_Value_Ptr    : aliased String2_Ptr;
  51       Env_Value_Length : aliased Integer;
  52
  53       EV_Val : aliased constant String :=
  54                  "GNAT_INIT_SCALARS" & ASCII.NUL;
  55
  56       B : Byte1;
  57
  58       EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
  59       --  Set True if we are on an x86 with 96-bit floats for extended
  60
  61       AFloat : constant Boolean :=
  62                  Long_Float'Size = 48 and then Long_Long_Float'Size = 48;
  63       --  Set True if we are on an AAMP with 48-bit extended floating point
  64
  65       type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
  66
  67       for ByteLF'Component_Size use 8;
  68
  69       --  Type used to hold Long_Float values on all targets and to initialize
  70       --  48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes.
  71       --  On other targets the type is 8 bytes, and type Byte8 is used for
  72       --  values that are then converted to ByteLF.
  73
  74       pragma Warnings (Off); --  why ???
  75       function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
  76       pragma Warnings (On);
  77
  78       type ByteLLF is
  79         array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
  80           of Byte1;
  81
  82       for ByteLLF'Component_Size use 8;
  83
  84       --  Type used to initialize Long_Long_Float values used on x86 and
  85       --  any other target with the same 80-bit floating-point values that
  86       --  GCC always stores in 96-bits. Note that we are assuming Intel
  87       --  format little-endian addressing for this type. On non-Intel
  88       --  architectures, this is the same length as Byte8 and holds
  89       --  a Long_Float value.
  90
  91       --  The following variables are used to initialize the float values
  92       --  by overlay. We can't assign directly to the float values, since
  93       --  we may be assigning signalling Nan's that will cause a trap if
  94       --  loaded into a floating-point register.
  95
  96       IV_Isf : aliased Byte4;     -- Initialize short float
  97       IV_Ifl : aliased Byte4;     -- Initialize float
  98       IV_Ilf : aliased ByteLF;    -- Initialize long float
  99       IV_Ill : aliased ByteLLF;   -- Initialize long long float
 100
 101       for IV_Isf'Address use IS_Isf'Address;
 102       for IV_Ifl'Address use IS_Ifl'Address;
 103       for IV_Ilf'Address use IS_Ilf'Address;
 104       for IV_Ill'Address use IS_Ill'Address;
 105
 106       --  The following pragmas are used to suppress initialization
 107
 108       pragma Import (Ada, IV_Isf);
 109       pragma Import (Ada, IV_Ifl);
 110       pragma Import (Ada, IV_Ilf);
 111       pragma Import (Ada, IV_Ill);
 112
 113    begin
 114       --  Acquire environment variable value if necessary
 115
 116       if C1 = 'E' and then C2 = 'V' then
 117          Get_Env_Value_Ptr
 118            (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 119
 120          --  Ignore if length is not 2
 121
 122          if Env_Value_Length /= 2 then
 123             C1 := 'I';
 124             C2 := 'N';
 125
 126          --  Length is 2, see if it is a valid value
 127
 128          else
 129             --  Acquire two characters and fold to upper case
 130
 131             C1 := Env_Value_Ptr (1);
 132             C2 := Env_Value_Ptr (2);
 133
 134             if C1 in 'a' .. 'z' then
 135                C1 := Character'Val (Character'Pos (C1) - 32);
 136             end if;
 137
 138             if C2 in 'a' .. 'z' then
 139                C2 := Character'Val (Character'Pos (C2) - 32);
 140             end if;
 141
 142             --  IN/LO/HI are ok values
 143
 144             if (C1 = 'I' and then C2 = 'N')
 145                   or else
 146                (C1 = 'L' and then C2 = 'O')
 147                   or else
 148                (C1 = 'H' and then C2 = 'I')
 149             then
 150                null;
 151
 152             --  Try for valid hex digits
 153
 154             elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
 155                      or else
 156                   (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
 157             then
 158                null;
 159
 160             --  Otherwise environment value is bad, ignore and use IN (invalid)
 161
 162             else
 163                C1 := 'I';
 164                C2 := 'N';
 165             end if;
 166          end if;
 167       end if;
 168
 169       --  IN (invalid value)
 170
 171       if C1 = 'I' and then C2 = 'N' then
 172          IS_Is1 := 16#80#;
 173          IS_Is2 := 16#8000#;
 174          IS_Is4 := 16#8000_0000#;
 175          IS_Is8 := 16#8000_0000_0000_0000#;
 176
 177          IS_Iu1 := 16#FF#;
 178          IS_Iu2 := 16#FFFF#;
 179          IS_Iu4 := 16#FFFF_FFFF#;
 180          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 181
 182          IS_Iz1 := 16#00#;
 183          IS_Iz2 := 16#0000#;
 184          IS_Iz4 := 16#0000_0000#;
 185          IS_Iz8 := 16#0000_0000_0000_0000#;
 186
 187          if AFloat then
 188             IV_Isf := 16#FFFF_FF00#;
 189             IV_Ifl := 16#FFFF_FF00#;
 190             IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#);
 191
 192          else
 193             IV_Isf := IS_Iu4;
 194             IV_Ifl := IS_Iu4;
 195             IV_Ilf := To_ByteLF (IS_Iu8);
 196          end if;
 197
 198          if EFloat then
 199             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
 200          end if;
 201
 202       --  LO (Low values)
 203
 204       elsif C1 = 'L' and then C2 = 'O' then
 205          IS_Is1 := 16#80#;
 206          IS_Is2 := 16#8000#;
 207          IS_Is4 := 16#8000_0000#;
 208          IS_Is8 := 16#8000_0000_0000_0000#;
 209
 210          IS_Iu1 := 16#00#;
 211          IS_Iu2 := 16#0000#;
 212          IS_Iu4 := 16#0000_0000#;
 213          IS_Iu8 := 16#0000_0000_0000_0000#;
 214
 215          IS_Iz1 := 16#00#;
 216          IS_Iz2 := 16#0000#;
 217          IS_Iz4 := 16#0000_0000#;
 218          IS_Iz8 := 16#0000_0000_0000_0000#;
 219
 220          if AFloat then
 221             IV_Isf := 16#0000_0001#;
 222             IV_Ifl := 16#0000_0001#;
 223             IV_Ilf := (1, 0, 0, 0, 0, 0);
 224
 225          else
 226             IV_Isf := 16#FF80_0000#;
 227             IV_Ifl := 16#FF80_0000#;
 228             IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
 229          end if;
 230
 231          if EFloat then
 232             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
 233          end if;
 234
 235       --  HI (High values)
 236
 237       elsif C1 = 'H' and then C2 = 'I' then
 238          IS_Is1 := 16#7F#;
 239          IS_Is2 := 16#7FFF#;
 240          IS_Is4 := 16#7FFF_FFFF#;
 241          IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
 242
 243          IS_Iu1 := 16#FF#;
 244          IS_Iu2 := 16#FFFF#;
 245          IS_Iu4 := 16#FFFF_FFFF#;
 246          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 247
 248          IS_Iz1 := 16#FF#;
 249          IS_Iz2 := 16#FFFF#;
 250          IS_Iz4 := 16#FFFF_FFFF#;
 251          IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
 252
 253          if AFloat then
 254             IV_Isf := 16#7FFF_FFFF#;
 255             IV_Ifl := 16#7FFF_FFFF#;
 256             IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#);
 257
 258          else
 259             IV_Isf := 16#7F80_0000#;
 260             IV_Ifl := 16#7F80_0000#;
 261             IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
 262          end if;
 263
 264          if EFloat then
 265             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
 266          end if;
 267
 268       --  -Shh (hex byte)
 269
 270       else
 271          --  Convert the two hex digits (we know they are valid here)
 272
 273          B := 16 * (Character'Pos (C1)
 274                      - (if C1 in '0' .. '9'
 275                         then Character'Pos ('0')
 276                         else Character'Pos ('A') - 10))
 277                  + (Character'Pos (C2)
 278                      - (if C2 in '0' .. '9'
 279                         then Character'Pos ('0')
 280                         else Character'Pos ('A') - 10));
 281
 282          --  Initialize data values from the hex value
 283
 284          IS_Is1 := B;
 285          IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
 286          IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
 287          IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
 288
 289          IS_Iu1 := IS_Is1;
 290          IS_Iu2 := IS_Is2;
 291          IS_Iu4 := IS_Is4;
 292          IS_Iu8 := IS_Is8;
 293
 294          IS_Iz1 := IS_Is1;
 295          IS_Iz2 := IS_Is2;
 296          IS_Iz4 := IS_Is4;
 297          IS_Iz8 := IS_Is8;
 298
 299          IV_Isf := IS_Is4;
 300          IV_Ifl := IS_Is4;
 301
 302          if AFloat then
 303             IV_Ill := (B, B, B, B, B, B);
 304          else
 305             IV_Ilf := To_ByteLF (IS_Is8);
 306          end if;
 307
 308          if EFloat then
 309             IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
 310          end if;
 311       end if;
 312
 313       --  If no separate Long_Long_Float, then use Long_Float value as
 314       --  Long_Long_Float initial value.
 315
 316       if not EFloat then
 317          declare
 318             pragma Warnings (Off);  -- why???
 319             function To_ByteLLF is
 320               new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
 321             pragma Warnings (On);
 322          begin
 323             IV_Ill := To_ByteLLF (IV_Ilf);
 324          end;
 325       end if;
 326    end Initialize;
 327
 328 end System.Scalar_Values;