------------------------------------------------------------------------------
--                                                                          --
--                          GNAT RUN-TIME 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-2022, 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 3,  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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Unchecked_Conversion;

package body System.Scalar_Values is

   use Interfaces;

   ----------------
   -- 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_getenv");

      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) of Byte1;

      for ByteLF'Component_Size use 8;
      function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);

      type ByteLLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;

      for ByteLLF'Component_Size use 8;

      --  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 ByteLF;    -- Initialize long float
      IV_Ill : aliased ByteLLF;   -- 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_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#;

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

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

         IV_Isf := IS_Iu4;
         IV_Ifl := IS_Iu4;
         IV_Ilf := To_ByteLF (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_Is16 := 16#8000_0000_0000_0000_0000_0000_0000_0000#;

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

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

         IV_Isf := 16#FF80_0000#;
         IV_Ifl := 16#FF80_0000#;
         IV_Ilf := To_ByteLF (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_Is16 := 16#7FFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF_FFFF#;

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

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

         IV_Isf := 16#7F80_0000#;
         IV_Ifl := 16#7F80_0000#;
         IV_Ilf := To_ByteLF (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)

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

         --  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_Is16 := 2**64 * Byte16 (IS_Is8) + Byte16 (IS_Is8);

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

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

         IV_Isf := IS_Is4;
         IV_Ifl := IS_Is4;

         IV_Ilf := To_ByteLF (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); -- because sizes don't match
            function To_ByteLLF is
              new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
            pragma Warnings (On);
         begin
            IV_Ill := To_ByteLLF (IV_Ilf);
         end;
      end if;
   end Initialize;

end System.Scalar_Values;