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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Conversion;
  35
  36 package body System.Scalar_Values is
  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       AFloat : constant Boolean :=
  64                  Long_Float'Size = 48 and Long_Long_Float'Size = 48;
  65       --  Set True if we are on an AAMP with 48-bit extended floating point
  66
  67       type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
  68
  69       for ByteLF'Component_Size use 8;
  70
  71       --  Type used to hold Long_Float values on all targets and to initialize
  72       --  48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes.
  73       --  On other targets the type is 8 bytes, and type Byte8 is used for
  74       --  values that are then converted to ByteLF.
  75
  76       pragma Warnings (Off);
  77       function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
  78       pragma Warnings (On);
  79
  80       type ByteLLF is
  81         array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
  82           of Byte1;
  83
  84       for ByteLLF'Component_Size use 8;
  85
  86       --  Type used to initialize Long_Long_Float values used on x86 and
  87       --  any other target with the same 80-bit floating-point values that
  88       --  GCC always stores in 96-bits. Note that we are assuming Intel
  89       --  format little-endian addressing for this type. On non-Intel
  90       --  architectures, this is the same length as Byte8 and holds
  91       --  a Long_Float value.
  92
  93       --  The following variables are used to initialize the float values
  94       --  by overlay. We can't assign directly to the float values, since
  95       --  we may be assigning signalling Nan's that will cause a trap if
  96       --  loaded into a floating-point register.
  97
  98       IV_Isf : aliased Byte4;     -- Initialize short float
  99       IV_Ifl : aliased Byte4;     -- Initialize float
 100       IV_Ilf : aliased ByteLF;    -- Initialize long float
 101       IV_Ill : aliased ByteLLF;   -- Initialize long long float
 102
 103       for IV_Isf'Address use IS_Isf'Address;
 104       for IV_Ifl'Address use IS_Ifl'Address;
 105       for IV_Ilf'Address use IS_Ilf'Address;
 106       for IV_Ill'Address use IS_Ill'Address;
 107
 108       --  The following pragmas are used to suppress initialization
 109
 110       pragma Import (Ada, IV_Isf);
 111       pragma Import (Ada, IV_Ifl);
 112       pragma Import (Ada, IV_Ilf);
 113       pragma Import (Ada, IV_Ill);
 114
 115    begin
 116       --  Acquire environment variable value if necessary
 117
 118       if C1 = 'E' and then C2 = 'V' then
 119          Get_Env_Value_Ptr
 120            (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 121
 122          --  Ignore if length is not 2
 123
 124          if Env_Value_Length /= 2 then
 125             C1 := 'I';
 126             C2 := 'N';
 127
 128          --  Length is 2, see if it is a valid value
 129
 130          else
 131             --  Acquire two characters and fold to upper case
 132
 133             C1 := Env_Value_Ptr (1);
 134             C2 := Env_Value_Ptr (2);
 135
 136             if C1 in 'a' .. 'z' then
 137                C1 := Character'Val (Character'Pos (C1) - 32);
 138             end if;
 139
 140             if C2 in 'a' .. 'z' then
 141                C2 := Character'Val (Character'Pos (C2) - 32);
 142             end if;
 143
 144             --  IN/LO/HI are ok values
 145
 146             if (C1 = 'I' and then C2 = 'N')
 147                   or else
 148                (C1 = 'L' and then C2 = 'O')
 149                   or else
 150                (C1 = 'H' and then C2 = 'I')
 151             then
 152                null;
 153
 154             --  Try for valid hex digits
 155
 156             elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
 157                      or else
 158                   (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
 159             then
 160                null;
 161
 162             --  Otherwise environment value is bad, ignore and use IN (invalid)
 163
 164             else
 165                C1 := 'I';
 166                C2 := 'N';
 167             end if;
 168          end if;
 169       end if;
 170
 171       --  IN (invalid value)
 172
 173       if C1 = 'I' and then C2 = 'N' then
 174          IS_Is1 := 16#80#;
 175          IS_Is2 := 16#8000#;
 176          IS_Is4 := 16#8000_0000#;
 177          IS_Is8 := 16#8000_0000_0000_0000#;
 178
 179          IS_Iu1 := 16#FF#;
 180          IS_Iu2 := 16#FFFF#;
 181          IS_Iu4 := 16#FFFF_FFFF#;
 182          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 183
 184          IS_Iz1 := 16#00#;
 185          IS_Iz2 := 16#0000#;
 186          IS_Iz4 := 16#0000_0000#;
 187          IS_Iz8 := 16#0000_0000_0000_0000#;
 188
 189          if AFloat then
 190             IV_Isf := 16#FFFF_FF00#;
 191             IV_Ifl := 16#FFFF_FF00#;
 192             IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#);
 193
 194          else
 195             IV_Isf := IS_Iu4;
 196             IV_Ifl := IS_Iu4;
 197             IV_Ilf := To_ByteLF (IS_Iu8);
 198          end if;
 199
 200          if EFloat then
 201             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
 202          end if;
 203
 204       --  LO (Low values)
 205
 206       elsif C1 = 'L' and then C2 = 'O' then
 207          IS_Is1 := 16#80#;
 208          IS_Is2 := 16#8000#;
 209          IS_Is4 := 16#8000_0000#;
 210          IS_Is8 := 16#8000_0000_0000_0000#;
 211
 212          IS_Iu1 := 16#00#;
 213          IS_Iu2 := 16#0000#;
 214          IS_Iu4 := 16#0000_0000#;
 215          IS_Iu8 := 16#0000_0000_0000_0000#;
 216
 217          IS_Iz1 := 16#00#;
 218          IS_Iz2 := 16#0000#;
 219          IS_Iz4 := 16#0000_0000#;
 220          IS_Iz8 := 16#0000_0000_0000_0000#;
 221
 222          if AFloat then
 223             IV_Isf := 16#0000_0001#;
 224             IV_Ifl := 16#0000_0001#;
 225             IV_Ilf := (1, 0, 0, 0, 0, 0);
 226
 227          else
 228             IV_Isf := 16#FF80_0000#;
 229             IV_Ifl := 16#FF80_0000#;
 230             IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
 231          end if;
 232
 233          if EFloat then
 234             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
 235          end if;
 236
 237       --  HI (High values)
 238
 239       elsif C1 = 'H' and then C2 = 'I' then
 240          IS_Is1 := 16#7F#;
 241          IS_Is2 := 16#7FFF#;
 242          IS_Is4 := 16#7FFF_FFFF#;
 243          IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
 244
 245          IS_Iu1 := 16#FF#;
 246          IS_Iu2 := 16#FFFF#;
 247          IS_Iu4 := 16#FFFF_FFFF#;
 248          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 249
 250          IS_Iz1 := 16#FF#;
 251          IS_Iz2 := 16#FFFF#;
 252          IS_Iz4 := 16#FFFF_FFFF#;
 253          IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
 254
 255          if AFloat then
 256             IV_Isf := 16#7FFF_FFFF#;
 257             IV_Ifl := 16#7FFF_FFFF#;
 258             IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#);
 259
 260          else
 261             IV_Isf := 16#7F80_0000#;
 262             IV_Ifl := 16#7F80_0000#;
 263             IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
 264          end if;
 265
 266          if EFloat then
 267             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
 268          end if;
 269
 270       --  -Shh (hex byte)
 271
 272       else
 273          --  Convert the two hex digits (we know they are valid here)
 274
 275          if C1 in '0' .. '9' then
 276             B := Character'Pos (C1) - Character'Pos ('0');
 277          else
 278             B := Character'Pos (C1) - (Character'Pos ('A') - 10);
 279          end if;
 280
 281          if C2 in '0' .. '9' then
 282             B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
 283          else
 284             B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
 285          end if;
 286
 287          --  Initialize data values from the hex value
 288
 289          IS_Is1 := B;
 290          IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
 291          IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
 292          IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
 293
 294          IS_Iu1 := IS_Is1;
 295          IS_Iu2 := IS_Is2;
 296          IS_Iu4 := IS_Is4;
 297          IS_Iu8 := IS_Is8;
 298
 299          IS_Iz1 := IS_Is1;
 300          IS_Iz2 := IS_Is2;
 301          IS_Iz4 := IS_Is4;
 302          IS_Iz8 := IS_Is8;
 303
 304          IV_Isf := IS_Is4;
 305          IV_Ifl := IS_Is4;
 306
 307          if AFloat then
 308             IV_Ill := (B, B, B, B, B, B);
 309          else
 310             IV_Ilf := To_ByteLF (IS_Is8);
 311          end if;
 312
 313          if EFloat then
 314             IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
 315          end if;
 316       end if;
 317
 318       --  If no separate Long_Long_Float, then use Long_Float value as
 319       --  Long_Long_Float initial value.
 320
 321       if not EFloat then
 322          declare
 323             pragma Warnings (Off);  -- why???
 324             function To_ByteLLF is
 325               new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
 326             pragma Warnings (On);
 327          begin
 328             IV_Ill := To_ByteLLF (IV_Ilf);
 329          end;
 330       end if;
 331    end Initialize;
 332
 333 end System.Scalar_Values;