s-scaval.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                          GNAT RUNTIME COMPONENTS                         --
--                                                                          --
--                  S Y S T E M . S C A L A R _ V A L U E S                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2003-2005 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Unchecked_Conversion;

package body System.Scalar_Values is

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Mode1 : Character; Mode2 : Character) is
      C1 : Character := Mode1;
      C2 : Character := Mode2;

      procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
      pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");

      subtype String2 is String (1 .. 2);
      type String2_Ptr is access all String2;

      Env_Value_Ptr    : aliased String2_Ptr;
      Env_Value_Length : aliased Integer;

      EV_Val : aliased constant String :=
                 "GNAT_INIT_SCALARS" & ASCII.NUL;

      B : Byte1;

      EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
      --  Set True if we are on an x86 with 96-bit floats for extended

      type ByteLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
      --  Type used to initialize Long_Long_Float values used on x86 and
      --  any other target with the same 80-bit floating-point values that
      --  GCC always stores in 96-bits. Note that we are assuming Intel
      --  format little-endian addressing for this type. On non-Intel
      --  architectures, this is the same length as Byte8 and holds
      --  a Long_Float value.

      --  The following variables are used to initialize the float values
      --  by overlay. We can't assign directly to the float values, since
      --  we may be assigning signalling Nan's that will cause a trap if
      --  loaded into a floating-point register.

      IV_Isf : aliased Byte4;     -- Initialize short float
      IV_Ifl : aliased Byte4;     -- Initialize float
      IV_Ilf : aliased Byte8;     -- Initialize long float
      IV_Ill : aliased ByteLF;    -- Initialize long long float

      for IV_Isf'Address use IS_Isf'Address;
      for IV_Ifl'Address use IS_Ifl'Address;
      for IV_Ilf'Address use IS_Ilf'Address;
      for IV_Ill'Address use IS_Ill'Address;

      --  The following pragmas are used to suppress initialization

      pragma Import (Ada, IV_Isf);
      pragma Import (Ada, IV_Ifl);
      pragma Import (Ada, IV_Ilf);
      pragma Import (Ada, IV_Ill);

   begin
      --  Acquire environment variable value if necessary

      if C1 = 'E' and then C2 = 'V' then
         Get_Env_Value_Ptr
           (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);

         --  Ignore if length is not 2

         if Env_Value_Length /= 2 then
            C1 := 'I';
            C2 := 'N';

         --  Length is 2, see if it is a valid value

         else
            --  Acquire two characters and fold to upper case

            C1 := Env_Value_Ptr (1);
            C2 := Env_Value_Ptr (2);

            if C1 in 'a' .. 'z' then
               C1 := Character'Val (Character'Pos (C1) - 32);
            end if;

            if C2 in 'a' .. 'z' then
               C2 := Character'Val (Character'Pos (C2) - 32);
            end if;

            --  IN/LO/HI are ok values

            if (C1 = 'I' and then C2 = 'N')
                  or else
               (C1 = 'L' and then C2 = 'O')
                  or else
               (C1 = 'H' and then C2 = 'I')
            then
               null;

            --  Try for valid hex digits

            elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
                     or else
                  (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
            then
               null;

            --  Otherwise environment value is bad, ignore and use IN (invalid)

            else
               C1 := 'I';
               C2 := 'N';
            end if;
         end if;
      end if;

      --  IN (invalid value)

      if C1 = 'I' and then C2 = 'N' then
         IS_Is1 := 16#80#;
         IS_Is2 := 16#8000#;
         IS_Is4 := 16#8000_0000#;
         IS_Is8 := 16#8000_0000_0000_0000#;

         IS_Iu1 := 16#FF#;
         IS_Iu2 := 16#FFFF#;
         IS_Iu4 := 16#FFFF_FFFF#;
         IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;

         IS_Iz1 := 16#00#;
         IS_Iz2 := 16#0000#;
         IS_Iz4 := 16#0000_0000#;
         IS_Iz8 := 16#0000_0000_0000_0000#;

         IV_Isf := IS_Iu4;
         IV_Ifl := IS_Iu4;
         IV_Ilf := IS_Iu8;

         if EFloat then
            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
         end if;

      --  LO (Low values)

      elsif C1 = 'L' and then C2 = 'O' then
         IS_Is1 := 16#80#;
         IS_Is2 := 16#8000#;
         IS_Is4 := 16#8000_0000#;
         IS_Is8 := 16#8000_0000_0000_0000#;

         IS_Iu1 := 16#00#;
         IS_Iu2 := 16#0000#;
         IS_Iu4 := 16#0000_0000#;
         IS_Iu8 := 16#0000_0000_0000_0000#;

         IS_Iz1 := 16#00#;
         IS_Iz2 := 16#0000#;
         IS_Iz4 := 16#0000_0000#;
         IS_Iz8 := 16#0000_0000_0000_0000#;

         IV_Isf := 16#FF80_0000#;
         IV_Ifl := 16#FF80_0000#;
         IV_Ilf := 16#FFF0_0000_0000_0000#;

         if EFloat then
            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
         end if;

      --  HI (High values)

      elsif C1 = 'H' and then C2 = 'I' then
         IS_Is1 := 16#7F#;
         IS_Is2 := 16#7FFF#;
         IS_Is4 := 16#7FFF_FFFF#;
         IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;

         IS_Iu1 := 16#FF#;
         IS_Iu2 := 16#FFFF#;
         IS_Iu4 := 16#FFFF_FFFF#;
         IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;

         IS_Iz1 := 16#FF#;
         IS_Iz2 := 16#FFFF#;
         IS_Iz4 := 16#FFFF_FFFF#;
         IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;

         IV_Isf := 16#7F80_0000#;
         IV_Ifl := 16#7F80_0000#;
         IV_Ilf := 16#7FF0_0000_0000_0000#;

         if EFloat then
            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
         end if;

      --  -Shh (hex byte)

      else
         --  Convert the two hex digits (we know they are valid here)

         if C1 in '0' .. '9' then
            B := Character'Pos (C1) - Character'Pos ('0');
         else
            B := Character'Pos (C1) - (Character'Pos ('A') - 10);
         end if;

         if C2 in '0' .. '9' then
            B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
         else
            B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
         end if;

         --  Initialize data values from the hex value

         IS_Is1 := B;
         IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
         IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
         IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);

         IS_Iu1 := IS_Is1;
         IS_Iu2 := IS_Is2;
         IS_Iu4 := IS_Is4;
         IS_Iu8 := IS_Is8;

         IS_Iz1 := IS_Is1;
         IS_Iz2 := IS_Is2;
         IS_Iz4 := IS_Is4;
         IS_Iz8 := IS_Is8;

         IV_Isf := IS_Is4;
         IV_Ifl := IS_Is4;
         IV_Ilf := IS_Is8;

         if EFloat then
            IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
         end if;
      end if;

      --  If no separate Long_Long_Float, then use Long_Float value as
      --  Long_Long_Float initial value.

      if not EFloat then
         declare
            pragma Warnings (Off);
            function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF);
            pragma Warnings (On);
         begin
            IV_Ill := To_ByteLF (IV_Ilf);
         end;
      end if;
   end Initialize;

end System.Scalar_Values;