gcc/ada/s-scaval.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT RUNTIME 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-2005 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 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_get_env_value_ptr");
  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 + 4 * Boolean'Pos (EFloat)) of Byte1;
  64       --  Type used to initialize Long_Long_Float values used on x86 and
  65       --  any other target with the same 80-bit floating-point values that
  66       --  GCC always stores in 96-bits. Note that we are assuming Intel
  67       --  format little-endian addressing for this type. On non-Intel
  68       --  architectures, this is the same length as Byte8 and holds
  69       --  a Long_Float value.
  70
  71       --  The following variables are used to initialize the float values
  72       --  by overlay. We can't assign directly to the float values, since
  73       --  we may be assigning signalling Nan's that will cause a trap if
  74       --  loaded into a floating-point register.
  75
  76       IV_Isf : aliased Byte4;     -- Initialize short float
  77       IV_Ifl : aliased Byte4;     -- Initialize float
  78       IV_Ilf : aliased Byte8;     -- Initialize long float
  79       IV_Ill : aliased ByteLF;    -- Initialize long long float
  80
  81       for IV_Isf'Address use IS_Isf'Address;
  82       for IV_Ifl'Address use IS_Ifl'Address;
  83       for IV_Ilf'Address use IS_Ilf'Address;
  84       for IV_Ill'Address use IS_Ill'Address;
  85
  86       --  The following pragmas are used to suppress initialization
  87
  88       pragma Import (Ada, IV_Isf);
  89       pragma Import (Ada, IV_Ifl);
  90       pragma Import (Ada, IV_Ilf);
  91       pragma Import (Ada, IV_Ill);
  92
  93    begin
  94       --  Acquire environment variable value if necessary
  95
  96       if C1 = 'E' and then C2 = 'V' then
  97          Get_Env_Value_Ptr
  98            (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
  99
 100          --  Ignore if length is not 2
 101
 102          if Env_Value_Length /= 2 then
 103             C1 := 'I';
 104             C2 := 'N';
 105
 106          --  Length is 2, see if it is a valid value
 107
 108          else
 109             --  Acquire two characters and fold to upper case
 110
 111             C1 := Env_Value_Ptr (1);
 112             C2 := Env_Value_Ptr (2);
 113
 114             if C1 in 'a' .. 'z' then
 115                C1 := Character'Val (Character'Pos (C1) - 32);
 116             end if;
 117
 118             if C2 in 'a' .. 'z' then
 119                C2 := Character'Val (Character'Pos (C2) - 32);
 120             end if;
 121
 122             --  IN/LO/HI are ok values
 123
 124             if (C1 = 'I' and then C2 = 'N')
 125                   or else
 126                (C1 = 'L' and then C2 = 'O')
 127                   or else
 128                (C1 = 'H' and then C2 = 'I')
 129             then
 130                null;
 131
 132             --  Try for valid hex digits
 133
 134             elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
 135                      or else
 136                   (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
 137             then
 138                null;
 139
 140             --  Otherwise environment value is bad, ignore and use IN (invalid)
 141
 142             else
 143                C1 := 'I';
 144                C2 := 'N';
 145             end if;
 146          end if;
 147       end if;
 148
 149       --  IN (invalid value)
 150
 151       if C1 = 'I' and then C2 = 'N' then
 152          IS_Is1 := 16#80#;
 153          IS_Is2 := 16#8000#;
 154          IS_Is4 := 16#8000_0000#;
 155          IS_Is8 := 16#8000_0000_0000_0000#;
 156
 157          IS_Iu1 := 16#FF#;
 158          IS_Iu2 := 16#FFFF#;
 159          IS_Iu4 := 16#FFFF_FFFF#;
 160          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 161
 162          IS_Iz1 := 16#00#;
 163          IS_Iz2 := 16#0000#;
 164          IS_Iz4 := 16#0000_0000#;
 165          IS_Iz8 := 16#0000_0000_0000_0000#;
 166
 167          IV_Isf := IS_Iu4;
 168          IV_Ifl := IS_Iu4;
 169          IV_Ilf := IS_Iu8;
 170
 171          if EFloat then
 172             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
 173          end if;
 174
 175       --  LO (Low values)
 176
 177       elsif C1 = 'L' and then C2 = 'O' then
 178          IS_Is1 := 16#80#;
 179          IS_Is2 := 16#8000#;
 180          IS_Is4 := 16#8000_0000#;
 181          IS_Is8 := 16#8000_0000_0000_0000#;
 182
 183          IS_Iu1 := 16#00#;
 184          IS_Iu2 := 16#0000#;
 185          IS_Iu4 := 16#0000_0000#;
 186          IS_Iu8 := 16#0000_0000_0000_0000#;
 187
 188          IS_Iz1 := 16#00#;
 189          IS_Iz2 := 16#0000#;
 190          IS_Iz4 := 16#0000_0000#;
 191          IS_Iz8 := 16#0000_0000_0000_0000#;
 192
 193          IV_Isf := 16#FF80_0000#;
 194          IV_Ifl := 16#FF80_0000#;
 195          IV_Ilf := 16#FFF0_0000_0000_0000#;
 196
 197          if EFloat then
 198             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
 199          end if;
 200
 201       --  HI (High values)
 202
 203       elsif C1 = 'H' and then C2 = 'I' then
 204          IS_Is1 := 16#7F#;
 205          IS_Is2 := 16#7FFF#;
 206          IS_Is4 := 16#7FFF_FFFF#;
 207          IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
 208
 209          IS_Iu1 := 16#FF#;
 210          IS_Iu2 := 16#FFFF#;
 211          IS_Iu4 := 16#FFFF_FFFF#;
 212          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 213
 214          IS_Iz1 := 16#FF#;
 215          IS_Iz2 := 16#FFFF#;
 216          IS_Iz4 := 16#FFFF_FFFF#;
 217          IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
 218
 219          IV_Isf := 16#7F80_0000#;
 220          IV_Ifl := 16#7F80_0000#;
 221          IV_Ilf := 16#7FF0_0000_0000_0000#;
 222
 223          if EFloat then
 224             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
 225          end if;
 226
 227       --  -Shh (hex byte)
 228
 229       else
 230          --  Convert the two hex digits (we know they are valid here)
 231
 232          if C1 in '0' .. '9' then
 233             B := Character'Pos (C1) - Character'Pos ('0');
 234          else
 235             B := Character'Pos (C1) - (Character'Pos ('A') - 10);
 236          end if;
 237
 238          if C2 in '0' .. '9' then
 239             B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
 240          else
 241             B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
 242          end if;
 243
 244          --  Initialize data values from the hex value
 245
 246          IS_Is1 := B;
 247          IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
 248          IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
 249          IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
 250
 251          IS_Iu1 := IS_Is1;
 252          IS_Iu2 := IS_Is2;
 253          IS_Iu4 := IS_Is4;
 254          IS_Iu8 := IS_Is8;
 255
 256          IS_Iz1 := IS_Is1;
 257          IS_Iz2 := IS_Is2;
 258          IS_Iz4 := IS_Is4;
 259          IS_Iz8 := IS_Is8;
 260
 261          IV_Isf := IS_Is4;
 262          IV_Ifl := IS_Is4;
 263          IV_Ilf := IS_Is8;
 264
 265          if EFloat then
 266             IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
 267          end if;
 268       end if;
 269
 270       --  If no separate Long_Long_Float, then use Long_Float value as
 271       --  Long_Long_Float initial value.
 272
 273       if not EFloat then
 274          declare
 275             pragma Warnings (Off);
 276             function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF);
 277             pragma Warnings (On);
 278          begin
 279             IV_Ill := To_ByteLF (IV_Ilf);
 280          end;
 281       end if;
 282    end Initialize;
 283
 284 end System.Scalar_Values;