| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2009, 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 |
| |
| ---------------- |
| -- 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 |
| |
| AFloat : constant Boolean := |
| Long_Float'Size = 48 and then Long_Long_Float'Size = 48; |
| -- Set True if we are on an AAMP with 48-bit extended floating point |
| |
| type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1; |
| |
| for ByteLF'Component_Size use 8; |
| |
| -- Type used to hold Long_Float values on all targets and to initialize |
| -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes. |
| -- On other targets the type is 8 bytes, and type Byte8 is used for |
| -- values that are then converted to ByteLF. |
| |
| pragma Warnings (Off); -- why ??? |
| function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF); |
| pragma Warnings (On); |
| |
| type ByteLLF is |
| array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat)) |
| 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_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#; |
| |
| if AFloat then |
| IV_Isf := 16#FFFF_FF00#; |
| IV_Ifl := 16#FFFF_FF00#; |
| IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); |
| |
| else |
| IV_Isf := IS_Iu4; |
| IV_Ifl := IS_Iu4; |
| IV_Ilf := To_ByteLF (IS_Iu8); |
| end if; |
| |
| 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#; |
| |
| if AFloat then |
| IV_Isf := 16#0000_0001#; |
| IV_Ifl := 16#0000_0001#; |
| IV_Ilf := (1, 0, 0, 0, 0, 0); |
| |
| else |
| IV_Isf := 16#FF80_0000#; |
| IV_Ifl := 16#FF80_0000#; |
| IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); |
| end if; |
| |
| 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#; |
| |
| if AFloat then |
| IV_Isf := 16#7FFF_FFFF#; |
| IV_Ifl := 16#7FFF_FFFF#; |
| IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); |
| |
| else |
| IV_Isf := 16#7F80_0000#; |
| IV_Ifl := 16#7F80_0000#; |
| IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); |
| end if; |
| |
| 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_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; |
| |
| if AFloat then |
| IV_Ill := (B, B, B, B, B, B); |
| else |
| IV_Ilf := To_ByteLF (IS_Is8); |
| end if; |
| |
| 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); -- why??? |
| 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; |
