gcc/
[official-gcc.git] / gcc / ada / s-scaval.adb
blob632e30e4b01bd7d514899f9083fbbd9af35ffd49
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 -- --
9 -- Copyright (C) 2003-2009, Free Software Foundation, Inc. --
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 ------------------------------------------------------------------------------
32 with Ada.Unchecked_Conversion;
34 package body System.Scalar_Values is
36 ----------------
37 -- Initialize --
38 ----------------
40 procedure Initialize (Mode1 : Character; Mode2 : Character) is
41 C1 : Character := Mode1;
42 C2 : Character := Mode2;
44 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
45 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
47 subtype String2 is String (1 .. 2);
48 type String2_Ptr is access all String2;
50 Env_Value_Ptr : aliased String2_Ptr;
51 Env_Value_Length : aliased Integer;
53 EV_Val : aliased constant String :=
54 "GNAT_INIT_SCALARS" & ASCII.NUL;
56 B : Byte1;
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
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
65 type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1;
67 for ByteLF'Component_Size use 8;
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.
74 pragma Warnings (Off); -- why ???
75 function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF);
76 pragma Warnings (On);
78 type ByteLLF is
79 array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat))
80 of Byte1;
82 for ByteLLF'Component_Size use 8;
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.
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.
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
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;
106 -- The following pragmas are used to suppress initialization
108 pragma Import (Ada, IV_Isf);
109 pragma Import (Ada, IV_Ifl);
110 pragma Import (Ada, IV_Ilf);
111 pragma Import (Ada, IV_Ill);
113 begin
114 -- Acquire environment variable value if necessary
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);
120 -- Ignore if length is not 2
122 if Env_Value_Length /= 2 then
123 C1 := 'I';
124 C2 := 'N';
126 -- Length is 2, see if it is a valid value
128 else
129 -- Acquire two characters and fold to upper case
131 C1 := Env_Value_Ptr (1);
132 C2 := Env_Value_Ptr (2);
134 if C1 in 'a' .. 'z' then
135 C1 := Character'Val (Character'Pos (C1) - 32);
136 end if;
138 if C2 in 'a' .. 'z' then
139 C2 := Character'Val (Character'Pos (C2) - 32);
140 end if;
142 -- IN/LO/HI are ok values
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;
152 -- Try for valid hex digits
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;
160 -- Otherwise environment value is bad, ignore and use IN (invalid)
162 else
163 C1 := 'I';
164 C2 := 'N';
165 end if;
166 end if;
167 end if;
169 -- IN (invalid value)
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#;
177 IS_Iu1 := 16#FF#;
178 IS_Iu2 := 16#FFFF#;
179 IS_Iu4 := 16#FFFF_FFFF#;
180 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
182 IS_Iz1 := 16#00#;
183 IS_Iz2 := 16#0000#;
184 IS_Iz4 := 16#0000_0000#;
185 IS_Iz8 := 16#0000_0000_0000_0000#;
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#);
192 else
193 IV_Isf := IS_Iu4;
194 IV_Ifl := IS_Iu4;
195 IV_Ilf := To_ByteLF (IS_Iu8);
196 end if;
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;
202 -- LO (Low values)
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#;
210 IS_Iu1 := 16#00#;
211 IS_Iu2 := 16#0000#;
212 IS_Iu4 := 16#0000_0000#;
213 IS_Iu8 := 16#0000_0000_0000_0000#;
215 IS_Iz1 := 16#00#;
216 IS_Iz2 := 16#0000#;
217 IS_Iz4 := 16#0000_0000#;
218 IS_Iz8 := 16#0000_0000_0000_0000#;
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);
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;
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;
235 -- HI (High values)
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#;
243 IS_Iu1 := 16#FF#;
244 IS_Iu2 := 16#FFFF#;
245 IS_Iu4 := 16#FFFF_FFFF#;
246 IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
248 IS_Iz1 := 16#FF#;
249 IS_Iz2 := 16#FFFF#;
250 IS_Iz4 := 16#FFFF_FFFF#;
251 IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#;
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#);
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;
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;
268 -- -Shh (hex byte)
270 else
271 -- Convert the two hex digits (we know they are valid here)
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));
282 -- Initialize data values from the hex value
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);
289 IS_Iu1 := IS_Is1;
290 IS_Iu2 := IS_Is2;
291 IS_Iu4 := IS_Is4;
292 IS_Iu8 := IS_Is8;
294 IS_Iz1 := IS_Is1;
295 IS_Iz2 := IS_Is2;
296 IS_Iz4 := IS_Is4;
297 IS_Iz8 := IS_Is8;
299 IV_Isf := IS_Is4;
300 IV_Ifl := IS_Is4;
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;
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;
313 -- If no separate Long_Long_Float, then use Long_Float value as
314 -- Long_Long_Float initial value.
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;
328 end System.Scalar_Values;