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 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          IV_Isf := IS_Iu4;
 163          IV_Ifl := IS_Iu4;
 164          IV_Ilf := IS_Iu8;
 165
 166          if EFloat then
 167             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
 168          end if;
 169
 170       --  LO (Low values)
 171
 172       elsif C1 = 'L' and then C2 = 'O' then
 173          IS_Is1 := 16#80#;
 174          IS_Is2 := 16#8000#;
 175          IS_Is4 := 16#8000_0000#;
 176          IS_Is8 := 16#8000_0000_0000_0000#;
 177
 178          IS_Iu1 := 16#00#;
 179          IS_Iu2 := 16#0000#;
 180          IS_Iu4 := 16#0000_0000#;
 181          IS_Iu8 := 16#0000_0000_0000_0000#;
 182
 183          IV_Isf := 16#FF80_0000#;
 184          IV_Ifl := 16#FF80_0000#;
 185          IV_Ilf := 16#FFF0_0000_0000_0000#;
 186
 187          if EFloat then
 188             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
 189          end if;
 190
 191       --  HI (High values)
 192
 193       elsif C1 = 'H' and then C2 = 'I' then
 194          IS_Is1 := 16#7F#;
 195          IS_Is2 := 16#7FFF#;
 196          IS_Is4 := 16#7FFF_FFFF#;
 197          IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
 198
 199          IS_Iu1 := 16#FF#;
 200          IS_Iu2 := 16#FFFF#;
 201          IS_Iu4 := 16#FFFF_FFFF#;
 202          IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
 203
 204          IV_Isf := 16#7F80_0000#;
 205          IV_Ifl := 16#7F80_0000#;
 206          IV_Ilf := 16#7FF0_0000_0000_0000#;
 207
 208          if EFloat then
 209             IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
 210          end if;
 211
 212       --  -Shh (hex byte)
 213
 214       else
 215          --  Convert the two hex digits (we know they are valid here)
 216
 217          if C1 in '0' .. '9' then
 218             B := Character'Pos (C1) - Character'Pos ('0');
 219          else
 220             B := Character'Pos (C1) - (Character'Pos ('A') - 10);
 221          end if;
 222
 223          if C2 in '0' .. '9' then
 224             B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
 225          else
 226             B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
 227          end if;
 228
 229          --  Initialize data values from the hex value
 230
 231          IS_Is1 := B;
 232          IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
 233          IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
 234          IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
 235
 236          IS_Iu1 := IS_Is1;
 237          IS_Iu2 := IS_Is2;
 238          IS_Iu4 := IS_Is4;
 239          IS_Iu8 := IS_Is8;
 240
 241          IV_Isf := IS_Is4;
 242          IV_Ifl := IS_Is4;
 243          IV_Ilf := IS_Is8;
 244
 245          if EFloat then
 246             IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
 247          end if;
 248       end if;
 249
 250       --  If no separate Long_Long_Float, then use Long_Float value as
 251       --  Long_Long_Float initial value.
 252
 253       if not EFloat then
 254          declare
 255             pragma Warnings (Off);
 256             function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF);
 257             pragma Warnings (On);
 258          begin
 259             IV_Ill := To_ByteLF (IV_Ilf);
 260          end;
 261       end if;
 262
 263
 264    end Initialize;
 265
 266 end System.Scalar_Values;