File : 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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;