|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . S T R E A M _ A T T R I B U T E S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1996-2017, Free Software Foundation, Inc. --
|
|
|
10 -- --
|
|
|
11 -- GARLIC 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 -- This file is an alternate version of s-stratt.adb based on the XDR
|
|
|
33 -- standard. It is especially useful for exchanging streams between two
|
|
|
34 -- different systems with different basic type representations and endianness.
|
|
|
35
|
|
|
36 pragma Warnings (Off, "*not allowed in compiler unit");
|
|
|
37 -- This body is used only when rebuilding the runtime library, not when
|
|
|
38 -- building the compiler, so it's OK to depend on features that would
|
|
|
39 -- otherwise break bootstrap (e.g. IF-expressions).
|
|
|
40
|
|
|
41 with Ada.IO_Exceptions;
|
|
|
42 with Ada.Streams; use Ada.Streams;
|
|
|
43 with Ada.Unchecked_Conversion;
|
|
|
44
|
|
|
45 package body System.Stream_Attributes is
|
|
|
46
|
|
|
47 pragma Suppress (Range_Check);
|
|
|
48 pragma Suppress (Overflow_Check);
|
|
|
49
|
|
|
50 use UST;
|
|
|
51
|
|
|
52 Data_Error : exception renames Ada.IO_Exceptions.End_Error;
|
|
|
53 -- Exception raised if insufficient data read (End_Error is mandated by
|
|
|
54 -- AI95-00132).
|
|
|
55
|
|
|
56 SU : constant := System.Storage_Unit;
|
|
|
57 -- The code in this body assumes that SU = 8
|
|
|
58
|
|
|
59 BB : constant := 2 ** SU; -- Byte base
|
|
|
60 BL : constant := 2 ** SU - 1; -- Byte last
|
|
|
61 BS : constant := 2 ** (SU - 1); -- Byte sign
|
|
|
62
|
|
|
63 US : constant := Unsigned'Size; -- Unsigned size
|
|
|
64 UB : constant := (US - 1) / SU + 1; -- Unsigned byte
|
|
|
65 UL : constant := 2 ** US - 1; -- Unsigned last
|
|
|
66
|
|
|
67 subtype SE is Ada.Streams.Stream_Element;
|
|
|
68 subtype SEA is Ada.Streams.Stream_Element_Array;
|
|
|
69 subtype SEO is Ada.Streams.Stream_Element_Offset;
|
|
|
70
|
|
|
71 generic function UC renames Ada.Unchecked_Conversion;
|
|
|
72
|
|
|
73 type Field_Type is
|
|
|
74 record
|
|
|
75 E_Size : Integer; -- Exponent bit size
|
|
|
76 E_Bias : Integer; -- Exponent bias
|
|
|
77 F_Size : Integer; -- Fraction bit size
|
|
|
78 E_Last : Integer; -- Max exponent value
|
|
|
79 F_Mask : SE; -- Mask to apply on first fraction byte
|
|
|
80 E_Bytes : SEO; -- N. of exponent bytes completely used
|
|
|
81 F_Bytes : SEO; -- N. of fraction bytes completely used
|
|
|
82 F_Bits : Integer; -- N. of bits used on first fraction word
|
|
|
83 end record;
|
|
|
84
|
|
|
85 type Precision is (Single, Double, Quadruple);
|
|
|
86
|
|
|
87 Fields : constant array (Precision) of Field_Type := (
|
|
|
88
|
|
|
89 -- Single precision
|
|
|
90
|
|
|
91 (E_Size => 8,
|
|
|
92 E_Bias => 127,
|
|
|
93 F_Size => 23,
|
|
|
94 E_Last => 2 ** 8 - 1,
|
|
|
95 F_Mask => 16#7F#, -- 2 ** 7 - 1,
|
|
|
96 E_Bytes => 2,
|
|
|
97 F_Bytes => 3,
|
|
|
98 F_Bits => 23 mod US),
|
|
|
99
|
|
|
100 -- Double precision
|
|
|
101
|
|
|
102 (E_Size => 11,
|
|
|
103 E_Bias => 1023,
|
|
|
104 F_Size => 52,
|
|
|
105 E_Last => 2 ** 11 - 1,
|
|
|
106 F_Mask => 16#0F#, -- 2 ** 4 - 1,
|
|
|
107 E_Bytes => 2,
|
|
|
108 F_Bytes => 7,
|
|
|
109 F_Bits => 52 mod US),
|
|
|
110
|
|
|
111 -- Quadruple precision
|
|
|
112
|
|
|
113 (E_Size => 15,
|
|
|
114 E_Bias => 16383,
|
|
|
115 F_Size => 112,
|
|
|
116 E_Last => 2 ** 8 - 1,
|
|
|
117 F_Mask => 16#FF#, -- 2 ** 8 - 1,
|
|
|
118 E_Bytes => 2,
|
|
|
119 F_Bytes => 14,
|
|
|
120 F_Bits => 112 mod US));
|
|
|
121
|
|
|
122 -- The representation of all items requires a multiple of four bytes
|
|
|
123 -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes
|
|
|
124 -- are read or written to some byte stream such that byte m always
|
|
|
125 -- precedes byte m+1. If the n bytes needed to contain the data are not
|
|
|
126 -- a multiple of four, then the n bytes are followed by enough (0 to 3)
|
|
|
127 -- residual zero bytes, r, to make the total byte count a multiple of 4.
|
|
|
128
|
|
|
129 -- An XDR signed integer is a 32-bit datum that encodes an integer
|
|
|
130 -- in the range [-2147483648,2147483647]. The integer is represented
|
|
|
131 -- in two's complement notation. The most and least significant bytes
|
|
|
132 -- are 0 and 3, respectively. Integers are declared as follows:
|
|
|
133
|
|
|
134 -- (MSB) (LSB)
|
|
|
135 -- +-------+-------+-------+-------+
|
|
|
136 -- |byte 0 |byte 1 |byte 2 |byte 3 |
|
|
|
137 -- +-------+-------+-------+-------+
|
|
|
138 -- <------------32 bits------------>
|
|
|
139
|
|
|
140 SSI_L : constant := 1;
|
|
|
141 SI_L : constant := 2;
|
|
|
142 I_L : constant := 4;
|
|
|
143 LI_L : constant := 8;
|
|
|
144 LLI_L : constant := 8;
|
|
|
145
|
|
|
146 subtype XDR_S_SSI is SEA (1 .. SSI_L);
|
|
|
147 subtype XDR_S_SI is SEA (1 .. SI_L);
|
|
|
148 subtype XDR_S_I is SEA (1 .. I_L);
|
|
|
149 subtype XDR_S_LI is SEA (1 .. LI_L);
|
|
|
150 subtype XDR_S_LLI is SEA (1 .. LLI_L);
|
|
|
151
|
|
|
152 function Short_Short_Integer_To_XDR_S_SSI is
|
|
|
153 new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
|
|
|
154 function XDR_S_SSI_To_Short_Short_Integer is
|
|
|
155 new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
|
|
|
156
|
|
|
157 function Short_Integer_To_XDR_S_SI is
|
|
|
158 new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
|
|
|
159 function XDR_S_SI_To_Short_Integer is
|
|
|
160 new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
|
|
|
161
|
|
|
162 function Integer_To_XDR_S_I is
|
|
|
163 new Ada.Unchecked_Conversion (Integer, XDR_S_I);
|
|
|
164 function XDR_S_I_To_Integer is
|
|
|
165 new Ada.Unchecked_Conversion (XDR_S_I, Integer);
|
|
|
166
|
|
|
167 function Long_Long_Integer_To_XDR_S_LI is
|
|
|
168 new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
|
|
|
169 function XDR_S_LI_To_Long_Long_Integer is
|
|
|
170 new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
|
|
|
171
|
|
|
172 function Long_Long_Integer_To_XDR_S_LLI is
|
|
|
173 new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
|
|
|
174 function XDR_S_LLI_To_Long_Long_Integer is
|
|
|
175 new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
|
|
|
176
|
|
|
177 -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
|
|
|
178 -- integer in the range [0,4294967295]. It is represented by an unsigned
|
|
|
179 -- binary number whose most and least significant bytes are 0 and 3,
|
|
|
180 -- respectively. An unsigned integer is declared as follows:
|
|
|
181
|
|
|
182 -- (MSB) (LSB)
|
|
|
183 -- +-------+-------+-------+-------+
|
|
|
184 -- |byte 0 |byte 1 |byte 2 |byte 3 |
|
|
|
185 -- +-------+-------+-------+-------+
|
|
|
186 -- <------------32 bits------------>
|
|
|
187
|
|
|
188 SSU_L : constant := 1;
|
|
|
189 SU_L : constant := 2;
|
|
|
190 U_L : constant := 4;
|
|
|
191 LU_L : constant := 8;
|
|
|
192 LLU_L : constant := 8;
|
|
|
193
|
|
|
194 subtype XDR_S_SSU is SEA (1 .. SSU_L);
|
|
|
195 subtype XDR_S_SU is SEA (1 .. SU_L);
|
|
|
196 subtype XDR_S_U is SEA (1 .. U_L);
|
|
|
197 subtype XDR_S_LU is SEA (1 .. LU_L);
|
|
|
198 subtype XDR_S_LLU is SEA (1 .. LLU_L);
|
|
|
199
|
|
|
200 type XDR_SSU is mod BB ** SSU_L;
|
|
|
201 type XDR_SU is mod BB ** SU_L;
|
|
|
202 type XDR_U is mod BB ** U_L;
|
|
|
203
|
|
|
204 function Short_Unsigned_To_XDR_S_SU is
|
|
|
205 new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
|
|
|
206 function XDR_S_SU_To_Short_Unsigned is
|
|
|
207 new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
|
|
|
208
|
|
|
209 function Unsigned_To_XDR_S_U is
|
|
|
210 new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
|
|
|
211 function XDR_S_U_To_Unsigned is
|
|
|
212 new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
|
|
|
213
|
|
|
214 function Long_Long_Unsigned_To_XDR_S_LU is
|
|
|
215 new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
|
|
|
216 function XDR_S_LU_To_Long_Long_Unsigned is
|
|
|
217 new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
|
|
|
218
|
|
|
219 function Long_Long_Unsigned_To_XDR_S_LLU is
|
|
|
220 new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
|
|
|
221 function XDR_S_LLU_To_Long_Long_Unsigned is
|
|
|
222 new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
|
|
|
223
|
|
|
224 -- The standard defines the floating-point data type "float" (32 bits
|
|
|
225 -- or 4 bytes). The encoding used is the IEEE standard for normalized
|
|
|
226 -- single-precision floating-point numbers.
|
|
|
227
|
|
|
228 -- The standard defines the encoding used for the double-precision
|
|
|
229 -- floating-point data type "double" (64 bits or 8 bytes). The encoding
|
|
|
230 -- used is the IEEE standard for normalized double-precision floating-point
|
|
|
231 -- numbers.
|
|
|
232
|
|
|
233 SF_L : constant := 4; -- Single precision
|
|
|
234 F_L : constant := 4; -- Single precision
|
|
|
235 LF_L : constant := 8; -- Double precision
|
|
|
236 LLF_L : constant := 16; -- Quadruple precision
|
|
|
237
|
|
|
238 TM_L : constant := 8;
|
|
|
239 subtype XDR_S_TM is SEA (1 .. TM_L);
|
|
|
240 type XDR_TM is mod BB ** TM_L;
|
|
|
241
|
|
|
242 type XDR_SA is mod 2 ** Standard'Address_Size;
|
|
|
243 function To_XDR_SA is new UC (System.Address, XDR_SA);
|
|
|
244 function To_XDR_SA is new UC (XDR_SA, System.Address);
|
|
|
245
|
|
|
246 -- Enumerations have the same representation as signed integers.
|
|
|
247 -- Enumerations are handy for describing subsets of the integers.
|
|
|
248
|
|
|
249 -- Booleans are important enough and occur frequently enough to warrant
|
|
|
250 -- their own explicit type in the standard. Booleans are declared as
|
|
|
251 -- an enumeration, with FALSE = 0 and TRUE = 1.
|
|
|
252
|
|
|
253 -- The standard defines a string of n (numbered 0 through n-1) ASCII
|
|
|
254 -- bytes to be the number n encoded as an unsigned integer (as described
|
|
|
255 -- above), and followed by the n bytes of the string. Byte m of the string
|
|
|
256 -- always precedes byte m+1 of the string, and byte 0 of the string always
|
|
|
257 -- follows the string's length. If n is not a multiple of four, then the
|
|
|
258 -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make
|
|
|
259 -- the total byte count a multiple of four.
|
|
|
260
|
|
|
261 -- To fit with XDR string, do not consider character as an enumeration
|
|
|
262 -- type.
|
|
|
263
|
|
|
264 C_L : constant := 1;
|
|
|
265 subtype XDR_S_C is SEA (1 .. C_L);
|
|
|
266
|
|
|
267 -- Consider Wide_Character as an enumeration type
|
|
|
268
|
|
|
269 WC_L : constant := 4;
|
|
|
270 subtype XDR_S_WC is SEA (1 .. WC_L);
|
|
|
271 type XDR_WC is mod BB ** WC_L;
|
|
|
272
|
|
|
273 -- Consider Wide_Wide_Character as an enumeration type
|
|
|
274
|
|
|
275 WWC_L : constant := 8;
|
|
|
276 subtype XDR_S_WWC is SEA (1 .. WWC_L);
|
|
|
277 type XDR_WWC is mod BB ** WWC_L;
|
|
|
278
|
|
|
279 -- Optimization: if we already have the correct Bit_Order, then some
|
|
|
280 -- computations can be avoided since the source and the target will be
|
|
|
281 -- identical anyway. They will be replaced by direct unchecked
|
|
|
282 -- conversions.
|
|
|
283
|
|
|
284 Optimize_Integers : constant Boolean :=
|
|
|
285 Default_Bit_Order = High_Order_First;
|
|
|
286
|
|
|
287 -----------------
|
|
|
288 -- Block_IO_OK --
|
|
|
289 -----------------
|
|
|
290
|
|
|
291 -- We must inhibit Block_IO, because in XDR mode, each element is output
|
|
|
292 -- according to XDR requirements, which is not at all the same as writing
|
|
|
293 -- the whole array in one block.
|
|
|
294
|
|
|
295 function Block_IO_OK return Boolean is
|
|
|
296 begin
|
|
|
297 return False;
|
|
|
298 end Block_IO_OK;
|
|
|
299
|
|
|
300 ----------
|
|
|
301 -- I_AD --
|
|
|
302 ----------
|
|
|
303
|
|
|
304 function I_AD (Stream : not null access RST) return Fat_Pointer is
|
|
|
305 FP : Fat_Pointer;
|
|
|
306
|
|
|
307 begin
|
|
|
308 FP.P1 := I_AS (Stream).P1;
|
|
|
309 FP.P2 := I_AS (Stream).P1;
|
|
|
310
|
|
|
311 return FP;
|
|
|
312 end I_AD;
|
|
|
313
|
|
|
314 ----------
|
|
|
315 -- I_AS --
|
|
|
316 ----------
|
|
|
317
|
|
|
318 function I_AS (Stream : not null access RST) return Thin_Pointer is
|
|
|
319 S : XDR_S_TM;
|
|
|
320 L : SEO;
|
|
|
321 U : XDR_TM := 0;
|
|
|
322
|
|
|
323 begin
|
|
|
324 Ada.Streams.Read (Stream.all, S, L);
|
|
|
325
|
|
|
326 if L /= S'Last then
|
|
|
327 raise Data_Error;
|
|
|
328
|
|
|
329 else
|
|
|
330 for N in S'Range loop
|
|
|
331 U := U * BB + XDR_TM (S (N));
|
|
|
332 end loop;
|
|
|
333
|
|
|
334 return (P1 => To_XDR_SA (XDR_SA (U)));
|
|
|
335 end if;
|
|
|
336 end I_AS;
|
|
|
337
|
|
|
338 ---------
|
|
|
339 -- I_B --
|
|
|
340 ---------
|
|
|
341
|
|
|
342 function I_B (Stream : not null access RST) return Boolean is
|
|
|
343 begin
|
|
|
344 case I_SSU (Stream) is
|
|
|
345 when 0 => return False;
|
|
|
346 when 1 => return True;
|
|
|
347 when others => raise Data_Error;
|
|
|
348 end case;
|
|
|
349 end I_B;
|
|
|
350
|
|
|
351 ---------
|
|
|
352 -- I_C --
|
|
|
353 ---------
|
|
|
354
|
|
|
355 function I_C (Stream : not null access RST) return Character is
|
|
|
356 S : XDR_S_C;
|
|
|
357 L : SEO;
|
|
|
358
|
|
|
359 begin
|
|
|
360 Ada.Streams.Read (Stream.all, S, L);
|
|
|
361
|
|
|
362 if L /= S'Last then
|
|
|
363 raise Data_Error;
|
|
|
364
|
|
|
365 else
|
|
|
366 -- Use Ada requirements on Character representation clause
|
|
|
367
|
|
|
368 return Character'Val (S (1));
|
|
|
369 end if;
|
|
|
370 end I_C;
|
|
|
371
|
|
|
372 ---------
|
|
|
373 -- I_F --
|
|
|
374 ---------
|
|
|
375
|
|
|
376 function I_F (Stream : not null access RST) return Float is
|
|
|
377 I : constant Precision := Single;
|
|
|
378 E_Size : Integer renames Fields (I).E_Size;
|
|
|
379 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
380 E_Last : Integer renames Fields (I).E_Last;
|
|
|
381 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
382 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
383 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
384 F_Size : Integer renames Fields (I).F_Size;
|
|
|
385
|
|
|
386 Is_Positive : Boolean;
|
|
|
387 Exponent : Long_Unsigned;
|
|
|
388 Fraction : Long_Unsigned;
|
|
|
389 Result : Float;
|
|
|
390 S : SEA (1 .. F_L);
|
|
|
391 L : SEO;
|
|
|
392
|
|
|
393 begin
|
|
|
394 Ada.Streams.Read (Stream.all, S, L);
|
|
|
395
|
|
|
396 if L /= S'Last then
|
|
|
397 raise Data_Error;
|
|
|
398 end if;
|
|
|
399
|
|
|
400 -- Extract Fraction, Sign and Exponent
|
|
|
401
|
|
|
402 Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);
|
|
|
403 for N in F_L + 2 - F_Bytes .. F_L loop
|
|
|
404 Fraction := Fraction * BB + Long_Unsigned (S (N));
|
|
|
405 end loop;
|
|
|
406 Result := Float'Scaling (Float (Fraction), -F_Size);
|
|
|
407
|
|
|
408 if BS <= S (1) then
|
|
|
409 Is_Positive := False;
|
|
|
410 Exponent := Long_Unsigned (S (1) - BS);
|
|
|
411 else
|
|
|
412 Is_Positive := True;
|
|
|
413 Exponent := Long_Unsigned (S (1));
|
|
|
414 end if;
|
|
|
415
|
|
|
416 for N in 2 .. E_Bytes loop
|
|
|
417 Exponent := Exponent * BB + Long_Unsigned (S (N));
|
|
|
418 end loop;
|
|
|
419 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
420
|
|
|
421 -- NaN or Infinities
|
|
|
422
|
|
|
423 if Integer (Exponent) = E_Last then
|
|
|
424 raise Constraint_Error;
|
|
|
425
|
|
|
426 elsif Exponent = 0 then
|
|
|
427
|
|
|
428 -- Signed zeros
|
|
|
429
|
|
|
430 if Fraction = 0 then
|
|
|
431 null;
|
|
|
432
|
|
|
433 -- Denormalized float
|
|
|
434
|
|
|
435 else
|
|
|
436 Result := Float'Scaling (Result, 1 - E_Bias);
|
|
|
437 end if;
|
|
|
438
|
|
|
439 -- Normalized float
|
|
|
440
|
|
|
441 else
|
|
|
442 Result := Float'Scaling
|
|
|
443 (1.0 + Result, Integer (Exponent) - E_Bias);
|
|
|
444 end if;
|
|
|
445
|
|
|
446 if not Is_Positive then
|
|
|
447 Result := -Result;
|
|
|
448 end if;
|
|
|
449
|
|
|
450 return Result;
|
|
|
451 end I_F;
|
|
|
452
|
|
|
453 ---------
|
|
|
454 -- I_I --
|
|
|
455 ---------
|
|
|
456
|
|
|
457 function I_I (Stream : not null access RST) return Integer is
|
|
|
458 S : XDR_S_I;
|
|
|
459 L : SEO;
|
|
|
460 U : XDR_U := 0;
|
|
|
461
|
|
|
462 begin
|
|
|
463 Ada.Streams.Read (Stream.all, S, L);
|
|
|
464
|
|
|
465 if L /= S'Last then
|
|
|
466 raise Data_Error;
|
|
|
467
|
|
|
468 elsif Optimize_Integers then
|
|
|
469 return XDR_S_I_To_Integer (S);
|
|
|
470
|
|
|
471 else
|
|
|
472 for N in S'Range loop
|
|
|
473 U := U * BB + XDR_U (S (N));
|
|
|
474 end loop;
|
|
|
475
|
|
|
476 -- Test sign and apply two complement notation
|
|
|
477
|
|
|
478 if S (1) < BL then
|
|
|
479 return Integer (U);
|
|
|
480
|
|
|
481 else
|
|
|
482 return Integer (-((XDR_U'Last xor U) + 1));
|
|
|
483 end if;
|
|
|
484 end if;
|
|
|
485 end I_I;
|
|
|
486
|
|
|
487 ----------
|
|
|
488 -- I_LF --
|
|
|
489 ----------
|
|
|
490
|
|
|
491 function I_LF (Stream : not null access RST) return Long_Float is
|
|
|
492 I : constant Precision := Double;
|
|
|
493 E_Size : Integer renames Fields (I).E_Size;
|
|
|
494 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
495 E_Last : Integer renames Fields (I).E_Last;
|
|
|
496 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
497 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
498 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
499 F_Size : Integer renames Fields (I).F_Size;
|
|
|
500
|
|
|
501 Is_Positive : Boolean;
|
|
|
502 Exponent : Long_Unsigned;
|
|
|
503 Fraction : Long_Long_Unsigned;
|
|
|
504 Result : Long_Float;
|
|
|
505 S : SEA (1 .. LF_L);
|
|
|
506 L : SEO;
|
|
|
507
|
|
|
508 begin
|
|
|
509 Ada.Streams.Read (Stream.all, S, L);
|
|
|
510
|
|
|
511 if L /= S'Last then
|
|
|
512 raise Data_Error;
|
|
|
513 end if;
|
|
|
514
|
|
|
515 -- Extract Fraction, Sign and Exponent
|
|
|
516
|
|
|
517 Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);
|
|
|
518 for N in LF_L + 2 - F_Bytes .. LF_L loop
|
|
|
519 Fraction := Fraction * BB + Long_Long_Unsigned (S (N));
|
|
|
520 end loop;
|
|
|
521
|
|
|
522 Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
|
|
|
523
|
|
|
524 if BS <= S (1) then
|
|
|
525 Is_Positive := False;
|
|
|
526 Exponent := Long_Unsigned (S (1) - BS);
|
|
|
527 else
|
|
|
528 Is_Positive := True;
|
|
|
529 Exponent := Long_Unsigned (S (1));
|
|
|
530 end if;
|
|
|
531
|
|
|
532 for N in 2 .. E_Bytes loop
|
|
|
533 Exponent := Exponent * BB + Long_Unsigned (S (N));
|
|
|
534 end loop;
|
|
|
535
|
|
|
536 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
537
|
|
|
538 -- NaN or Infinities
|
|
|
539
|
|
|
540 if Integer (Exponent) = E_Last then
|
|
|
541 raise Constraint_Error;
|
|
|
542
|
|
|
543 elsif Exponent = 0 then
|
|
|
544
|
|
|
545 -- Signed zeros
|
|
|
546
|
|
|
547 if Fraction = 0 then
|
|
|
548 null;
|
|
|
549
|
|
|
550 -- Denormalized float
|
|
|
551
|
|
|
552 else
|
|
|
553 Result := Long_Float'Scaling (Result, 1 - E_Bias);
|
|
|
554 end if;
|
|
|
555
|
|
|
556 -- Normalized float
|
|
|
557
|
|
|
558 else
|
|
|
559 Result := Long_Float'Scaling
|
|
|
560 (1.0 + Result, Integer (Exponent) - E_Bias);
|
|
|
561 end if;
|
|
|
562
|
|
|
563 if not Is_Positive then
|
|
|
564 Result := -Result;
|
|
|
565 end if;
|
|
|
566
|
|
|
567 return Result;
|
|
|
568 end I_LF;
|
|
|
569
|
|
|
570 ----------
|
|
|
571 -- I_LI --
|
|
|
572 ----------
|
|
|
573
|
|
|
574 function I_LI (Stream : not null access RST) return Long_Integer is
|
|
|
575 S : XDR_S_LI;
|
|
|
576 L : SEO;
|
|
|
577 U : Unsigned := 0;
|
|
|
578 X : Long_Unsigned := 0;
|
|
|
579
|
|
|
580 begin
|
|
|
581 Ada.Streams.Read (Stream.all, S, L);
|
|
|
582
|
|
|
583 if L /= S'Last then
|
|
|
584 raise Data_Error;
|
|
|
585
|
|
|
586 elsif Optimize_Integers then
|
|
|
587 return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));
|
|
|
588
|
|
|
589 else
|
|
|
590
|
|
|
591 -- Compute using machine unsigned
|
|
|
592 -- rather than long_long_unsigned
|
|
|
593
|
|
|
594 for N in S'Range loop
|
|
|
595 U := U * BB + Unsigned (S (N));
|
|
|
596
|
|
|
597 -- We have filled an unsigned
|
|
|
598
|
|
|
599 if N mod UB = 0 then
|
|
|
600 X := Shift_Left (X, US) + Long_Unsigned (U);
|
|
|
601 U := 0;
|
|
|
602 end if;
|
|
|
603 end loop;
|
|
|
604
|
|
|
605 -- Test sign and apply two complement notation
|
|
|
606
|
|
|
607 if S (1) < BL then
|
|
|
608 return Long_Integer (X);
|
|
|
609 else
|
|
|
610 return Long_Integer (-((Long_Unsigned'Last xor X) + 1));
|
|
|
611 end if;
|
|
|
612
|
|
|
613 end if;
|
|
|
614 end I_LI;
|
|
|
615
|
|
|
616 -----------
|
|
|
617 -- I_LLF --
|
|
|
618 -----------
|
|
|
619
|
|
|
620 function I_LLF (Stream : not null access RST) return Long_Long_Float is
|
|
|
621 I : constant Precision := Quadruple;
|
|
|
622 E_Size : Integer renames Fields (I).E_Size;
|
|
|
623 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
624 E_Last : Integer renames Fields (I).E_Last;
|
|
|
625 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
626 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
627 F_Size : Integer renames Fields (I).F_Size;
|
|
|
628
|
|
|
629 Is_Positive : Boolean;
|
|
|
630 Exponent : Long_Unsigned;
|
|
|
631 Fraction_1 : Long_Long_Unsigned := 0;
|
|
|
632 Fraction_2 : Long_Long_Unsigned := 0;
|
|
|
633 Result : Long_Long_Float;
|
|
|
634 HF : constant Natural := F_Size / 2;
|
|
|
635 S : SEA (1 .. LLF_L);
|
|
|
636 L : SEO;
|
|
|
637
|
|
|
638 begin
|
|
|
639 Ada.Streams.Read (Stream.all, S, L);
|
|
|
640
|
|
|
641 if L /= S'Last then
|
|
|
642 raise Data_Error;
|
|
|
643 end if;
|
|
|
644
|
|
|
645 -- Extract Fraction, Sign and Exponent
|
|
|
646
|
|
|
647 for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
|
|
|
648 Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));
|
|
|
649 end loop;
|
|
|
650
|
|
|
651 for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop
|
|
|
652 Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));
|
|
|
653 end loop;
|
|
|
654
|
|
|
655 Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);
|
|
|
656 Result := Long_Long_Float (Fraction_1) + Result;
|
|
|
657 Result := Long_Long_Float'Scaling (Result, HF - F_Size);
|
|
|
658
|
|
|
659 if BS <= S (1) then
|
|
|
660 Is_Positive := False;
|
|
|
661 Exponent := Long_Unsigned (S (1) - BS);
|
|
|
662 else
|
|
|
663 Is_Positive := True;
|
|
|
664 Exponent := Long_Unsigned (S (1));
|
|
|
665 end if;
|
|
|
666
|
|
|
667 for N in 2 .. E_Bytes loop
|
|
|
668 Exponent := Exponent * BB + Long_Unsigned (S (N));
|
|
|
669 end loop;
|
|
|
670
|
|
|
671 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
672
|
|
|
673 -- NaN or Infinities
|
|
|
674
|
|
|
675 if Integer (Exponent) = E_Last then
|
|
|
676 raise Constraint_Error;
|
|
|
677
|
|
|
678 elsif Exponent = 0 then
|
|
|
679
|
|
|
680 -- Signed zeros
|
|
|
681
|
|
|
682 if Fraction_1 = 0 and then Fraction_2 = 0 then
|
|
|
683 null;
|
|
|
684
|
|
|
685 -- Denormalized float
|
|
|
686
|
|
|
687 else
|
|
|
688 Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);
|
|
|
689 end if;
|
|
|
690
|
|
|
691 -- Normalized float
|
|
|
692
|
|
|
693 else
|
|
|
694 Result := Long_Long_Float'Scaling
|
|
|
695 (1.0 + Result, Integer (Exponent) - E_Bias);
|
|
|
696 end if;
|
|
|
697
|
|
|
698 if not Is_Positive then
|
|
|
699 Result := -Result;
|
|
|
700 end if;
|
|
|
701
|
|
|
702 return Result;
|
|
|
703 end I_LLF;
|
|
|
704
|
|
|
705 -----------
|
|
|
706 -- I_LLI --
|
|
|
707 -----------
|
|
|
708
|
|
|
709 function I_LLI (Stream : not null access RST) return Long_Long_Integer is
|
|
|
710 S : XDR_S_LLI;
|
|
|
711 L : SEO;
|
|
|
712 U : Unsigned := 0;
|
|
|
713 X : Long_Long_Unsigned := 0;
|
|
|
714
|
|
|
715 begin
|
|
|
716 Ada.Streams.Read (Stream.all, S, L);
|
|
|
717
|
|
|
718 if L /= S'Last then
|
|
|
719 raise Data_Error;
|
|
|
720
|
|
|
721 elsif Optimize_Integers then
|
|
|
722 return XDR_S_LLI_To_Long_Long_Integer (S);
|
|
|
723
|
|
|
724 else
|
|
|
725 -- Compute using machine unsigned for computing
|
|
|
726 -- rather than long_long_unsigned.
|
|
|
727
|
|
|
728 for N in S'Range loop
|
|
|
729 U := U * BB + Unsigned (S (N));
|
|
|
730
|
|
|
731 -- We have filled an unsigned
|
|
|
732
|
|
|
733 if N mod UB = 0 then
|
|
|
734 X := Shift_Left (X, US) + Long_Long_Unsigned (U);
|
|
|
735 U := 0;
|
|
|
736 end if;
|
|
|
737 end loop;
|
|
|
738
|
|
|
739 -- Test sign and apply two complement notation
|
|
|
740
|
|
|
741 if S (1) < BL then
|
|
|
742 return Long_Long_Integer (X);
|
|
|
743 else
|
|
|
744 return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));
|
|
|
745 end if;
|
|
|
746 end if;
|
|
|
747 end I_LLI;
|
|
|
748
|
|
|
749 -----------
|
|
|
750 -- I_LLU --
|
|
|
751 -----------
|
|
|
752
|
|
|
753 function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is
|
|
|
754 S : XDR_S_LLU;
|
|
|
755 L : SEO;
|
|
|
756 U : Unsigned := 0;
|
|
|
757 X : Long_Long_Unsigned := 0;
|
|
|
758
|
|
|
759 begin
|
|
|
760 Ada.Streams.Read (Stream.all, S, L);
|
|
|
761
|
|
|
762 if L /= S'Last then
|
|
|
763 raise Data_Error;
|
|
|
764
|
|
|
765 elsif Optimize_Integers then
|
|
|
766 return XDR_S_LLU_To_Long_Long_Unsigned (S);
|
|
|
767
|
|
|
768 else
|
|
|
769 -- Compute using machine unsigned
|
|
|
770 -- rather than long_long_unsigned.
|
|
|
771
|
|
|
772 for N in S'Range loop
|
|
|
773 U := U * BB + Unsigned (S (N));
|
|
|
774
|
|
|
775 -- We have filled an unsigned
|
|
|
776
|
|
|
777 if N mod UB = 0 then
|
|
|
778 X := Shift_Left (X, US) + Long_Long_Unsigned (U);
|
|
|
779 U := 0;
|
|
|
780 end if;
|
|
|
781 end loop;
|
|
|
782
|
|
|
783 return X;
|
|
|
784 end if;
|
|
|
785 end I_LLU;
|
|
|
786
|
|
|
787 ----------
|
|
|
788 -- I_LU --
|
|
|
789 ----------
|
|
|
790
|
|
|
791 function I_LU (Stream : not null access RST) return Long_Unsigned is
|
|
|
792 S : XDR_S_LU;
|
|
|
793 L : SEO;
|
|
|
794 U : Unsigned := 0;
|
|
|
795 X : Long_Unsigned := 0;
|
|
|
796
|
|
|
797 begin
|
|
|
798 Ada.Streams.Read (Stream.all, S, L);
|
|
|
799
|
|
|
800 if L /= S'Last then
|
|
|
801 raise Data_Error;
|
|
|
802
|
|
|
803 elsif Optimize_Integers then
|
|
|
804 return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S));
|
|
|
805
|
|
|
806 else
|
|
|
807 -- Compute using machine unsigned
|
|
|
808 -- rather than long_unsigned.
|
|
|
809
|
|
|
810 for N in S'Range loop
|
|
|
811 U := U * BB + Unsigned (S (N));
|
|
|
812
|
|
|
813 -- We have filled an unsigned
|
|
|
814
|
|
|
815 if N mod UB = 0 then
|
|
|
816 X := Shift_Left (X, US) + Long_Unsigned (U);
|
|
|
817 U := 0;
|
|
|
818 end if;
|
|
|
819 end loop;
|
|
|
820
|
|
|
821 return X;
|
|
|
822 end if;
|
|
|
823 end I_LU;
|
|
|
824
|
|
|
825 ----------
|
|
|
826 -- I_SF --
|
|
|
827 ----------
|
|
|
828
|
|
|
829 function I_SF (Stream : not null access RST) return Short_Float is
|
|
|
830 I : constant Precision := Single;
|
|
|
831 E_Size : Integer renames Fields (I).E_Size;
|
|
|
832 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
833 E_Last : Integer renames Fields (I).E_Last;
|
|
|
834 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
835 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
836 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
837 F_Size : Integer renames Fields (I).F_Size;
|
|
|
838
|
|
|
839 Exponent : Long_Unsigned;
|
|
|
840 Fraction : Long_Unsigned;
|
|
|
841 Is_Positive : Boolean;
|
|
|
842 Result : Short_Float;
|
|
|
843 S : SEA (1 .. SF_L);
|
|
|
844 L : SEO;
|
|
|
845
|
|
|
846 begin
|
|
|
847 Ada.Streams.Read (Stream.all, S, L);
|
|
|
848
|
|
|
849 if L /= S'Last then
|
|
|
850 raise Data_Error;
|
|
|
851 end if;
|
|
|
852
|
|
|
853 -- Extract Fraction, Sign and Exponent
|
|
|
854
|
|
|
855 Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask);
|
|
|
856 for N in SF_L + 2 - F_Bytes .. SF_L loop
|
|
|
857 Fraction := Fraction * BB + Long_Unsigned (S (N));
|
|
|
858 end loop;
|
|
|
859 Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
|
|
|
860
|
|
|
861 if BS <= S (1) then
|
|
|
862 Is_Positive := False;
|
|
|
863 Exponent := Long_Unsigned (S (1) - BS);
|
|
|
864 else
|
|
|
865 Is_Positive := True;
|
|
|
866 Exponent := Long_Unsigned (S (1));
|
|
|
867 end if;
|
|
|
868
|
|
|
869 for N in 2 .. E_Bytes loop
|
|
|
870 Exponent := Exponent * BB + Long_Unsigned (S (N));
|
|
|
871 end loop;
|
|
|
872 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
873
|
|
|
874 -- NaN or Infinities
|
|
|
875
|
|
|
876 if Integer (Exponent) = E_Last then
|
|
|
877 raise Constraint_Error;
|
|
|
878
|
|
|
879 elsif Exponent = 0 then
|
|
|
880
|
|
|
881 -- Signed zeros
|
|
|
882
|
|
|
883 if Fraction = 0 then
|
|
|
884 null;
|
|
|
885
|
|
|
886 -- Denormalized float
|
|
|
887
|
|
|
888 else
|
|
|
889 Result := Short_Float'Scaling (Result, 1 - E_Bias);
|
|
|
890 end if;
|
|
|
891
|
|
|
892 -- Normalized float
|
|
|
893
|
|
|
894 else
|
|
|
895 Result := Short_Float'Scaling
|
|
|
896 (1.0 + Result, Integer (Exponent) - E_Bias);
|
|
|
897 end if;
|
|
|
898
|
|
|
899 if not Is_Positive then
|
|
|
900 Result := -Result;
|
|
|
901 end if;
|
|
|
902
|
|
|
903 return Result;
|
|
|
904 end I_SF;
|
|
|
905
|
|
|
906 ----------
|
|
|
907 -- I_SI --
|
|
|
908 ----------
|
|
|
909
|
|
|
910 function I_SI (Stream : not null access RST) return Short_Integer is
|
|
|
911 S : XDR_S_SI;
|
|
|
912 L : SEO;
|
|
|
913 U : XDR_SU := 0;
|
|
|
914
|
|
|
915 begin
|
|
|
916 Ada.Streams.Read (Stream.all, S, L);
|
|
|
917
|
|
|
918 if L /= S'Last then
|
|
|
919 raise Data_Error;
|
|
|
920
|
|
|
921 elsif Optimize_Integers then
|
|
|
922 return XDR_S_SI_To_Short_Integer (S);
|
|
|
923
|
|
|
924 else
|
|
|
925 for N in S'Range loop
|
|
|
926 U := U * BB + XDR_SU (S (N));
|
|
|
927 end loop;
|
|
|
928
|
|
|
929 -- Test sign and apply two complement notation
|
|
|
930
|
|
|
931 if S (1) < BL then
|
|
|
932 return Short_Integer (U);
|
|
|
933 else
|
|
|
934 return Short_Integer (-((XDR_SU'Last xor U) + 1));
|
|
|
935 end if;
|
|
|
936 end if;
|
|
|
937 end I_SI;
|
|
|
938
|
|
|
939 -----------
|
|
|
940 -- I_SSI --
|
|
|
941 -----------
|
|
|
942
|
|
|
943 function I_SSI (Stream : not null access RST) return Short_Short_Integer is
|
|
|
944 S : XDR_S_SSI;
|
|
|
945 L : SEO;
|
|
|
946 U : XDR_SSU;
|
|
|
947
|
|
|
948 begin
|
|
|
949 Ada.Streams.Read (Stream.all, S, L);
|
|
|
950
|
|
|
951 if L /= S'Last then
|
|
|
952 raise Data_Error;
|
|
|
953
|
|
|
954 elsif Optimize_Integers then
|
|
|
955 return XDR_S_SSI_To_Short_Short_Integer (S);
|
|
|
956
|
|
|
957 else
|
|
|
958 U := XDR_SSU (S (1));
|
|
|
959
|
|
|
960 -- Test sign and apply two complement notation
|
|
|
961
|
|
|
962 if S (1) < BL then
|
|
|
963 return Short_Short_Integer (U);
|
|
|
964 else
|
|
|
965 return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1));
|
|
|
966 end if;
|
|
|
967 end if;
|
|
|
968 end I_SSI;
|
|
|
969
|
|
|
970 -----------
|
|
|
971 -- I_SSU --
|
|
|
972 -----------
|
|
|
973
|
|
|
974 function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is
|
|
|
975 S : XDR_S_SSU;
|
|
|
976 L : SEO;
|
|
|
977 U : XDR_SSU := 0;
|
|
|
978
|
|
|
979 begin
|
|
|
980 Ada.Streams.Read (Stream.all, S, L);
|
|
|
981
|
|
|
982 if L /= S'Last then
|
|
|
983 raise Data_Error;
|
|
|
984
|
|
|
985 else
|
|
|
986 U := XDR_SSU (S (1));
|
|
|
987 return Short_Short_Unsigned (U);
|
|
|
988 end if;
|
|
|
989 end I_SSU;
|
|
|
990
|
|
|
991 ----------
|
|
|
992 -- I_SU --
|
|
|
993 ----------
|
|
|
994
|
|
|
995 function I_SU (Stream : not null access RST) return Short_Unsigned is
|
|
|
996 S : XDR_S_SU;
|
|
|
997 L : SEO;
|
|
|
998 U : XDR_SU := 0;
|
|
|
999
|
|
|
1000 begin
|
|
|
1001 Ada.Streams.Read (Stream.all, S, L);
|
|
|
1002
|
|
|
1003 if L /= S'Last then
|
|
|
1004 raise Data_Error;
|
|
|
1005
|
|
|
1006 elsif Optimize_Integers then
|
|
|
1007 return XDR_S_SU_To_Short_Unsigned (S);
|
|
|
1008
|
|
|
1009 else
|
|
|
1010 for N in S'Range loop
|
|
|
1011 U := U * BB + XDR_SU (S (N));
|
|
|
1012 end loop;
|
|
|
1013
|
|
|
1014 return Short_Unsigned (U);
|
|
|
1015 end if;
|
|
|
1016 end I_SU;
|
|
|
1017
|
|
|
1018 ---------
|
|
|
1019 -- I_U --
|
|
|
1020 ---------
|
|
|
1021
|
|
|
1022 function I_U (Stream : not null access RST) return Unsigned is
|
|
|
1023 S : XDR_S_U;
|
|
|
1024 L : SEO;
|
|
|
1025 U : XDR_U := 0;
|
|
|
1026
|
|
|
1027 begin
|
|
|
1028 Ada.Streams.Read (Stream.all, S, L);
|
|
|
1029
|
|
|
1030 if L /= S'Last then
|
|
|
1031 raise Data_Error;
|
|
|
1032
|
|
|
1033 elsif Optimize_Integers then
|
|
|
1034 return XDR_S_U_To_Unsigned (S);
|
|
|
1035
|
|
|
1036 else
|
|
|
1037 for N in S'Range loop
|
|
|
1038 U := U * BB + XDR_U (S (N));
|
|
|
1039 end loop;
|
|
|
1040
|
|
|
1041 return Unsigned (U);
|
|
|
1042 end if;
|
|
|
1043 end I_U;
|
|
|
1044
|
|
|
1045 ----------
|
|
|
1046 -- I_WC --
|
|
|
1047 ----------
|
|
|
1048
|
|
|
1049 function I_WC (Stream : not null access RST) return Wide_Character is
|
|
|
1050 S : XDR_S_WC;
|
|
|
1051 L : SEO;
|
|
|
1052 U : XDR_WC := 0;
|
|
|
1053
|
|
|
1054 begin
|
|
|
1055 Ada.Streams.Read (Stream.all, S, L);
|
|
|
1056
|
|
|
1057 if L /= S'Last then
|
|
|
1058 raise Data_Error;
|
|
|
1059
|
|
|
1060 else
|
|
|
1061 for N in S'Range loop
|
|
|
1062 U := U * BB + XDR_WC (S (N));
|
|
|
1063 end loop;
|
|
|
1064
|
|
|
1065 -- Use Ada requirements on Wide_Character representation clause
|
|
|
1066
|
|
|
1067 return Wide_Character'Val (U);
|
|
|
1068 end if;
|
|
|
1069 end I_WC;
|
|
|
1070
|
|
|
1071 -----------
|
|
|
1072 -- I_WWC --
|
|
|
1073 -----------
|
|
|
1074
|
|
|
1075 function I_WWC (Stream : not null access RST) return Wide_Wide_Character is
|
|
|
1076 S : XDR_S_WWC;
|
|
|
1077 L : SEO;
|
|
|
1078 U : XDR_WWC := 0;
|
|
|
1079
|
|
|
1080 begin
|
|
|
1081 Ada.Streams.Read (Stream.all, S, L);
|
|
|
1082
|
|
|
1083 if L /= S'Last then
|
|
|
1084 raise Data_Error;
|
|
|
1085
|
|
|
1086 else
|
|
|
1087 for N in S'Range loop
|
|
|
1088 U := U * BB + XDR_WWC (S (N));
|
|
|
1089 end loop;
|
|
|
1090
|
|
|
1091 -- Use Ada requirements on Wide_Wide_Character representation clause
|
|
|
1092
|
|
|
1093 return Wide_Wide_Character'Val (U);
|
|
|
1094 end if;
|
|
|
1095 end I_WWC;
|
|
|
1096
|
|
|
1097 ----------
|
|
|
1098 -- W_AD --
|
|
|
1099 ----------
|
|
|
1100
|
|
|
1101 procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
|
|
|
1102 S : XDR_S_TM;
|
|
|
1103 U : XDR_TM;
|
|
|
1104
|
|
|
1105 begin
|
|
|
1106 U := XDR_TM (To_XDR_SA (Item.P1));
|
|
|
1107 for N in reverse S'Range loop
|
|
|
1108 S (N) := SE (U mod BB);
|
|
|
1109 U := U / BB;
|
|
|
1110 end loop;
|
|
|
1111
|
|
|
1112 Ada.Streams.Write (Stream.all, S);
|
|
|
1113
|
|
|
1114 U := XDR_TM (To_XDR_SA (Item.P2));
|
|
|
1115 for N in reverse S'Range loop
|
|
|
1116 S (N) := SE (U mod BB);
|
|
|
1117 U := U / BB;
|
|
|
1118 end loop;
|
|
|
1119
|
|
|
1120 Ada.Streams.Write (Stream.all, S);
|
|
|
1121
|
|
|
1122 if U /= 0 then
|
|
|
1123 raise Data_Error;
|
|
|
1124 end if;
|
|
|
1125 end W_AD;
|
|
|
1126
|
|
|
1127 ----------
|
|
|
1128 -- W_AS --
|
|
|
1129 ----------
|
|
|
1130
|
|
|
1131 procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
|
|
|
1132 S : XDR_S_TM;
|
|
|
1133 U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
|
|
|
1134
|
|
|
1135 begin
|
|
|
1136 for N in reverse S'Range loop
|
|
|
1137 S (N) := SE (U mod BB);
|
|
|
1138 U := U / BB;
|
|
|
1139 end loop;
|
|
|
1140
|
|
|
1141 Ada.Streams.Write (Stream.all, S);
|
|
|
1142
|
|
|
1143 if U /= 0 then
|
|
|
1144 raise Data_Error;
|
|
|
1145 end if;
|
|
|
1146 end W_AS;
|
|
|
1147
|
|
|
1148 ---------
|
|
|
1149 -- W_B --
|
|
|
1150 ---------
|
|
|
1151
|
|
|
1152 procedure W_B (Stream : not null access RST; Item : Boolean) is
|
|
|
1153 begin
|
|
|
1154 if Item then
|
|
|
1155 W_SSU (Stream, 1);
|
|
|
1156 else
|
|
|
1157 W_SSU (Stream, 0);
|
|
|
1158 end if;
|
|
|
1159 end W_B;
|
|
|
1160
|
|
|
1161 ---------
|
|
|
1162 -- W_C --
|
|
|
1163 ---------
|
|
|
1164
|
|
|
1165 procedure W_C (Stream : not null access RST; Item : Character) is
|
|
|
1166 S : XDR_S_C;
|
|
|
1167
|
|
|
1168 pragma Assert (C_L = 1);
|
|
|
1169
|
|
|
1170 begin
|
|
|
1171 -- Use Ada requirements on Character representation clause
|
|
|
1172
|
|
|
1173 S (1) := SE (Character'Pos (Item));
|
|
|
1174
|
|
|
1175 Ada.Streams.Write (Stream.all, S);
|
|
|
1176 end W_C;
|
|
|
1177
|
|
|
1178 ---------
|
|
|
1179 -- W_F --
|
|
|
1180 ---------
|
|
|
1181
|
|
|
1182 procedure W_F (Stream : not null access RST; Item : Float) is
|
|
|
1183 I : constant Precision := Single;
|
|
|
1184 E_Size : Integer renames Fields (I).E_Size;
|
|
|
1185 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
1186 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
1187 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
1188 F_Size : Integer renames Fields (I).F_Size;
|
|
|
1189 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
1190
|
|
|
1191 Exponent : Long_Unsigned;
|
|
|
1192 Fraction : Long_Unsigned;
|
|
|
1193 Is_Positive : Boolean;
|
|
|
1194 E : Integer;
|
|
|
1195 F : Float;
|
|
|
1196 S : SEA (1 .. F_L) := (others => 0);
|
|
|
1197
|
|
|
1198 begin
|
|
|
1199 if not Item'Valid then
|
|
|
1200 raise Constraint_Error;
|
|
|
1201 end if;
|
|
|
1202
|
|
|
1203 -- Compute Sign
|
|
|
1204
|
|
|
1205 Is_Positive := (0.0 <= Item);
|
|
|
1206 F := abs (Item);
|
|
|
1207
|
|
|
1208 -- Signed zero
|
|
|
1209
|
|
|
1210 if F = 0.0 then
|
|
|
1211 Exponent := 0;
|
|
|
1212 Fraction := 0;
|
|
|
1213
|
|
|
1214 else
|
|
|
1215 E := Float'Exponent (F) - 1;
|
|
|
1216
|
|
|
1217 -- Denormalized float
|
|
|
1218
|
|
|
1219 if E <= -E_Bias then
|
|
|
1220 F := Float'Scaling (F, F_Size + E_Bias - 1);
|
|
|
1221 E := -E_Bias;
|
|
|
1222 else
|
|
|
1223 F := Float'Scaling (Float'Fraction (F), F_Size + 1);
|
|
|
1224 end if;
|
|
|
1225
|
|
|
1226 -- Compute Exponent and Fraction
|
|
|
1227
|
|
|
1228 Exponent := Long_Unsigned (E + E_Bias);
|
|
|
1229 Fraction := Long_Unsigned (F * 2.0) / 2;
|
|
|
1230 end if;
|
|
|
1231
|
|
|
1232 -- Store Fraction
|
|
|
1233
|
|
|
1234 for I in reverse F_L - F_Bytes + 1 .. F_L loop
|
|
|
1235 S (I) := SE (Fraction mod BB);
|
|
|
1236 Fraction := Fraction / BB;
|
|
|
1237 end loop;
|
|
|
1238
|
|
|
1239 -- Remove implicit bit
|
|
|
1240
|
|
|
1241 S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask;
|
|
|
1242
|
|
|
1243 -- Store Exponent (not always at the beginning of a byte)
|
|
|
1244
|
|
|
1245 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
1246 for N in reverse 1 .. E_Bytes loop
|
|
|
1247 S (N) := SE (Exponent mod BB) + S (N);
|
|
|
1248 Exponent := Exponent / BB;
|
|
|
1249 end loop;
|
|
|
1250
|
|
|
1251 -- Store Sign
|
|
|
1252
|
|
|
1253 if not Is_Positive then
|
|
|
1254 S (1) := S (1) + BS;
|
|
|
1255 end if;
|
|
|
1256
|
|
|
1257 Ada.Streams.Write (Stream.all, S);
|
|
|
1258 end W_F;
|
|
|
1259
|
|
|
1260 ---------
|
|
|
1261 -- W_I --
|
|
|
1262 ---------
|
|
|
1263
|
|
|
1264 procedure W_I (Stream : not null access RST; Item : Integer) is
|
|
|
1265 S : XDR_S_I;
|
|
|
1266 U : XDR_U;
|
|
|
1267
|
|
|
1268 begin
|
|
|
1269 if Optimize_Integers then
|
|
|
1270 S := Integer_To_XDR_S_I (Item);
|
|
|
1271
|
|
|
1272 else
|
|
|
1273 -- Test sign and apply two complement notation
|
|
|
1274
|
|
|
1275 U := (if Item < 0
|
|
|
1276 then XDR_U'Last xor XDR_U (-(Item + 1))
|
|
|
1277 else XDR_U (Item));
|
|
|
1278
|
|
|
1279 for N in reverse S'Range loop
|
|
|
1280 S (N) := SE (U mod BB);
|
|
|
1281 U := U / BB;
|
|
|
1282 end loop;
|
|
|
1283
|
|
|
1284 if U /= 0 then
|
|
|
1285 raise Data_Error;
|
|
|
1286 end if;
|
|
|
1287 end if;
|
|
|
1288
|
|
|
1289 Ada.Streams.Write (Stream.all, S);
|
|
|
1290 end W_I;
|
|
|
1291
|
|
|
1292 ----------
|
|
|
1293 -- W_LF --
|
|
|
1294 ----------
|
|
|
1295
|
|
|
1296 procedure W_LF (Stream : not null access RST; Item : Long_Float) is
|
|
|
1297 I : constant Precision := Double;
|
|
|
1298 E_Size : Integer renames Fields (I).E_Size;
|
|
|
1299 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
1300 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
1301 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
1302 F_Size : Integer renames Fields (I).F_Size;
|
|
|
1303 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
1304
|
|
|
1305 Exponent : Long_Unsigned;
|
|
|
1306 Fraction : Long_Long_Unsigned;
|
|
|
1307 Is_Positive : Boolean;
|
|
|
1308 E : Integer;
|
|
|
1309 F : Long_Float;
|
|
|
1310 S : SEA (1 .. LF_L) := (others => 0);
|
|
|
1311
|
|
|
1312 begin
|
|
|
1313 if not Item'Valid then
|
|
|
1314 raise Constraint_Error;
|
|
|
1315 end if;
|
|
|
1316
|
|
|
1317 -- Compute Sign
|
|
|
1318
|
|
|
1319 Is_Positive := (0.0 <= Item);
|
|
|
1320 F := abs (Item);
|
|
|
1321
|
|
|
1322 -- Signed zero
|
|
|
1323
|
|
|
1324 if F = 0.0 then
|
|
|
1325 Exponent := 0;
|
|
|
1326 Fraction := 0;
|
|
|
1327
|
|
|
1328 else
|
|
|
1329 E := Long_Float'Exponent (F) - 1;
|
|
|
1330
|
|
|
1331 -- Denormalized float
|
|
|
1332
|
|
|
1333 if E <= -E_Bias then
|
|
|
1334 E := -E_Bias;
|
|
|
1335 F := Long_Float'Scaling (F, F_Size + E_Bias - 1);
|
|
|
1336 else
|
|
|
1337 F := Long_Float'Scaling (F, F_Size - E);
|
|
|
1338 end if;
|
|
|
1339
|
|
|
1340 -- Compute Exponent and Fraction
|
|
|
1341
|
|
|
1342 Exponent := Long_Unsigned (E + E_Bias);
|
|
|
1343 Fraction := Long_Long_Unsigned (F * 2.0) / 2;
|
|
|
1344 end if;
|
|
|
1345
|
|
|
1346 -- Store Fraction
|
|
|
1347
|
|
|
1348 for I in reverse LF_L - F_Bytes + 1 .. LF_L loop
|
|
|
1349 S (I) := SE (Fraction mod BB);
|
|
|
1350 Fraction := Fraction / BB;
|
|
|
1351 end loop;
|
|
|
1352
|
|
|
1353 -- Remove implicit bit
|
|
|
1354
|
|
|
1355 S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask;
|
|
|
1356
|
|
|
1357 -- Store Exponent (not always at the beginning of a byte)
|
|
|
1358
|
|
|
1359 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
1360 for N in reverse 1 .. E_Bytes loop
|
|
|
1361 S (N) := SE (Exponent mod BB) + S (N);
|
|
|
1362 Exponent := Exponent / BB;
|
|
|
1363 end loop;
|
|
|
1364
|
|
|
1365 -- Store Sign
|
|
|
1366
|
|
|
1367 if not Is_Positive then
|
|
|
1368 S (1) := S (1) + BS;
|
|
|
1369 end if;
|
|
|
1370
|
|
|
1371 Ada.Streams.Write (Stream.all, S);
|
|
|
1372 end W_LF;
|
|
|
1373
|
|
|
1374 ----------
|
|
|
1375 -- W_LI --
|
|
|
1376 ----------
|
|
|
1377
|
|
|
1378 procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
|
|
|
1379 S : XDR_S_LI;
|
|
|
1380 U : Unsigned;
|
|
|
1381 X : Long_Unsigned;
|
|
|
1382
|
|
|
1383 begin
|
|
|
1384 if Optimize_Integers then
|
|
|
1385 S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item));
|
|
|
1386
|
|
|
1387 else
|
|
|
1388 -- Test sign and apply two complement notation
|
|
|
1389
|
|
|
1390 if Item < 0 then
|
|
|
1391 X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1));
|
|
|
1392 else
|
|
|
1393 X := Long_Unsigned (Item);
|
|
|
1394 end if;
|
|
|
1395
|
|
|
1396 -- Compute using machine unsigned rather than long_unsigned
|
|
|
1397
|
|
|
1398 for N in reverse S'Range loop
|
|
|
1399
|
|
|
1400 -- We have filled an unsigned
|
|
|
1401
|
|
|
1402 if (LU_L - N) mod UB = 0 then
|
|
|
1403 U := Unsigned (X and UL);
|
|
|
1404 X := Shift_Right (X, US);
|
|
|
1405 end if;
|
|
|
1406
|
|
|
1407 S (N) := SE (U mod BB);
|
|
|
1408 U := U / BB;
|
|
|
1409 end loop;
|
|
|
1410
|
|
|
1411 if U /= 0 then
|
|
|
1412 raise Data_Error;
|
|
|
1413 end if;
|
|
|
1414 end if;
|
|
|
1415
|
|
|
1416 Ada.Streams.Write (Stream.all, S);
|
|
|
1417 end W_LI;
|
|
|
1418
|
|
|
1419 -----------
|
|
|
1420 -- W_LLF --
|
|
|
1421 -----------
|
|
|
1422
|
|
|
1423 procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
|
|
|
1424 I : constant Precision := Quadruple;
|
|
|
1425 E_Size : Integer renames Fields (I).E_Size;
|
|
|
1426 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
1427 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
1428 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
1429 F_Size : Integer renames Fields (I).F_Size;
|
|
|
1430
|
|
|
1431 HFS : constant Integer := F_Size / 2;
|
|
|
1432
|
|
|
1433 Exponent : Long_Unsigned;
|
|
|
1434 Fraction_1 : Long_Long_Unsigned;
|
|
|
1435 Fraction_2 : Long_Long_Unsigned;
|
|
|
1436 Is_Positive : Boolean;
|
|
|
1437 E : Integer;
|
|
|
1438 F : Long_Long_Float := Item;
|
|
|
1439 S : SEA (1 .. LLF_L) := (others => 0);
|
|
|
1440
|
|
|
1441 begin
|
|
|
1442 if not Item'Valid then
|
|
|
1443 raise Constraint_Error;
|
|
|
1444 end if;
|
|
|
1445
|
|
|
1446 -- Compute Sign
|
|
|
1447
|
|
|
1448 Is_Positive := (0.0 <= Item);
|
|
|
1449
|
|
|
1450 if F < 0.0 then
|
|
|
1451 F := -Item;
|
|
|
1452 end if;
|
|
|
1453
|
|
|
1454 -- Signed zero
|
|
|
1455
|
|
|
1456 if F = 0.0 then
|
|
|
1457 Exponent := 0;
|
|
|
1458 Fraction_1 := 0;
|
|
|
1459 Fraction_2 := 0;
|
|
|
1460
|
|
|
1461 else
|
|
|
1462 E := Long_Long_Float'Exponent (F) - 1;
|
|
|
1463
|
|
|
1464 -- Denormalized float
|
|
|
1465
|
|
|
1466 if E <= -E_Bias then
|
|
|
1467 F := Long_Long_Float'Scaling (F, E_Bias - 1);
|
|
|
1468 E := -E_Bias;
|
|
|
1469 else
|
|
|
1470 F := Long_Long_Float'Scaling
|
|
|
1471 (Long_Long_Float'Fraction (F), 1);
|
|
|
1472 end if;
|
|
|
1473
|
|
|
1474 -- Compute Exponent and Fraction
|
|
|
1475
|
|
|
1476 Exponent := Long_Unsigned (E + E_Bias);
|
|
|
1477 F := Long_Long_Float'Scaling (F, F_Size - HFS);
|
|
|
1478 Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
|
|
|
1479 F := F - Long_Long_Float (Fraction_1);
|
|
|
1480 F := Long_Long_Float'Scaling (F, HFS);
|
|
|
1481 Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
|
|
|
1482 end if;
|
|
|
1483
|
|
|
1484 -- Store Fraction_1
|
|
|
1485
|
|
|
1486 for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
|
|
|
1487 S (I) := SE (Fraction_1 mod BB);
|
|
|
1488 Fraction_1 := Fraction_1 / BB;
|
|
|
1489 end loop;
|
|
|
1490
|
|
|
1491 -- Store Fraction_2
|
|
|
1492
|
|
|
1493 for I in reverse LLF_L - 6 .. LLF_L loop
|
|
|
1494 S (SEO (I)) := SE (Fraction_2 mod BB);
|
|
|
1495 Fraction_2 := Fraction_2 / BB;
|
|
|
1496 end loop;
|
|
|
1497
|
|
|
1498 -- Store Exponent (not always at the beginning of a byte)
|
|
|
1499
|
|
|
1500 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
1501 for N in reverse 1 .. E_Bytes loop
|
|
|
1502 S (N) := SE (Exponent mod BB) + S (N);
|
|
|
1503 Exponent := Exponent / BB;
|
|
|
1504 end loop;
|
|
|
1505
|
|
|
1506 -- Store Sign
|
|
|
1507
|
|
|
1508 if not Is_Positive then
|
|
|
1509 S (1) := S (1) + BS;
|
|
|
1510 end if;
|
|
|
1511
|
|
|
1512 Ada.Streams.Write (Stream.all, S);
|
|
|
1513 end W_LLF;
|
|
|
1514
|
|
|
1515 -----------
|
|
|
1516 -- W_LLI --
|
|
|
1517 -----------
|
|
|
1518
|
|
|
1519 procedure W_LLI
|
|
|
1520 (Stream : not null access RST;
|
|
|
1521 Item : Long_Long_Integer)
|
|
|
1522 is
|
|
|
1523 S : XDR_S_LLI;
|
|
|
1524 U : Unsigned;
|
|
|
1525 X : Long_Long_Unsigned;
|
|
|
1526
|
|
|
1527 begin
|
|
|
1528 if Optimize_Integers then
|
|
|
1529 S := Long_Long_Integer_To_XDR_S_LLI (Item);
|
|
|
1530
|
|
|
1531 else
|
|
|
1532 -- Test sign and apply two complement notation
|
|
|
1533
|
|
|
1534 if Item < 0 then
|
|
|
1535 X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1));
|
|
|
1536 else
|
|
|
1537 X := Long_Long_Unsigned (Item);
|
|
|
1538 end if;
|
|
|
1539
|
|
|
1540 -- Compute using machine unsigned rather than long_long_unsigned
|
|
|
1541
|
|
|
1542 for N in reverse S'Range loop
|
|
|
1543
|
|
|
1544 -- We have filled an unsigned
|
|
|
1545
|
|
|
1546 if (LLU_L - N) mod UB = 0 then
|
|
|
1547 U := Unsigned (X and UL);
|
|
|
1548 X := Shift_Right (X, US);
|
|
|
1549 end if;
|
|
|
1550
|
|
|
1551 S (N) := SE (U mod BB);
|
|
|
1552 U := U / BB;
|
|
|
1553 end loop;
|
|
|
1554
|
|
|
1555 if U /= 0 then
|
|
|
1556 raise Data_Error;
|
|
|
1557 end if;
|
|
|
1558 end if;
|
|
|
1559
|
|
|
1560 Ada.Streams.Write (Stream.all, S);
|
|
|
1561 end W_LLI;
|
|
|
1562
|
|
|
1563 -----------
|
|
|
1564 -- W_LLU --
|
|
|
1565 -----------
|
|
|
1566
|
|
|
1567 procedure W_LLU
|
|
|
1568 (Stream : not null access RST;
|
|
|
1569 Item : Long_Long_Unsigned)
|
|
|
1570 is
|
|
|
1571 S : XDR_S_LLU;
|
|
|
1572 U : Unsigned;
|
|
|
1573 X : Long_Long_Unsigned := Item;
|
|
|
1574
|
|
|
1575 begin
|
|
|
1576 if Optimize_Integers then
|
|
|
1577 S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
|
|
|
1578
|
|
|
1579 else
|
|
|
1580 -- Compute using machine unsigned rather than long_long_unsigned
|
|
|
1581
|
|
|
1582 for N in reverse S'Range loop
|
|
|
1583
|
|
|
1584 -- We have filled an unsigned
|
|
|
1585
|
|
|
1586 if (LLU_L - N) mod UB = 0 then
|
|
|
1587 U := Unsigned (X and UL);
|
|
|
1588 X := Shift_Right (X, US);
|
|
|
1589 end if;
|
|
|
1590
|
|
|
1591 S (N) := SE (U mod BB);
|
|
|
1592 U := U / BB;
|
|
|
1593 end loop;
|
|
|
1594
|
|
|
1595 if U /= 0 then
|
|
|
1596 raise Data_Error;
|
|
|
1597 end if;
|
|
|
1598 end if;
|
|
|
1599
|
|
|
1600 Ada.Streams.Write (Stream.all, S);
|
|
|
1601 end W_LLU;
|
|
|
1602
|
|
|
1603 ----------
|
|
|
1604 -- W_LU --
|
|
|
1605 ----------
|
|
|
1606
|
|
|
1607 procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
|
|
|
1608 S : XDR_S_LU;
|
|
|
1609 U : Unsigned;
|
|
|
1610 X : Long_Unsigned := Item;
|
|
|
1611
|
|
|
1612 begin
|
|
|
1613 if Optimize_Integers then
|
|
|
1614 S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item));
|
|
|
1615
|
|
|
1616 else
|
|
|
1617 -- Compute using machine unsigned rather than long_unsigned
|
|
|
1618
|
|
|
1619 for N in reverse S'Range loop
|
|
|
1620
|
|
|
1621 -- We have filled an unsigned
|
|
|
1622
|
|
|
1623 if (LU_L - N) mod UB = 0 then
|
|
|
1624 U := Unsigned (X and UL);
|
|
|
1625 X := Shift_Right (X, US);
|
|
|
1626 end if;
|
|
|
1627 S (N) := SE (U mod BB);
|
|
|
1628 U := U / BB;
|
|
|
1629 end loop;
|
|
|
1630
|
|
|
1631 if U /= 0 then
|
|
|
1632 raise Data_Error;
|
|
|
1633 end if;
|
|
|
1634 end if;
|
|
|
1635
|
|
|
1636 Ada.Streams.Write (Stream.all, S);
|
|
|
1637 end W_LU;
|
|
|
1638
|
|
|
1639 ----------
|
|
|
1640 -- W_SF --
|
|
|
1641 ----------
|
|
|
1642
|
|
|
1643 procedure W_SF (Stream : not null access RST; Item : Short_Float) is
|
|
|
1644 I : constant Precision := Single;
|
|
|
1645 E_Size : Integer renames Fields (I).E_Size;
|
|
|
1646 E_Bias : Integer renames Fields (I).E_Bias;
|
|
|
1647 E_Bytes : SEO renames Fields (I).E_Bytes;
|
|
|
1648 F_Bytes : SEO renames Fields (I).F_Bytes;
|
|
|
1649 F_Size : Integer renames Fields (I).F_Size;
|
|
|
1650 F_Mask : SE renames Fields (I).F_Mask;
|
|
|
1651
|
|
|
1652 Exponent : Long_Unsigned;
|
|
|
1653 Fraction : Long_Unsigned;
|
|
|
1654 Is_Positive : Boolean;
|
|
|
1655 E : Integer;
|
|
|
1656 F : Short_Float;
|
|
|
1657 S : SEA (1 .. SF_L) := (others => 0);
|
|
|
1658
|
|
|
1659 begin
|
|
|
1660 if not Item'Valid then
|
|
|
1661 raise Constraint_Error;
|
|
|
1662 end if;
|
|
|
1663
|
|
|
1664 -- Compute Sign
|
|
|
1665
|
|
|
1666 Is_Positive := (0.0 <= Item);
|
|
|
1667 F := abs (Item);
|
|
|
1668
|
|
|
1669 -- Signed zero
|
|
|
1670
|
|
|
1671 if F = 0.0 then
|
|
|
1672 Exponent := 0;
|
|
|
1673 Fraction := 0;
|
|
|
1674
|
|
|
1675 else
|
|
|
1676 E := Short_Float'Exponent (F) - 1;
|
|
|
1677
|
|
|
1678 -- Denormalized float
|
|
|
1679
|
|
|
1680 if E <= -E_Bias then
|
|
|
1681 E := -E_Bias;
|
|
|
1682 F := Short_Float'Scaling (F, F_Size + E_Bias - 1);
|
|
|
1683 else
|
|
|
1684 F := Short_Float'Scaling (F, F_Size - E);
|
|
|
1685 end if;
|
|
|
1686
|
|
|
1687 -- Compute Exponent and Fraction
|
|
|
1688
|
|
|
1689 Exponent := Long_Unsigned (E + E_Bias);
|
|
|
1690 Fraction := Long_Unsigned (F * 2.0) / 2;
|
|
|
1691 end if;
|
|
|
1692
|
|
|
1693 -- Store Fraction
|
|
|
1694
|
|
|
1695 for I in reverse SF_L - F_Bytes + 1 .. SF_L loop
|
|
|
1696 S (I) := SE (Fraction mod BB);
|
|
|
1697 Fraction := Fraction / BB;
|
|
|
1698 end loop;
|
|
|
1699
|
|
|
1700 -- Remove implicit bit
|
|
|
1701
|
|
|
1702 S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask;
|
|
|
1703
|
|
|
1704 -- Store Exponent (not always at the beginning of a byte)
|
|
|
1705
|
|
|
1706 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
|
|
|
1707 for N in reverse 1 .. E_Bytes loop
|
|
|
1708 S (N) := SE (Exponent mod BB) + S (N);
|
|
|
1709 Exponent := Exponent / BB;
|
|
|
1710 end loop;
|
|
|
1711
|
|
|
1712 -- Store Sign
|
|
|
1713
|
|
|
1714 if not Is_Positive then
|
|
|
1715 S (1) := S (1) + BS;
|
|
|
1716 end if;
|
|
|
1717
|
|
|
1718 Ada.Streams.Write (Stream.all, S);
|
|
|
1719 end W_SF;
|
|
|
1720
|
|
|
1721 ----------
|
|
|
1722 -- W_SI --
|
|
|
1723 ----------
|
|
|
1724
|
|
|
1725 procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
|
|
|
1726 S : XDR_S_SI;
|
|
|
1727 U : XDR_SU;
|
|
|
1728
|
|
|
1729 begin
|
|
|
1730 if Optimize_Integers then
|
|
|
1731 S := Short_Integer_To_XDR_S_SI (Item);
|
|
|
1732
|
|
|
1733 else
|
|
|
1734 -- Test sign and apply two complement's notation
|
|
|
1735
|
|
|
1736 U := (if Item < 0
|
|
|
1737 then XDR_SU'Last xor XDR_SU (-(Item + 1))
|
|
|
1738 else XDR_SU (Item));
|
|
|
1739
|
|
|
1740 for N in reverse S'Range loop
|
|
|
1741 S (N) := SE (U mod BB);
|
|
|
1742 U := U / BB;
|
|
|
1743 end loop;
|
|
|
1744
|
|
|
1745 if U /= 0 then
|
|
|
1746 raise Data_Error;
|
|
|
1747 end if;
|
|
|
1748 end if;
|
|
|
1749
|
|
|
1750 Ada.Streams.Write (Stream.all, S);
|
|
|
1751 end W_SI;
|
|
|
1752
|
|
|
1753 -----------
|
|
|
1754 -- W_SSI --
|
|
|
1755 -----------
|
|
|
1756
|
|
|
1757 procedure W_SSI
|
|
|
1758 (Stream : not null access RST;
|
|
|
1759 Item : Short_Short_Integer)
|
|
|
1760 is
|
|
|
1761 S : XDR_S_SSI;
|
|
|
1762 U : XDR_SSU;
|
|
|
1763
|
|
|
1764 begin
|
|
|
1765 if Optimize_Integers then
|
|
|
1766 S := Short_Short_Integer_To_XDR_S_SSI (Item);
|
|
|
1767
|
|
|
1768 else
|
|
|
1769 -- Test sign and apply two complement's notation
|
|
|
1770
|
|
|
1771 U := (if Item < 0
|
|
|
1772 then XDR_SSU'Last xor XDR_SSU (-(Item + 1))
|
|
|
1773 else XDR_SSU (Item));
|
|
|
1774
|
|
|
1775 S (1) := SE (U);
|
|
|
1776 end if;
|
|
|
1777
|
|
|
1778 Ada.Streams.Write (Stream.all, S);
|
|
|
1779 end W_SSI;
|
|
|
1780
|
|
|
1781 -----------
|
|
|
1782 -- W_SSU --
|
|
|
1783 -----------
|
|
|
1784
|
|
|
1785 procedure W_SSU
|
|
|
1786 (Stream : not null access RST;
|
|
|
1787 Item : Short_Short_Unsigned)
|
|
|
1788 is
|
|
|
1789 U : constant XDR_SSU := XDR_SSU (Item);
|
|
|
1790 S : XDR_S_SSU;
|
|
|
1791
|
|
|
1792 begin
|
|
|
1793 S (1) := SE (U);
|
|
|
1794 Ada.Streams.Write (Stream.all, S);
|
|
|
1795 end W_SSU;
|
|
|
1796
|
|
|
1797 ----------
|
|
|
1798 -- W_SU --
|
|
|
1799 ----------
|
|
|
1800
|
|
|
1801 procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is
|
|
|
1802 S : XDR_S_SU;
|
|
|
1803 U : XDR_SU := XDR_SU (Item);
|
|
|
1804
|
|
|
1805 begin
|
|
|
1806 if Optimize_Integers then
|
|
|
1807 S := Short_Unsigned_To_XDR_S_SU (Item);
|
|
|
1808
|
|
|
1809 else
|
|
|
1810 for N in reverse S'Range loop
|
|
|
1811 S (N) := SE (U mod BB);
|
|
|
1812 U := U / BB;
|
|
|
1813 end loop;
|
|
|
1814
|
|
|
1815 if U /= 0 then
|
|
|
1816 raise Data_Error;
|
|
|
1817 end if;
|
|
|
1818 end if;
|
|
|
1819
|
|
|
1820 Ada.Streams.Write (Stream.all, S);
|
|
|
1821 end W_SU;
|
|
|
1822
|
|
|
1823 ---------
|
|
|
1824 -- W_U --
|
|
|
1825 ---------
|
|
|
1826
|
|
|
1827 procedure W_U (Stream : not null access RST; Item : Unsigned) is
|
|
|
1828 S : XDR_S_U;
|
|
|
1829 U : XDR_U := XDR_U (Item);
|
|
|
1830
|
|
|
1831 begin
|
|
|
1832 if Optimize_Integers then
|
|
|
1833 S := Unsigned_To_XDR_S_U (Item);
|
|
|
1834
|
|
|
1835 else
|
|
|
1836 for N in reverse S'Range loop
|
|
|
1837 S (N) := SE (U mod BB);
|
|
|
1838 U := U / BB;
|
|
|
1839 end loop;
|
|
|
1840
|
|
|
1841 if U /= 0 then
|
|
|
1842 raise Data_Error;
|
|
|
1843 end if;
|
|
|
1844 end if;
|
|
|
1845
|
|
|
1846 Ada.Streams.Write (Stream.all, S);
|
|
|
1847 end W_U;
|
|
|
1848
|
|
|
1849 ----------
|
|
|
1850 -- W_WC --
|
|
|
1851 ----------
|
|
|
1852
|
|
|
1853 procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
|
|
|
1854 S : XDR_S_WC;
|
|
|
1855 U : XDR_WC;
|
|
|
1856
|
|
|
1857 begin
|
|
|
1858 -- Use Ada requirements on Wide_Character representation clause
|
|
|
1859
|
|
|
1860 U := XDR_WC (Wide_Character'Pos (Item));
|
|
|
1861
|
|
|
1862 for N in reverse S'Range loop
|
|
|
1863 S (N) := SE (U mod BB);
|
|
|
1864 U := U / BB;
|
|
|
1865 end loop;
|
|
|
1866
|
|
|
1867 Ada.Streams.Write (Stream.all, S);
|
|
|
1868
|
|
|
1869 if U /= 0 then
|
|
|
1870 raise Data_Error;
|
|
|
1871 end if;
|
|
|
1872 end W_WC;
|
|
|
1873
|
|
|
1874 -----------
|
|
|
1875 -- W_WWC --
|
|
|
1876 -----------
|
|
|
1877
|
|
|
1878 procedure W_WWC
|
|
|
1879 (Stream : not null access RST; Item : Wide_Wide_Character)
|
|
|
1880 is
|
|
|
1881 S : XDR_S_WWC;
|
|
|
1882 U : XDR_WWC;
|
|
|
1883
|
|
|
1884 begin
|
|
|
1885 -- Use Ada requirements on Wide_Wide_Character representation clause
|
|
|
1886
|
|
|
1887 U := XDR_WWC (Wide_Wide_Character'Pos (Item));
|
|
|
1888
|
|
|
1889 for N in reverse S'Range loop
|
|
|
1890 S (N) := SE (U mod BB);
|
|
|
1891 U := U / BB;
|
|
|
1892 end loop;
|
|
|
1893
|
|
|
1894 Ada.Streams.Write (Stream.all, S);
|
|
|
1895
|
|
|
1896 if U /= 0 then
|
|
|
1897 raise Data_Error;
|
|
|
1898 end if;
|
|
|
1899 end W_WWC;
|
|
|
1900
|
|
|
1901 end System.Stream_Attributes;
|
