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