1------------------------------------------------------------------------------
2--                                                                          --
3--                          GNAT RUNTIME 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 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34with Unchecked_Conversion;
35
36package body System.Scalar_Values is
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_get_env_value_ptr");
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      type ByteLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
64      --  Type used to initialize Long_Long_Float values used on x86 and
65      --  any other target with the same 80-bit floating-point values that
66      --  GCC always stores in 96-bits. Note that we are assuming Intel
67      --  format little-endian addressing for this type. On non-Intel
68      --  architectures, this is the same length as Byte8 and holds
69      --  a Long_Float value.
70
71      --  The following variables are used to initialize the float values
72      --  by overlay. We can't assign directly to the float values, since
73      --  we may be assigning signalling Nan's that will cause a trap if
74      --  loaded into a floating-point register.
75
76      IV_Isf : aliased Byte4;     -- Initialize short float
77      IV_Ifl : aliased Byte4;     -- Initialize float
78      IV_Ilf : aliased Byte8;     -- Initialize long float
79      IV_Ill : aliased ByteLF;    -- Initialize long long float
80
81      for IV_Isf'Address use IS_Isf'Address;
82      for IV_Ifl'Address use IS_Ifl'Address;
83      for IV_Ilf'Address use IS_Ilf'Address;
84      for IV_Ill'Address use IS_Ill'Address;
85
86      --  The following pragmas are used to suppress initialization
87
88      pragma Import (Ada, IV_Isf);
89      pragma Import (Ada, IV_Ifl);
90      pragma Import (Ada, IV_Ilf);
91      pragma Import (Ada, IV_Ill);
92
93   begin
94      --  Acquire environment variable value if necessary
95
96      if C1 = 'E' and then C2 = 'V' then
97         Get_Env_Value_Ptr
98           (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
99
100         --  Ignore if length is not 2
101
102         if Env_Value_Length /= 2 then
103            C1 := 'I';
104            C2 := 'N';
105
106         --  Length is 2, see if it is a valid value
107
108         else
109            --  Acquire two characters and fold to upper case
110
111            C1 := Env_Value_Ptr (1);
112            C2 := Env_Value_Ptr (2);
113
114            if C1 in 'a' .. 'z' then
115               C1 := Character'Val (Character'Pos (C1) - 32);
116            end if;
117
118            if C2 in 'a' .. 'z' then
119               C2 := Character'Val (Character'Pos (C2) - 32);
120            end if;
121
122            --  IN/LO/HI are ok values
123
124            if (C1 = 'I' and then C2 = 'N')
125                  or else
126               (C1 = 'L' and then C2 = 'O')
127                  or else
128               (C1 = 'H' and then C2 = 'I')
129            then
130               null;
131
132            --  Try for valid hex digits
133
134            elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
135                     or else
136                  (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
137            then
138               null;
139
140            --  Otherwise environment value is bad, ignore and use IN (invalid)
141
142            else
143               C1 := 'I';
144               C2 := 'N';
145            end if;
146         end if;
147      end if;
148
149      --  IN (invalid value)
150
151      if C1 = 'I' and then C2 = 'N' then
152         IS_Is1 := 16#80#;
153         IS_Is2 := 16#8000#;
154         IS_Is4 := 16#8000_0000#;
155         IS_Is8 := 16#8000_0000_0000_0000#;
156
157         IS_Iu1 := 16#FF#;
158         IS_Iu2 := 16#FFFF#;
159         IS_Iu4 := 16#FFFF_FFFF#;
160         IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
161
162         IV_Isf := IS_Iu4;
163         IV_Ifl := IS_Iu4;
164         IV_Ilf := IS_Iu8;
165
166         if EFloat then
167            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
168         end if;
169
170      --  LO (Low values)
171
172      elsif C1 = 'L' and then C2 = 'O' then
173         IS_Is1 := 16#80#;
174         IS_Is2 := 16#8000#;
175         IS_Is4 := 16#8000_0000#;
176         IS_Is8 := 16#8000_0000_0000_0000#;
177
178         IS_Iu1 := 16#00#;
179         IS_Iu2 := 16#0000#;
180         IS_Iu4 := 16#0000_0000#;
181         IS_Iu8 := 16#0000_0000_0000_0000#;
182
183         IV_Isf := 16#FF80_0000#;
184         IV_Ifl := 16#FF80_0000#;
185         IV_Ilf := 16#FFF0_0000_0000_0000#;
186
187         if EFloat then
188            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
189         end if;
190
191      --  HI (High values)
192
193      elsif C1 = 'H' and then C2 = 'I' then
194         IS_Is1 := 16#7F#;
195         IS_Is2 := 16#7FFF#;
196         IS_Is4 := 16#7FFF_FFFF#;
197         IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
198
199         IS_Iu1 := 16#FF#;
200         IS_Iu2 := 16#FFFF#;
201         IS_Iu4 := 16#FFFF_FFFF#;
202         IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
203
204         IV_Isf := 16#7F80_0000#;
205         IV_Ifl := 16#7F80_0000#;
206         IV_Ilf := 16#7FF0_0000_0000_0000#;
207
208         if EFloat then
209            IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
210         end if;
211
212      --  -Shh (hex byte)
213
214      else
215         --  Convert the two hex digits (we know they are valid here)
216
217         if C1 in '0' .. '9' then
218            B := Character'Pos (C1) - Character'Pos ('0');
219         else
220            B := Character'Pos (C1) - (Character'Pos ('A') - 10);
221         end if;
222
223         if C2 in '0' .. '9' then
224            B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
225         else
226            B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
227         end if;
228
229         --  Initialize data values from the hex value
230
231         IS_Is1 := B;
232         IS_Is2 := 2**8  * Byte2 (IS_Is1) + Byte2 (IS_Is1);
233         IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
234         IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
235
236         IS_Iu1 := IS_Is1;
237         IS_Iu2 := IS_Is2;
238         IS_Iu4 := IS_Is4;
239         IS_Iu8 := IS_Is8;
240
241         IV_Isf := IS_Is4;
242         IV_Ifl := IS_Is4;
243         IV_Ilf := IS_Is8;
244
245         if EFloat then
246            IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
247         end if;
248      end if;
249
250      --  If no separate Long_Long_Float, then use Long_Float value as
251      --  Long_Long_Float initial value.
252
253      if not EFloat then
254         declare
255            pragma Warnings (Off);
256            function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF);
257            pragma Warnings (On);
258         begin
259            IV_Ill := To_ByteLF (IV_Ilf);
260         end;
261      end if;
262
263
264   end Initialize;
265
266end System.Scalar_Values;
267