|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . S C A L A R _ V A L U E S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2003-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Unchecked_Conversion;
|
|
|
33
|
|
|
34 package body System.Scalar_Values is
|
|
|
35
|
|
|
36 ----------------
|
|
|
37 -- Initialize --
|
|
|
38 ----------------
|
|
|
39
|
|
|
40 procedure Initialize (Mode1 : Character; Mode2 : Character) is
|
|
|
41 C1 : Character := Mode1;
|
|
|
42 C2 : Character := Mode2;
|
|
|
43
|
|
|
44 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
|
|
|
45 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
|
|
|
46
|
|
|
47 subtype String2 is String (1 .. 2);
|
|
|
48 type String2_Ptr is access all String2;
|
|
|
49
|
|
|
50 Env_Value_Ptr : aliased String2_Ptr;
|
|
|
51 Env_Value_Length : aliased Integer;
|
|
|
52
|
|
|
53 EV_Val : aliased constant String :=
|
|
|
54 "GNAT_INIT_SCALARS" & ASCII.NUL;
|
|
|
55
|
|
|
56 B : Byte1;
|
|
|
57
|
|
|
58 EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
|
|
|
59 -- Set True if we are on an x86 with 96-bit floats for extended
|
|
|
60
|
|
|
61 AFloat : constant Boolean :=
|
|
|
62 Long_Float'Size = 48 and then Long_Long_Float'Size = 48;
|
|
|
63 -- Set True if we are on an AAMP with 48-bit extended floating point
|
|
|
64
|
|
|
65 type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
|
|
|
66
|
|
|
67 for ByteLF'Component_Size use 8;
|
|
|
68
|
|
|
69 -- Type used to hold Long_Float values on all targets and to initialize
|
|
|
70 -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes.
|
|
|
71 -- On other targets the type is 8 bytes, and type Byte8 is used for
|
|
|
72 -- values that are then converted to ByteLF.
|
|
|
73
|
|
|
74 pragma Warnings (Off); -- why ???
|
|
|
75 function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
|
|
|
76 pragma Warnings (On);
|
|
|
77
|
|
|
78 type ByteLLF is
|
|
|
79 array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
|
|
|
80 of Byte1;
|
|
|
81
|
|
|
82 for ByteLLF'Component_Size use 8;
|
|
|
83
|
|
|
84 -- Type used to initialize Long_Long_Float values used on x86 and
|
|
|
85 -- any other target with the same 80-bit floating-point values that
|
|
|
86 -- GCC always stores in 96-bits. Note that we are assuming Intel
|
|
|
87 -- format little-endian addressing for this type. On non-Intel
|
|
|
88 -- architectures, this is the same length as Byte8 and holds
|
|
|
89 -- a Long_Float value.
|
|
|
90
|
|
|
91 -- The following variables are used to initialize the float values
|
|
|
92 -- by overlay. We can't assign directly to the float values, since
|
|
|
93 -- we may be assigning signalling Nan's that will cause a trap if
|
|
|
94 -- loaded into a floating-point register.
|
|
|
95
|
|
|
96 IV_Isf : aliased Byte4; -- Initialize short float
|
|
|
97 IV_Ifl : aliased Byte4; -- Initialize float
|
|
|
98 IV_Ilf : aliased ByteLF; -- Initialize long float
|
|
|
99 IV_Ill : aliased ByteLLF; -- Initialize long long float
|
|
|
100
|
|
|
101 for IV_Isf'Address use IS_Isf'Address;
|
|
|
102 for IV_Ifl'Address use IS_Ifl'Address;
|
|
|
103 for IV_Ilf'Address use IS_Ilf'Address;
|
|
|
104 for IV_Ill'Address use IS_Ill'Address;
|
|
|
105
|
|
|
106 -- The following pragmas are used to suppress initialization
|
|
|
107
|
|
|
108 pragma Import (Ada, IV_Isf);
|
|
|
109 pragma Import (Ada, IV_Ifl);
|
|
|
110 pragma Import (Ada, IV_Ilf);
|
|
|
111 pragma Import (Ada, IV_Ill);
|
|
|
112
|
|
|
113 begin
|
|
|
114 -- Acquire environment variable value if necessary
|
|
|
115
|
|
|
116 if C1 = 'E' and then C2 = 'V' then
|
|
|
117 Get_Env_Value_Ptr
|
|
|
118 (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
|
|
|
119
|
|
|
120 -- Ignore if length is not 2
|
|
|
121
|
|
|
122 if Env_Value_Length /= 2 then
|
|
|
123 C1 := 'I';
|
|
|
124 C2 := 'N';
|
|
|
125
|
|
|
126 -- Length is 2, see if it is a valid value
|
|
|
127
|
|
|
128 else
|
|
|
129 -- Acquire two characters and fold to upper case
|
|
|
130
|
|
|
131 C1 := Env_Value_Ptr (1);
|
|
|
132 C2 := Env_Value_Ptr (2);
|
|
|
133
|
|
|
134 if C1 in 'a' .. 'z' then
|
|
|
135 C1 := Character'Val (Character'Pos (C1) - 32);
|
|
|
136 end if;
|
|
|
137
|
|
|
138 if C2 in 'a' .. 'z' then
|
|
|
139 C2 := Character'Val (Character'Pos (C2) - 32);
|
|
|
140 end if;
|
|
|
141
|
|
|
142 -- IN/LO/HI are ok values
|
|
|
143
|
|
|
144 if (C1 = 'I' and then C2 = 'N')
|
|
|
145 or else
|
|
|
146 (C1 = 'L' and then C2 = 'O')
|
|
|
147 or else
|
|
|
148 (C1 = 'H' and then C2 = 'I')
|
|
|
149 then
|
|
|
150 null;
|
|
|
151
|
|
|
152 -- Try for valid hex digits
|
|
|
153
|
|
|
154 elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
|
|
|
155 or else
|
|
|
156 (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
|
|
|
157 then
|
|
|
158 null;
|
|
|
159
|
|
|
160 -- Otherwise environment value is bad, ignore and use IN (invalid)
|
|
|
161
|
|
|
162 else
|
|
|
163 C1 := 'I';
|
|
|
164 C2 := 'N';
|
|
|
165 end if;
|
|
|
166 end if;
|
|
|
167 end if;
|
|
|
168
|
|
|
169 -- IN (invalid value)
|
|
|
170
|
|
|
171 if C1 = 'I' and then C2 = 'N' then
|
|
|
172 IS_Is1 := 16#80#;
|
|
|
173 IS_Is2 := 16#8000#;
|
|
|
174 IS_Is4 := 16#8000_0000#;
|
|
|
175 IS_Is8 := 16#8000_0000_0000_0000#;
|
|
|
176
|
|
|
177 IS_Iu1 := 16#FF#;
|
|
|
178 IS_Iu2 := 16#FFFF#;
|
|
|
179 IS_Iu4 := 16#FFFF_FFFF#;
|
|
|
180 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
|
|
|
181
|
|
|
182 IS_Iz1 := 16#00#;
|
|
|
183 IS_Iz2 := 16#0000#;
|
|
|
184 IS_Iz4 := 16#0000_0000#;
|
|
|
185 IS_Iz8 := 16#0000_0000_0000_0000#;
|
|
|
186
|
|
|
187 if AFloat then
|
|
|
188 IV_Isf := 16#FFFF_FF00#;
|
|
|
189 IV_Ifl := 16#FFFF_FF00#;
|
|
|
190 IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#);
|
|
|
191
|
|
|
192 else
|
|
|
193 IV_Isf := IS_Iu4;
|
|
|
194 IV_Ifl := IS_Iu4;
|
|
|
195 IV_Ilf := To_ByteLF (IS_Iu8);
|
|
|
196 end if;
|
|
|
197
|
|
|
198 if EFloat then
|
|
|
199 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
|
|
|
200 end if;
|
|
|
201
|
|
|
202 -- LO (Low values)
|
|
|
203
|
|
|
204 elsif C1 = 'L' and then C2 = 'O' then
|
|
|
205 IS_Is1 := 16#80#;
|
|
|
206 IS_Is2 := 16#8000#;
|
|
|
207 IS_Is4 := 16#8000_0000#;
|
|
|
208 IS_Is8 := 16#8000_0000_0000_0000#;
|
|
|
209
|
|
|
210 IS_Iu1 := 16#00#;
|
|
|
211 IS_Iu2 := 16#0000#;
|
|
|
212 IS_Iu4 := 16#0000_0000#;
|
|
|
213 IS_Iu8 := 16#0000_0000_0000_0000#;
|
|
|
214
|
|
|
215 IS_Iz1 := 16#00#;
|
|
|
216 IS_Iz2 := 16#0000#;
|
|
|
217 IS_Iz4 := 16#0000_0000#;
|
|
|
218 IS_Iz8 := 16#0000_0000_0000_0000#;
|
|
|
219
|
|
|
220 if AFloat then
|
|
|
221 IV_Isf := 16#0000_0001#;
|
|
|
222 IV_Ifl := 16#0000_0001#;
|
|
|
223 IV_Ilf := (1, 0, 0, 0, 0, 0);
|
|
|
224
|
|
|
225 else
|
|
|
226 IV_Isf := 16#FF80_0000#;
|
|
|
227 IV_Ifl := 16#FF80_0000#;
|
|
|
228 IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#);
|
|
|
229 end if;
|
|
|
230
|
|
|
231 if EFloat then
|
|
|
232 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
|
|
|
233 end if;
|
|
|
234
|
|
|
235 -- HI (High values)
|
|
|
236
|
|
|
237 elsif C1 = 'H' and then C2 = 'I' then
|
|
|
238 IS_Is1 := 16#7F#;
|
|
|
239 IS_Is2 := 16#7FFF#;
|
|
|
240 IS_Is4 := 16#7FFF_FFFF#;
|
|
|
241 IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
|
|
|
242
|
|
|
243 IS_Iu1 := 16#FF#;
|
|
|
244 IS_Iu2 := 16#FFFF#;
|
|
|
245 IS_Iu4 := 16#FFFF_FFFF#;
|
|
|
246 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
|
|
|
247
|
|
|
248 IS_Iz1 := 16#FF#;
|
|
|
249 IS_Iz2 := 16#FFFF#;
|
|
|
250 IS_Iz4 := 16#FFFF_FFFF#;
|
|
|
251 IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
|
|
|
252
|
|
|
253 if AFloat then
|
|
|
254 IV_Isf := 16#7FFF_FFFF#;
|
|
|
255 IV_Ifl := 16#7FFF_FFFF#;
|
|
|
256 IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#);
|
|
|
257
|
|
|
258 else
|
|
|
259 IV_Isf := 16#7F80_0000#;
|
|
|
260 IV_Ifl := 16#7F80_0000#;
|
|
|
261 IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#);
|
|
|
262 end if;
|
|
|
263
|
|
|
264 if EFloat then
|
|
|
265 IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
|
|
|
266 end if;
|
|
|
267
|
|
|
268 -- -Shh (hex byte)
|
|
|
269
|
|
|
270 else
|
|
|
271 -- Convert the two hex digits (we know they are valid here)
|
|
|
272
|
|
|
273 B := 16 * (Character'Pos (C1)
|
|
|
274 - (if C1 in '0' .. '9'
|
|
|
275 then Character'Pos ('0')
|
|
|
276 else Character'Pos ('A') - 10))
|
|
|
277 + (Character'Pos (C2)
|
|
|
278 - (if C2 in '0' .. '9'
|
|
|
279 then Character'Pos ('0')
|
|
|
280 else Character'Pos ('A') - 10));
|
|
|
281
|
|
|
282 -- Initialize data values from the hex value
|
|
|
283
|
|
|
284 IS_Is1 := B;
|
|
|
285 IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1);
|
|
|
286 IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
|
|
|
287 IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
|
|
|
288
|
|
|
289 IS_Iu1 := IS_Is1;
|
|
|
290 IS_Iu2 := IS_Is2;
|
|
|
291 IS_Iu4 := IS_Is4;
|
|
|
292 IS_Iu8 := IS_Is8;
|
|
|
293
|
|
|
294 IS_Iz1 := IS_Is1;
|
|
|
295 IS_Iz2 := IS_Is2;
|
|
|
296 IS_Iz4 := IS_Is4;
|
|
|
297 IS_Iz8 := IS_Is8;
|
|
|
298
|
|
|
299 IV_Isf := IS_Is4;
|
|
|
300 IV_Ifl := IS_Is4;
|
|
|
301
|
|
|
302 if AFloat then
|
|
|
303 IV_Ill := (B, B, B, B, B, B);
|
|
|
304 else
|
|
|
305 IV_Ilf := To_ByteLF (IS_Is8);
|
|
|
306 end if;
|
|
|
307
|
|
|
308 if EFloat then
|
|
|
309 IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
|
|
|
310 end if;
|
|
|
311 end if;
|
|
|
312
|
|
|
313 -- If no separate Long_Long_Float, then use Long_Float value as
|
|
|
314 -- Long_Long_Float initial value.
|
|
|
315
|
|
|
316 if not EFloat then
|
|
|
317 declare
|
|
|
318 pragma Warnings (Off); -- why???
|
|
|
319 function To_ByteLLF is
|
|
|
320 new Ada.Unchecked_Conversion (ByteLF, ByteLLF);
|
|
|
321 pragma Warnings (On);
|
|
|
322 begin
|
|
|
323 IV_Ill := To_ByteLLF (IV_Ilf);
|
|
|
324 end;
|
|
|
325 end if;
|
|
|
326 end Initialize;
|
|
|
327
|
|
|
328 end System.Scalar_Values;
|
