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-2018, 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------------------------------------------------------------------------------
31
32with Ada.Unchecked_Conversion;
33
34package 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
328end System.Scalar_Values;
329