1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . S C A L A R _ V A L U E S --
9 -- Copyright (C) 2003-2023, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Unchecked_Conversion
;
34 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_getenv");
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) of Byte1
;
65 for ByteLF
'Component_Size use 8;
67 -- Type used to hold Long_Float values on all targets. On most targets
68 -- the type is 8 bytes, and type Byte8 is used for values that are then
69 -- converted to ByteLF.
71 function To_ByteLF
is new Ada
.Unchecked_Conversion
(Byte8
, ByteLF
);
73 type ByteLLF
is array (0 .. 7 + 4 * Boolean'Pos (EFloat
)) of Byte1
;
75 for ByteLLF
'Component_Size use 8;
77 -- Type used to initialize Long_Long_Float values used on x86 and
78 -- any other target with the same 80-bit floating-point values that
79 -- GCC always stores in 96-bits. Note that we are assuming Intel
80 -- format little-endian addressing for this type. On non-Intel
81 -- architectures, this is the same length as Byte8 and holds
82 -- a Long_Float value.
84 -- The following variables are used to initialize the float values
85 -- by overlay. We can't assign directly to the float values, since
86 -- we may be assigning signalling Nan's that will cause a trap if
87 -- loaded into a floating-point register.
89 IV_Isf
: aliased Byte4
; -- Initialize short float
90 IV_Ifl
: aliased Byte4
; -- Initialize float
91 IV_Ilf
: aliased ByteLF
; -- Initialize long float
92 IV_Ill
: aliased ByteLLF
; -- Initialize long long float
94 for IV_Isf
'Address use IS_Isf
'Address;
95 for IV_Ifl
'Address use IS_Ifl
'Address;
96 for IV_Ilf
'Address use IS_Ilf
'Address;
97 for IV_Ill
'Address use IS_Ill
'Address;
99 -- The following pragmas are used to suppress initialization
101 pragma Import
(Ada
, IV_Isf
);
102 pragma Import
(Ada
, IV_Ifl
);
103 pragma Import
(Ada
, IV_Ilf
);
104 pragma Import
(Ada
, IV_Ill
);
107 -- Acquire environment variable value if necessary
109 if C1
= 'E' and then C2
= 'V' then
111 (EV_Val
'Address, Env_Value_Length
'Address, Env_Value_Ptr
'Address);
113 -- Ignore if length is not 2
115 if Env_Value_Length
/= 2 then
119 -- Length is 2, see if it is a valid value
122 -- Acquire two characters and fold to upper case
124 C1
:= Env_Value_Ptr
(1);
125 C2
:= Env_Value_Ptr
(2);
127 if C1
in 'a' .. 'z' then
128 C1
:= Character'Val (Character'Pos (C1
) - 32);
131 if C2
in 'a' .. 'z' then
132 C2
:= Character'Val (Character'Pos (C2
) - 32);
135 -- IN/LO/HI are ok values
137 if (C1
= 'I' and then C2
= 'N')
139 (C1
= 'L' and then C2
= 'O')
141 (C1
= 'H' and then C2
= 'I')
145 -- Try for valid hex digits
147 elsif (C1
in '0' .. '9' or else C1
in 'A' .. 'Z')
149 (C2
in '0' .. '9' or else C2
in 'A' .. 'Z')
153 -- Otherwise environment value is bad, ignore and use IN (invalid)
162 -- IN (invalid value)
164 if C1
= 'I' and then C2
= 'N' then
167 IS_Is4
:= 16#
8000_0000#
;
168 IS_Is8
:= 16#
8000_0000_0000_0000#
;
172 IS_Iu4
:= 16#FFFF_FFFF#
;
173 IS_Iu8
:= 16#FFFF_FFFF_FFFF_FFFF#
;
177 IS_Iz4
:= 16#
0000_0000#
;
178 IS_Iz8
:= 16#
0000_0000_0000_0000#
;
182 IV_Ilf
:= To_ByteLF
(IS_Iu8
);
185 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#C0#
, 16#FF#
, 16#FF#
, 0, 0);
190 elsif C1
= 'L' and then C2
= 'O' then
193 IS_Is4
:= 16#
8000_0000#
;
194 IS_Is8
:= 16#
8000_0000_0000_0000#
;
198 IS_Iu4
:= 16#
0000_0000#
;
199 IS_Iu8
:= 16#
0000_0000_0000_0000#
;
203 IS_Iz4
:= 16#
0000_0000#
;
204 IS_Iz8
:= 16#
0000_0000_0000_0000#
;
206 IV_Isf
:= 16#FF80_0000#
;
207 IV_Ifl
:= 16#FF80_0000#
;
208 IV_Ilf
:= To_ByteLF
(16#FFF0_0000_0000_0000#
);
211 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#
80#
, 16#FF#
, 16#FF#
, 0, 0);
216 elsif C1
= 'H' and then C2
= 'I' then
219 IS_Is4
:= 16#
7FFF_FFFF#
;
220 IS_Is8
:= 16#
7FFF_FFFF_FFFF_FFFF#
;
224 IS_Iu4
:= 16#FFFF_FFFF#
;
225 IS_Iu8
:= 16#FFFF_FFFF_FFFF_FFFF#
;
229 IS_Iz4
:= 16#FFFF_FFFF#
;
230 IS_Iz8
:= 16#FFFF_FFFF_FFFF_FFFF#
;
232 IV_Isf
:= 16#
7F80_0000#
;
233 IV_Ifl
:= 16#
7F80_0000#
;
234 IV_Ilf
:= To_ByteLF
(16#
7FF0_0000_0000_0000#
);
237 IV_Ill
:= (0, 0, 0, 0, 0, 0, 0, 16#
80#
, 16#FF#
, 16#
7F#
, 0, 0);
243 -- Convert the two hex digits (we know they are valid here)
245 B
:= 16 * (Character'Pos (C1
)
246 - (if C1
in '0' .. '9'
247 then Character'Pos ('0')
248 else Character'Pos ('A') - 10))
249 + (Character'Pos (C2
)
250 - (if C2
in '0' .. '9'
251 then Character'Pos ('0')
252 else Character'Pos ('A') - 10));
254 -- Initialize data values from the hex value
257 IS_Is2
:= 2**8 * Byte2
(IS_Is1
) + Byte2
(IS_Is1
);
258 IS_Is4
:= 2**16 * Byte4
(IS_Is2
) + Byte4
(IS_Is2
);
259 IS_Is8
:= 2**32 * Byte8
(IS_Is4
) + Byte8
(IS_Is4
);
274 IV_Ilf
:= To_ByteLF
(IS_Is8
);
277 IV_Ill
:= (B
, B
, B
, B
, B
, B
, B
, B
, B
, B
, B
, B
);
281 -- If no separate Long_Long_Float, then use Long_Float value as
282 -- Long_Long_Float initial value.
286 pragma Warnings
(Off
); -- because sizes don't match
287 function To_ByteLLF
is
288 new Ada
.Unchecked_Conversion
(ByteLF
, ByteLLF
);
289 pragma Warnings
(On
);
291 IV_Ill
:= To_ByteLLF
(IV_Ilf
);
296 end System
.Scalar_Values
;