1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- S Y S T E M . S C A L A R _ V A L U E S --
9 -- Copyright (C) 2003 Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Unchecked_Conversion
;
36 package body System
.Scalar_Values
is
42 procedure Initialize
(Mode1
: Character; Mode2
: Character) is
43 C1
: Character := Mode1
;
44 C2
: Character := Mode2
;
46 procedure Get_Env_Value_Ptr
(Name
, Length
, Ptr
: Address
);
47 pragma Import
(C
, Get_Env_Value_Ptr
, "__gnat_get_env_value_ptr");
49 subtype String2
is String (1 .. 2);
50 type String2_Ptr
is access all String2
;
52 Env_Value_Ptr
: aliased String2_Ptr
;
53 Env_Value_Length
: aliased Integer;
55 EV_Val
: aliased constant String :=
56 "GNAT_INIT_SCALARS" & ASCII
.NUL
;
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
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.
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.
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
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;
86 -- The following pragmas are used to suppress initialization
88 pragma Import
(Ada
, IV_Isf
);
89 pragma Import
(Ada
, IV_Ifl
);
90 pragma Import
(Ada
, IV_Ilf
);
91 pragma Import
(Ada
, IV_Ill
);
94 -- Acquire environment variable value if necessary
96 if C1
= 'E' and then C2
= 'V' then
98 (EV_Val
'Address, Env_Value_Length
'Address, Env_Value_Ptr
'Address);
100 -- Ignore if length is not 2
102 if Env_Value_Length
/= 2 then
106 -- Length is 2, see if it is a valid value
109 -- Acquire two characters and fold to upper case
111 C1
:= Env_Value_Ptr
(1);
112 C2
:= Env_Value_Ptr
(2);
114 if C1
in 'a' .. 'z' then
115 C1
:= Character'Val (Character'Pos (C1
) - 32);
118 if C2
in 'a' .. 'z' then
119 C2
:= Character'Val (Character'Pos (C2
) - 32);
122 -- IN/LO/HI are ok values
124 if (C1
= 'I' and then C2
= 'N')
126 (C1
= 'L' and then C2
= 'O')
128 (C1
= 'H' and then C2
= 'I')
132 -- Try for valid hex digits
134 elsif (C1
in '0' .. '9' or else C1
in 'A' .. 'Z')
136 (C2
in '0' .. '9' or else C2
in 'A' .. 'Z')
140 -- Otherwise environment value is bad, ignore and use IN (invalid)
149 -- IN (invalid value)
151 if C1
= 'I' and then C2
= 'N' then
154 IS_Is4
:= 16#
8000_0000#
;
155 IS_Is8
:= 16#
8000_0000_0000_0000#
;
159 IS_Iu4
:= 16#FFFF_FFFF#
;
160 IS_Iu8
:= 16#FFFF_FFFF_FFFF_FFFF#
;
167 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#C0#
, 16#FF#
, 16#FF#
, 0, 0);
172 elsif C1
= 'L' and then C2
= 'O' then
175 IS_Is4
:= 16#
8000_0000#
;
176 IS_Is8
:= 16#
8000_0000_0000_0000#
;
180 IS_Iu4
:= 16#
0000_0000#
;
181 IS_Iu8
:= 16#
0000_0000_0000_0000#
;
183 IV_Isf
:= 16#FF80_0000#
;
184 IV_Ifl
:= 16#FF80_0000#
;
185 IV_Ilf
:= 16#FFF0_0000_0000_0000#
;
188 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#
80#
, 16#FF#
, 16#FF#
, 0, 0);
193 elsif C1
= 'H' and then C2
= 'I' then
196 IS_Is4
:= 16#
7FFF_FFFF#
;
197 IS_Is8
:= 16#
7FFF_FFFF_FFFF_FFFF#
;
201 IS_Iu4
:= 16#FFFF_FFFF#
;
202 IS_Iu8
:= 16#FFFF_FFFF_FFFF_FFFF#
;
204 IV_Isf
:= 16#
7F80_0000#
;
205 IV_Ifl
:= 16#
7F80_0000#
;
206 IV_Ilf
:= 16#
7FF0_0000_0000_0000#
;
209 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#
80#
, 16#FF#
, 16#
7F#
, 0, 0);
215 -- Convert the two hex digits (we know they are valid here)
217 if C1
in '0' .. '9' then
218 B
:= Character'Pos (C1
) - Character'Pos ('0');
220 B
:= Character'Pos (C1
) - (Character'Pos ('A') - 10);
223 if C2
in '0' .. '9' then
224 B
:= B
* 16 + Character'Pos (C2
) - Character'Pos ('0');
226 B
:= B
* 16 + Character'Pos (C2
) - (Character'Pos ('A') - 10);
229 -- Initialize data values from the hex value
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
);
246 IV_Ill
:= (B
, B
, B
, B
, B
, B
, B
, B
, B
, B
, B
, B
);
250 -- If no separate Long_Long_Float, then use Long_Float value as
251 -- Long_Long_Float initial value.
255 pragma Warnings
(Off
);
256 function To_ByteLF
is new Unchecked_Conversion
(Byte8
, ByteLF
);
257 pragma Warnings
(On
);
259 IV_Ill
:= To_ByteLF
(IV_Ilf
);
266 end System
.Scalar_Values
;