| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 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#; |
| |
| 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#; |
| |
| 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#; |
| |
| 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; |
| |
| 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; |
