1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . S T R E A M _ A T T R I B U T E S --
9 -- Copyright (C) 1996-2006, Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GARLIC is distributed in the hope that it will be useful, but --
15 -- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- --
16 -- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
17 -- License for more details. You should have received a copy of the GNU --
18 -- General Public License distributed with GARLIC; see file COPYING. If --
19 -- not, write to the Free Software Foundation, 51 Franklin Street, Fifth --
20 -- Floor, Boston, MA 02110-1301, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This file is an alternate version of s-stratt.adb based on the XDR
35 -- standard. It is especially useful for exchanging streams between two
36 -- different systems with different basic type representations and endianess.
38 with Ada
.IO_Exceptions
;
39 with Ada
.Streams
; use Ada
.Streams
;
40 with Ada
.Unchecked_Conversion
;
42 package body System
.Stream_Attributes
is
44 pragma Suppress
(Range_Check
);
45 pragma Suppress
(Overflow_Check
);
49 Data_Error
: exception renames Ada
.IO_Exceptions
.End_Error
;
50 -- Exception raised if insufficient data read (End_Error is
51 -- mandated by AI95-00132).
53 SU
: constant := System
.Storage_Unit
;
54 -- XXXXX pragma Assert (SU = 8);
56 BB
: constant := 2 ** SU
; -- Byte base
57 BL
: constant := 2 ** SU
- 1; -- Byte last
58 BS
: constant := 2 ** (SU
- 1); -- Byte sign
60 US
: constant := Unsigned
'Size; -- Unsigned size
61 UB
: constant := (US
- 1) / SU
+ 1; -- Unsigned byte
62 UL
: constant := 2 ** US
- 1; -- Unsigned last
64 subtype SE
is Ada
.Streams
.Stream_Element
;
65 subtype SEA
is Ada
.Streams
.Stream_Element_Array
;
66 subtype SEO
is Ada
.Streams
.Stream_Element_Offset
;
68 generic function UC
renames Ada
.Unchecked_Conversion
;
72 E_Size
: Integer; -- Exponent bit size
73 E_Bias
: Integer; -- Exponent bias
74 F_Size
: Integer; -- Fraction bit size
75 E_Last
: Integer; -- Max exponent value
76 F_Mask
: SE
; -- Mask to apply on first fraction byte
77 E_Bytes
: SEO
; -- N. of exponent bytes completly used
78 F_Bytes
: SEO
; -- N. of fraction bytes completly used
79 F_Bits
: Integer; -- N. of bits used on first fraction word
82 type Precision
is (Single
, Double
, Quadruple
);
84 Fields
: constant array (Precision
) of Field_Type
:= (
92 F_Mask
=> 16#
7F#
, -- 2 ** 7 - 1,
102 E_Last
=> 2 ** 11 - 1,
103 F_Mask
=> 16#
0F#
, -- 2 ** 4 - 1,
106 F_Bits
=> 52 mod US
),
108 -- Quadruple precision
113 E_Last
=> 2 ** 8 - 1,
114 F_Mask
=> 16#FF#
, -- 2 ** 8 - 1,
117 F_Bits
=> 112 mod US
));
119 -- The representation of all items requires a multiple of four bytes
120 -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes
121 -- are read or written to some byte stream such that byte m always
122 -- precedes byte m+1. If the n bytes needed to contain the data are not
123 -- a multiple of four, then the n bytes are followed by enough (0 to 3)
124 -- residual zero bytes, r, to make the total byte count a multiple of 4.
126 -- An XDR signed integer is a 32-bit datum that encodes an integer
127 -- in the range [-2147483648,2147483647]. The integer is represented
128 -- in two's complement notation. The most and least significant bytes
129 -- are 0 and 3, respectively. Integers are declared as follows:
132 -- +-------+-------+-------+-------+
133 -- |byte 0 |byte 1 |byte 2 |byte 3 |
134 -- +-------+-------+-------+-------+
135 -- <------------32 bits------------>
137 SSI_L
: constant := 1;
138 SI_L
: constant := 2;
140 LI_L
: constant := 8;
141 LLI_L
: constant := 8;
143 subtype XDR_S_SSI
is SEA
(1 .. SSI_L
);
144 subtype XDR_S_SI
is SEA
(1 .. SI_L
);
145 subtype XDR_S_I
is SEA
(1 .. I_L
);
146 subtype XDR_S_LI
is SEA
(1 .. LI_L
);
147 subtype XDR_S_LLI
is SEA
(1 .. LLI_L
);
149 function Short_Short_Integer_To_XDR_S_SSI
is
150 new Ada
.Unchecked_Conversion
(Short_Short_Integer, XDR_S_SSI
);
151 function XDR_S_SSI_To_Short_Short_Integer
is
152 new Ada
.Unchecked_Conversion
(XDR_S_SSI
, Short_Short_Integer);
154 function Short_Integer_To_XDR_S_SI
is
155 new Ada
.Unchecked_Conversion
(Short_Integer, XDR_S_SI
);
156 function XDR_S_SI_To_Short_Integer
is
157 new Ada
.Unchecked_Conversion
(XDR_S_SI
, Short_Integer);
159 function Integer_To_XDR_S_I
is
160 new Ada
.Unchecked_Conversion
(Integer, XDR_S_I
);
161 function XDR_S_I_To_Integer
is
162 new Ada
.Unchecked_Conversion
(XDR_S_I
, Integer);
164 function Long_Long_Integer_To_XDR_S_LI
is
165 new Ada
.Unchecked_Conversion
(Long_Long_Integer, XDR_S_LI
);
166 function XDR_S_LI_To_Long_Long_Integer
is
167 new Ada
.Unchecked_Conversion
(XDR_S_LI
, Long_Long_Integer);
169 function Long_Long_Integer_To_XDR_S_LLI
is
170 new Ada
.Unchecked_Conversion
(Long_Long_Integer, XDR_S_LLI
);
171 function XDR_S_LLI_To_Long_Long_Integer
is
172 new Ada
.Unchecked_Conversion
(XDR_S_LLI
, Long_Long_Integer);
174 -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
175 -- integer in the range [0,4294967295]. It is represented by an unsigned
176 -- binary number whose most and least significant bytes are 0 and 3,
177 -- respectively. An unsigned integer is declared as follows:
180 -- +-------+-------+-------+-------+
181 -- |byte 0 |byte 1 |byte 2 |byte 3 |
182 -- +-------+-------+-------+-------+
183 -- <------------32 bits------------>
185 SSU_L
: constant := 1;
186 SU_L
: constant := 2;
188 LU_L
: constant := 8;
189 LLU_L
: constant := 8;
191 subtype XDR_S_SSU
is SEA
(1 .. SSU_L
);
192 subtype XDR_S_SU
is SEA
(1 .. SU_L
);
193 subtype XDR_S_U
is SEA
(1 .. U_L
);
194 subtype XDR_S_LU
is SEA
(1 .. LU_L
);
195 subtype XDR_S_LLU
is SEA
(1 .. LLU_L
);
197 type XDR_SSU
is mod BB
** SSU_L
;
198 type XDR_SU
is mod BB
** SU_L
;
199 type XDR_U
is mod BB
** U_L
;
201 function Short_Unsigned_To_XDR_S_SU
is
202 new Ada
.Unchecked_Conversion
(Short_Unsigned
, XDR_S_SU
);
203 function XDR_S_SU_To_Short_Unsigned
is
204 new Ada
.Unchecked_Conversion
(XDR_S_SU
, Short_Unsigned
);
206 function Unsigned_To_XDR_S_U
is
207 new Ada
.Unchecked_Conversion
(Unsigned
, XDR_S_U
);
208 function XDR_S_U_To_Unsigned
is
209 new Ada
.Unchecked_Conversion
(XDR_S_U
, Unsigned
);
211 function Long_Long_Unsigned_To_XDR_S_LU
is
212 new Ada
.Unchecked_Conversion
(Long_Long_Unsigned
, XDR_S_LU
);
213 function XDR_S_LU_To_Long_Long_Unsigned
is
214 new Ada
.Unchecked_Conversion
(XDR_S_LU
, Long_Long_Unsigned
);
216 function Long_Long_Unsigned_To_XDR_S_LLU
is
217 new Ada
.Unchecked_Conversion
(Long_Long_Unsigned
, XDR_S_LLU
);
218 function XDR_S_LLU_To_Long_Long_Unsigned
is
219 new Ada
.Unchecked_Conversion
(XDR_S_LLU
, Long_Long_Unsigned
);
221 -- The standard defines the floating-point data type "float" (32 bits
222 -- or 4 bytes). The encoding used is the IEEE standard for normalized
223 -- single-precision floating-point numbers.
225 -- The standard defines the encoding for the double-precision
226 -- floating-point data type "double" (64 bits or 8 bytes). The
227 -- encoding used is the IEEE standard for normalized double-precision
228 -- floating-point numbers.
230 SF_L
: constant := 4; -- Single precision
231 F_L
: constant := 4; -- Single precision
232 LF_L
: constant := 8; -- Double precision
233 LLF_L
: constant := 16; -- Quadruple precision
235 TM_L
: constant := 8;
236 subtype XDR_S_TM
is SEA
(1 .. TM_L
);
237 type XDR_TM
is mod BB
** TM_L
;
239 type XDR_SA
is mod 2 ** Standard
'Address_Size;
240 function To_XDR_SA
is new UC
(System
.Address
, XDR_SA
);
241 function To_XDR_SA
is new UC
(XDR_SA
, System
.Address
);
243 -- Enumerations have the same representation as signed integers.
244 -- Enumerations are handy for describing subsets of the integers.
246 -- Booleans are important enough and occur frequently enough to warrant
247 -- their own explicit type in the standard. Booleans are declared as
248 -- an enumeration, with FALSE = 0 and TRUE = 1.
250 -- The standard defines a string of n (numbered 0 through n-1) ASCII
251 -- bytes to be the number n encoded as an unsigned integer (as described
252 -- above), and followed by the n bytes of the string. Byte m of the string
253 -- always precedes byte m+1 of the string, and byte 0 of the string always
254 -- follows the string's length. If n is not a multiple of four, then the
255 -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make
256 -- the total byte count a multiple of four.
258 -- To fit with XDR string, do not consider character as an enumeration
262 subtype XDR_S_C
is SEA
(1 .. C_L
);
264 -- Consider Wide_Character as an enumeration type
266 WC_L
: constant := 4;
267 subtype XDR_S_WC
is SEA
(1 .. WC_L
);
268 type XDR_WC
is mod BB
** WC_L
;
270 -- Optimization: if we already have the correct Bit_Order, then some
271 -- computations can be avoided since the source and the target will be
272 -- identical anyway. They will be replaced by direct unchecked
275 Optimize_Integers
: constant Boolean :=
276 Default_Bit_Order
= High_Order_First
;
282 function I_AD
(Stream
: not null access RST
) return Fat_Pointer
is
286 FP
.P1
:= I_AS
(Stream
).P1
;
287 FP
.P2
:= I_AS
(Stream
).P1
;
296 function I_AS
(Stream
: not null access RST
) return Thin_Pointer
is
302 Ada
.Streams
.Read
(Stream
.all, S
, L
);
307 for N
in S
'Range loop
308 U
:= U
* BB
+ XDR_TM
(S
(N
));
311 return (P1
=> To_XDR_SA
(XDR_SA
(U
)));
319 function I_B
(Stream
: not null access RST
) return Boolean is
321 case I_SSU
(Stream
) is
322 when 0 => return False;
323 when 1 => return True;
324 when others => raise Data_Error
;
332 function I_C
(Stream
: not null access RST
) return Character is
337 Ada
.Streams
.Read
(Stream
.all, S
, L
);
343 -- Use Ada requirements on Character representation clause
345 return Character'Val (S
(1));
353 function I_F
(Stream
: not null access RST
) return Float is
354 I
: constant Precision
:= Single
;
355 E_Size
: Integer renames Fields
(I
).E_Size
;
356 E_Bias
: Integer renames Fields
(I
).E_Bias
;
357 E_Last
: Integer renames Fields
(I
).E_Last
;
358 F_Mask
: SE
renames Fields
(I
).F_Mask
;
359 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
360 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
361 F_Size
: Integer renames Fields
(I
).F_Size
;
364 Exponent
: Long_Unsigned
;
365 Fraction
: Long_Unsigned
;
371 Ada
.Streams
.Read
(Stream
.all, S
, L
);
377 -- Extract Fraction, Sign and Exponent
379 Fraction
:= Long_Unsigned
(S
(F_L
+ 1 - F_Bytes
) and F_Mask
);
380 for N
in F_L
+ 2 - F_Bytes
.. F_L
loop
381 Fraction
:= Fraction
* BB
+ Long_Unsigned
(S
(N
));
383 Result
:= Float'Scaling (Float (Fraction
), -F_Size
);
387 Exponent
:= Long_Unsigned
(S
(1) - BS
);
390 Exponent
:= Long_Unsigned
(S
(1));
393 for N
in 2 .. E_Bytes
loop
394 Exponent
:= Exponent
* BB
+ Long_Unsigned
(S
(N
));
396 Exponent
:= Shift_Right
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
400 if Integer (Exponent
) = E_Last
then
401 raise Constraint_Error
;
403 elsif Exponent
= 0 then
410 -- Denormalized float
413 Result
:= Float'Scaling (Result
, 1 - E_Bias
);
419 Result
:= Float'Scaling
420 (1.0 + Result
, Integer (Exponent
) - E_Bias
);
434 function I_I
(Stream
: not null access RST
) return Integer is
440 Ada
.Streams
.Read
(Stream
.all, S
, L
);
445 elsif Optimize_Integers
then
446 return XDR_S_I_To_Integer
(S
);
449 for N
in S
'Range loop
450 U
:= U
* BB
+ XDR_U
(S
(N
));
453 -- Test sign and apply two complement notation
459 return Integer (-((XDR_U
'Last xor U
) + 1));
468 function I_LF
(Stream
: not null access RST
) return Long_Float is
469 I
: constant Precision
:= Double
;
470 E_Size
: Integer renames Fields
(I
).E_Size
;
471 E_Bias
: Integer renames Fields
(I
).E_Bias
;
472 E_Last
: Integer renames Fields
(I
).E_Last
;
473 F_Mask
: SE
renames Fields
(I
).F_Mask
;
474 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
475 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
476 F_Size
: Integer renames Fields
(I
).F_Size
;
479 Exponent
: Long_Unsigned
;
480 Fraction
: Long_Long_Unsigned
;
486 Ada
.Streams
.Read
(Stream
.all, S
, L
);
492 -- Extract Fraction, Sign and Exponent
494 Fraction
:= Long_Long_Unsigned
(S
(LF_L
+ 1 - F_Bytes
) and F_Mask
);
495 for N
in LF_L
+ 2 - F_Bytes
.. LF_L
loop
496 Fraction
:= Fraction
* BB
+ Long_Long_Unsigned
(S
(N
));
499 Result
:= Long_Float'Scaling (Long_Float (Fraction
), -F_Size
);
503 Exponent
:= Long_Unsigned
(S
(1) - BS
);
506 Exponent
:= Long_Unsigned
(S
(1));
509 for N
in 2 .. E_Bytes
loop
510 Exponent
:= Exponent
* BB
+ Long_Unsigned
(S
(N
));
513 Exponent
:= Shift_Right
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
517 if Integer (Exponent
) = E_Last
then
518 raise Constraint_Error
;
520 elsif Exponent
= 0 then
527 -- Denormalized float
530 Result
:= Long_Float'Scaling (Result
, 1 - E_Bias
);
536 Result
:= Long_Float'Scaling
537 (1.0 + Result
, Integer (Exponent
) - E_Bias
);
551 function I_LI
(Stream
: not null access RST
) return Long_Integer is
555 X
: Long_Unsigned
:= 0;
558 Ada
.Streams
.Read
(Stream
.all, S
, L
);
563 elsif Optimize_Integers
then
564 return Long_Integer (XDR_S_LI_To_Long_Long_Integer
(S
));
568 -- Compute using machine unsigned
569 -- rather than long_long_unsigned
571 for N
in S
'Range loop
572 U
:= U
* BB
+ Unsigned
(S
(N
));
574 -- We have filled an unsigned
577 X
:= Shift_Left
(X
, US
) + Long_Unsigned
(U
);
582 -- Test sign and apply two complement notation
585 return Long_Integer (X
);
587 return Long_Integer (-((Long_Unsigned
'Last xor X
) + 1));
597 function I_LLF
(Stream
: not null access RST
) return Long_Long_Float is
598 I
: constant Precision
:= Quadruple
;
599 E_Size
: Integer renames Fields
(I
).E_Size
;
600 E_Bias
: Integer renames Fields
(I
).E_Bias
;
601 E_Last
: Integer renames Fields
(I
).E_Last
;
602 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
603 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
604 F_Size
: Integer renames Fields
(I
).F_Size
;
607 Exponent
: Long_Unsigned
;
608 Fraction_1
: Long_Long_Unsigned
:= 0;
609 Fraction_2
: Long_Long_Unsigned
:= 0;
610 Result
: Long_Long_Float;
611 HF
: constant Natural := F_Size
/ 2;
612 S
: SEA
(1 .. LLF_L
);
616 Ada
.Streams
.Read
(Stream
.all, S
, L
);
622 -- Extract Fraction, Sign and Exponent
624 for I
in LLF_L
- F_Bytes
+ 1 .. LLF_L
- 7 loop
625 Fraction_1
:= Fraction_1
* BB
+ Long_Long_Unsigned
(S
(I
));
628 for I
in SEO
(LLF_L
- 6) .. SEO
(LLF_L
) loop
629 Fraction_2
:= Fraction_2
* BB
+ Long_Long_Unsigned
(S
(I
));
632 Result
:= Long_Long_Float'Scaling (Long_Long_Float (Fraction_2
), -HF
);
633 Result
:= Long_Long_Float (Fraction_1
) + Result
;
634 Result
:= Long_Long_Float'Scaling (Result
, HF
- F_Size
);
638 Exponent
:= Long_Unsigned
(S
(1) - BS
);
641 Exponent
:= Long_Unsigned
(S
(1));
644 for N
in 2 .. E_Bytes
loop
645 Exponent
:= Exponent
* BB
+ Long_Unsigned
(S
(N
));
648 Exponent
:= Shift_Right
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
652 if Integer (Exponent
) = E_Last
then
653 raise Constraint_Error
;
655 elsif Exponent
= 0 then
659 if Fraction_1
= 0 and then Fraction_2
= 0 then
662 -- Denormalized float
665 Result
:= Long_Long_Float'Scaling (Result
, 1 - E_Bias
);
671 Result
:= Long_Long_Float'Scaling
672 (1.0 + Result
, Integer (Exponent
) - E_Bias
);
686 function I_LLI
(Stream
: not null access RST
) return Long_Long_Integer is
690 X
: Long_Long_Unsigned
:= 0;
693 Ada
.Streams
.Read
(Stream
.all, S
, L
);
697 elsif Optimize_Integers
then
698 return XDR_S_LLI_To_Long_Long_Integer
(S
);
701 -- Compute using machine unsigned for computing
702 -- rather than long_long_unsigned.
704 for N
in S
'Range loop
705 U
:= U
* BB
+ Unsigned
(S
(N
));
707 -- We have filled an unsigned
710 X
:= Shift_Left
(X
, US
) + Long_Long_Unsigned
(U
);
715 -- Test sign and apply two complement notation
718 return Long_Long_Integer (X
);
720 return Long_Long_Integer (-((Long_Long_Unsigned
'Last xor X
) + 1));
729 function I_LLU
(Stream
: not null access RST
) return Long_Long_Unsigned
is
733 X
: Long_Long_Unsigned
:= 0;
736 Ada
.Streams
.Read
(Stream
.all, S
, L
);
740 elsif Optimize_Integers
then
741 return XDR_S_LLU_To_Long_Long_Unsigned
(S
);
744 -- Compute using machine unsigned
745 -- rather than long_long_unsigned.
747 for N
in S
'Range loop
748 U
:= U
* BB
+ Unsigned
(S
(N
));
750 -- We have filled an unsigned
753 X
:= Shift_Left
(X
, US
) + Long_Long_Unsigned
(U
);
766 function I_LU
(Stream
: not null access RST
) return Long_Unsigned
is
770 X
: Long_Unsigned
:= 0;
773 Ada
.Streams
.Read
(Stream
.all, S
, L
);
777 elsif Optimize_Integers
then
778 return Long_Unsigned
(XDR_S_LU_To_Long_Long_Unsigned
(S
));
781 -- Compute using machine unsigned
782 -- rather than long_unsigned.
784 for N
in S
'Range loop
785 U
:= U
* BB
+ Unsigned
(S
(N
));
787 -- We have filled an unsigned
790 X
:= Shift_Left
(X
, US
) + Long_Unsigned
(U
);
803 function I_SF
(Stream
: not null access RST
) return Short_Float is
804 I
: constant Precision
:= Single
;
805 E_Size
: Integer renames Fields
(I
).E_Size
;
806 E_Bias
: Integer renames Fields
(I
).E_Bias
;
807 E_Last
: Integer renames Fields
(I
).E_Last
;
808 F_Mask
: SE
renames Fields
(I
).F_Mask
;
809 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
810 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
811 F_Size
: Integer renames Fields
(I
).F_Size
;
813 Exponent
: Long_Unsigned
;
814 Fraction
: Long_Unsigned
;
816 Result
: Short_Float;
821 Ada
.Streams
.Read
(Stream
.all, S
, L
);
827 -- Extract Fraction, Sign and Exponent
829 Fraction
:= Long_Unsigned
(S
(SF_L
+ 1 - F_Bytes
) and F_Mask
);
830 for N
in SF_L
+ 2 - F_Bytes
.. SF_L
loop
831 Fraction
:= Fraction
* BB
+ Long_Unsigned
(S
(N
));
833 Result
:= Short_Float'Scaling (Short_Float (Fraction
), -F_Size
);
837 Exponent
:= Long_Unsigned
(S
(1) - BS
);
840 Exponent
:= Long_Unsigned
(S
(1));
843 for N
in 2 .. E_Bytes
loop
844 Exponent
:= Exponent
* BB
+ Long_Unsigned
(S
(N
));
846 Exponent
:= Shift_Right
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
850 if Integer (Exponent
) = E_Last
then
851 raise Constraint_Error
;
853 elsif Exponent
= 0 then
860 -- Denormalized float
863 Result
:= Short_Float'Scaling (Result
, 1 - E_Bias
);
869 Result
:= Short_Float'Scaling
870 (1.0 + Result
, Integer (Exponent
) - E_Bias
);
884 function I_SI
(Stream
: not null access RST
) return Short_Integer is
890 Ada
.Streams
.Read
(Stream
.all, S
, L
);
895 elsif Optimize_Integers
then
896 return XDR_S_SI_To_Short_Integer
(S
);
899 for N
in S
'Range loop
900 U
:= U
* BB
+ XDR_SU
(S
(N
));
903 -- Test sign and apply two complement notation
906 return Short_Integer (U
);
908 return Short_Integer (-((XDR_SU
'Last xor U
) + 1));
917 function I_SSI
(Stream
: not null access RST
) return Short_Short_Integer is
923 Ada
.Streams
.Read
(Stream
.all, S
, L
);
927 elsif Optimize_Integers
then
928 return XDR_S_SSI_To_Short_Short_Integer
(S
);
930 U
:= XDR_SSU
(S
(1));
932 -- Test sign and apply two complement notation
935 return Short_Short_Integer (U
);
937 return Short_Short_Integer (-((XDR_SSU
'Last xor U
) + 1));
946 function I_SSU
(Stream
: not null access RST
) return Short_Short_Unsigned
is
952 Ada
.Streams
.Read
(Stream
.all, S
, L
);
957 U
:= XDR_SSU
(S
(1));
959 return Short_Short_Unsigned
(U
);
967 function I_SU
(Stream
: not null access RST
) return Short_Unsigned
is
973 Ada
.Streams
.Read
(Stream
.all, S
, L
);
977 elsif Optimize_Integers
then
978 return XDR_S_SU_To_Short_Unsigned
(S
);
980 for N
in S
'Range loop
981 U
:= U
* BB
+ XDR_SU
(S
(N
));
984 return Short_Unsigned
(U
);
992 function I_U
(Stream
: not null access RST
) return Unsigned
is
998 Ada
.Streams
.Read
(Stream
.all, S
, L
);
1003 elsif Optimize_Integers
then
1004 return XDR_S_U_To_Unsigned
(S
);
1007 for N
in S
'Range loop
1008 U
:= U
* BB
+ XDR_U
(S
(N
));
1011 return Unsigned
(U
);
1019 function I_WC
(Stream
: not null access RST
) return Wide_Character is
1025 Ada
.Streams
.Read
(Stream
.all, S
, L
);
1030 for N
in S
'Range loop
1031 U
:= U
* BB
+ XDR_WC
(S
(N
));
1034 -- Use Ada requirements on Wide_Character representation clause
1036 return Wide_Character'Val (U
);
1044 procedure W_AD
(Stream
: not null access RST
; Item
: Fat_Pointer
) is
1049 U
:= XDR_TM
(To_XDR_SA
(Item
.P1
));
1050 for N
in reverse S
'Range loop
1051 S
(N
) := SE
(U
mod BB
);
1055 Ada
.Streams
.Write
(Stream
.all, S
);
1057 U
:= XDR_TM
(To_XDR_SA
(Item
.P2
));
1058 for N
in reverse S
'Range loop
1059 S
(N
) := SE
(U
mod BB
);
1063 Ada
.Streams
.Write
(Stream
.all, S
);
1074 procedure W_AS
(Stream
: not null access RST
; Item
: Thin_Pointer
) is
1076 U
: XDR_TM
:= XDR_TM
(To_XDR_SA
(Item
.P1
));
1079 for N
in reverse S
'Range loop
1080 S
(N
) := SE
(U
mod BB
);
1084 Ada
.Streams
.Write
(Stream
.all, S
);
1095 procedure W_B
(Stream
: not null access RST
; Item
: Boolean) is
1108 procedure W_C
(Stream
: not null access RST
; Item
: Character) is
1111 pragma Assert
(C_L
= 1);
1115 -- Use Ada requirements on Character representation clause
1117 S
(1) := SE
(Character'Pos (Item
));
1119 Ada
.Streams
.Write
(Stream
.all, S
);
1126 procedure W_F
(Stream
: not null access RST
; Item
: Float) is
1127 I
: constant Precision
:= Single
;
1128 E_Size
: Integer renames Fields
(I
).E_Size
;
1129 E_Bias
: Integer renames Fields
(I
).E_Bias
;
1130 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
1131 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
1132 F_Size
: Integer renames Fields
(I
).F_Size
;
1133 F_Mask
: SE
renames Fields
(I
).F_Mask
;
1135 Exponent
: Long_Unsigned
;
1136 Fraction
: Long_Unsigned
;
1140 S
: SEA
(1 .. F_L
) := (others => 0);
1143 if not Item
'Valid then
1144 raise Constraint_Error
;
1149 Positive := (0.0 <= Item
);
1159 E
:= Float'Exponent (F
) - 1;
1161 -- Denormalized float
1163 if E
<= -E_Bias
then
1164 F
:= Float'Scaling (F
, F_Size
+ E_Bias
- 1);
1167 F
:= Float'Scaling (Float'Fraction (F
), F_Size
+ 1);
1170 -- Compute Exponent and Fraction
1172 Exponent
:= Long_Unsigned
(E
+ E_Bias
);
1173 Fraction
:= Long_Unsigned
(F
* 2.0) / 2;
1178 for I
in reverse F_L
- F_Bytes
+ 1 .. F_L
loop
1179 S
(I
) := SE
(Fraction
mod BB
);
1180 Fraction
:= Fraction
/ BB
;
1183 -- Remove implicit bit
1185 S
(F_L
- F_Bytes
+ 1) := S
(F_L
- F_Bytes
+ 1) and F_Mask
;
1187 -- Store Exponent (not always at the beginning of a byte)
1189 Exponent
:= Shift_Left
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
1190 for N
in reverse 1 .. E_Bytes
loop
1191 S
(N
) := SE
(Exponent
mod BB
) + S
(N
);
1192 Exponent
:= Exponent
/ BB
;
1197 if not Positive then
1198 S
(1) := S
(1) + BS
;
1201 Ada
.Streams
.Write
(Stream
.all, S
);
1208 procedure W_I
(Stream
: not null access RST
; Item
: Integer) is
1213 if Optimize_Integers
then
1214 S
:= Integer_To_XDR_S_I
(Item
);
1217 -- Test sign and apply two complement notation
1220 U
:= XDR_U
'Last xor XDR_U
(-(Item
+ 1));
1225 for N
in reverse S
'Range loop
1226 S
(N
) := SE
(U
mod BB
);
1235 Ada
.Streams
.Write
(Stream
.all, S
);
1242 procedure W_LF
(Stream
: not null access RST
; Item
: Long_Float) is
1243 I
: constant Precision
:= Double
;
1244 E_Size
: Integer renames Fields
(I
).E_Size
;
1245 E_Bias
: Integer renames Fields
(I
).E_Bias
;
1246 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
1247 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
1248 F_Size
: Integer renames Fields
(I
).F_Size
;
1249 F_Mask
: SE
renames Fields
(I
).F_Mask
;
1251 Exponent
: Long_Unsigned
;
1252 Fraction
: Long_Long_Unsigned
;
1256 S
: SEA
(1 .. LF_L
) := (others => 0);
1259 if not Item
'Valid then
1260 raise Constraint_Error
;
1265 Positive := (0.0 <= Item
);
1275 E
:= Long_Float'Exponent (F
) - 1;
1277 -- Denormalized float
1279 if E
<= -E_Bias
then
1281 F
:= Long_Float'Scaling (F
, F_Size
+ E_Bias
- 1);
1283 F
:= Long_Float'Scaling (F
, F_Size
- E
);
1286 -- Compute Exponent and Fraction
1288 Exponent
:= Long_Unsigned
(E
+ E_Bias
);
1289 Fraction
:= Long_Long_Unsigned
(F
* 2.0) / 2;
1294 for I
in reverse LF_L
- F_Bytes
+ 1 .. LF_L
loop
1295 S
(I
) := SE
(Fraction
mod BB
);
1296 Fraction
:= Fraction
/ BB
;
1299 -- Remove implicit bit
1301 S
(LF_L
- F_Bytes
+ 1) := S
(LF_L
- F_Bytes
+ 1) and F_Mask
;
1303 -- Store Exponent (not always at the beginning of a byte)
1305 Exponent
:= Shift_Left
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
1306 for N
in reverse 1 .. E_Bytes
loop
1307 S
(N
) := SE
(Exponent
mod BB
) + S
(N
);
1308 Exponent
:= Exponent
/ BB
;
1313 if not Positive then
1314 S
(1) := S
(1) + BS
;
1317 Ada
.Streams
.Write
(Stream
.all, S
);
1324 procedure W_LI
(Stream
: not null access RST
; Item
: Long_Integer) is
1330 if Optimize_Integers
then
1331 S
:= Long_Long_Integer_To_XDR_S_LI
(Long_Long_Integer (Item
));
1334 -- Test sign and apply two complement notation
1337 X
:= Long_Unsigned
'Last xor Long_Unsigned
(-(Item
+ 1));
1339 X
:= Long_Unsigned
(Item
);
1342 -- Compute using machine unsigned
1343 -- rather than long_unsigned.
1345 for N
in reverse S
'Range loop
1347 -- We have filled an unsigned
1349 if (LU_L
- N
) mod UB
= 0 then
1350 U
:= Unsigned
(X
and UL
);
1351 X
:= Shift_Right
(X
, US
);
1354 S
(N
) := SE
(U
mod BB
);
1363 Ada
.Streams
.Write
(Stream
.all, S
);
1370 procedure W_LLF
(Stream
: not null access RST
; Item
: Long_Long_Float) is
1371 I
: constant Precision
:= Quadruple
;
1372 E_Size
: Integer renames Fields
(I
).E_Size
;
1373 E_Bias
: Integer renames Fields
(I
).E_Bias
;
1374 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
1375 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
1376 F_Size
: Integer renames Fields
(I
).F_Size
;
1378 HFS
: constant Integer := F_Size
/ 2;
1380 Exponent
: Long_Unsigned
;
1381 Fraction_1
: Long_Long_Unsigned
;
1382 Fraction_2
: Long_Long_Unsigned
;
1385 F
: Long_Long_Float := Item
;
1386 S
: SEA
(1 .. LLF_L
) := (others => 0);
1389 if not Item
'Valid then
1390 raise Constraint_Error
;
1395 Positive := (0.0 <= Item
);
1408 E
:= Long_Long_Float'Exponent (F
) - 1;
1410 -- Denormalized float
1412 if E
<= -E_Bias
then
1413 F
:= Long_Long_Float'Scaling (F
, E_Bias
- 1);
1416 F
:= Long_Long_Float'Scaling
1417 (Long_Long_Float'Fraction (F
), 1);
1420 -- Compute Exponent and Fraction
1422 Exponent
:= Long_Unsigned
(E
+ E_Bias
);
1423 F
:= Long_Long_Float'Scaling (F
, F_Size
- HFS
);
1424 Fraction_1
:= Long_Long_Unsigned
(Long_Long_Float'Floor (F
));
1425 F
:= Long_Long_Float (F
- Long_Long_Float (Fraction_1
));
1426 F
:= Long_Long_Float'Scaling (F
, HFS
);
1427 Fraction_2
:= Long_Long_Unsigned
(Long_Long_Float'Floor (F
));
1432 for I
in reverse LLF_L
- F_Bytes
+ 1 .. LLF_L
- 7 loop
1433 S
(I
) := SE
(Fraction_1
mod BB
);
1434 Fraction_1
:= Fraction_1
/ BB
;
1439 for I
in reverse LLF_L
- 6 .. LLF_L
loop
1440 S
(SEO
(I
)) := SE
(Fraction_2
mod BB
);
1441 Fraction_2
:= Fraction_2
/ BB
;
1444 -- Store Exponent (not always at the beginning of a byte)
1446 Exponent
:= Shift_Left
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
1447 for N
in reverse 1 .. E_Bytes
loop
1448 S
(N
) := SE
(Exponent
mod BB
) + S
(N
);
1449 Exponent
:= Exponent
/ BB
;
1454 if not Positive then
1455 S
(1) := S
(1) + BS
;
1458 Ada
.Streams
.Write
(Stream
.all, S
);
1465 procedure W_LLI
(Stream
: not null access RST
;
1466 Item
: Long_Long_Integer)
1470 X
: Long_Long_Unsigned
;
1473 if Optimize_Integers
then
1474 S
:= Long_Long_Integer_To_XDR_S_LLI
(Item
);
1477 -- Test sign and apply two complement notation
1480 X
:= Long_Long_Unsigned
'Last xor Long_Long_Unsigned
(-(Item
+ 1));
1482 X
:= Long_Long_Unsigned
(Item
);
1485 -- Compute using machine unsigned
1486 -- rather than long_long_unsigned.
1488 for N
in reverse S
'Range loop
1490 -- We have filled an unsigned
1492 if (LLU_L
- N
) mod UB
= 0 then
1493 U
:= Unsigned
(X
and UL
);
1494 X
:= Shift_Right
(X
, US
);
1497 S
(N
) := SE
(U
mod BB
);
1506 Ada
.Streams
.Write
(Stream
.all, S
);
1513 procedure W_LLU
(Stream
: not null access RST
;
1514 Item
: Long_Long_Unsigned
) is
1517 X
: Long_Long_Unsigned
:= Item
;
1520 if Optimize_Integers
then
1521 S
:= Long_Long_Unsigned_To_XDR_S_LLU
(Item
);
1523 -- Compute using machine unsigned
1524 -- rather than long_long_unsigned.
1526 for N
in reverse S
'Range loop
1528 -- We have filled an unsigned
1530 if (LLU_L
- N
) mod UB
= 0 then
1531 U
:= Unsigned
(X
and UL
);
1532 X
:= Shift_Right
(X
, US
);
1535 S
(N
) := SE
(U
mod BB
);
1544 Ada
.Streams
.Write
(Stream
.all, S
);
1551 procedure W_LU
(Stream
: not null access RST
; Item
: Long_Unsigned
) is
1554 X
: Long_Unsigned
:= Item
;
1557 if Optimize_Integers
then
1558 S
:= Long_Long_Unsigned_To_XDR_S_LU
(Long_Long_Unsigned
(Item
));
1560 -- Compute using machine unsigned
1561 -- rather than long_unsigned.
1563 for N
in reverse S
'Range loop
1565 -- We have filled an unsigned
1567 if (LU_L
- N
) mod UB
= 0 then
1568 U
:= Unsigned
(X
and UL
);
1569 X
:= Shift_Right
(X
, US
);
1571 S
(N
) := SE
(U
mod BB
);
1580 Ada
.Streams
.Write
(Stream
.all, S
);
1587 procedure W_SF
(Stream
: not null access RST
; Item
: Short_Float) is
1588 I
: constant Precision
:= Single
;
1589 E_Size
: Integer renames Fields
(I
).E_Size
;
1590 E_Bias
: Integer renames Fields
(I
).E_Bias
;
1591 E_Bytes
: SEO
renames Fields
(I
).E_Bytes
;
1592 F_Bytes
: SEO
renames Fields
(I
).F_Bytes
;
1593 F_Size
: Integer renames Fields
(I
).F_Size
;
1594 F_Mask
: SE
renames Fields
(I
).F_Mask
;
1596 Exponent
: Long_Unsigned
;
1597 Fraction
: Long_Unsigned
;
1601 S
: SEA
(1 .. SF_L
) := (others => 0);
1604 if not Item
'Valid then
1605 raise Constraint_Error
;
1610 Positive := (0.0 <= Item
);
1620 E
:= Short_Float'Exponent (F
) - 1;
1622 -- Denormalized float
1624 if E
<= -E_Bias
then
1626 F
:= Short_Float'Scaling (F
, F_Size
+ E_Bias
- 1);
1628 F
:= Short_Float'Scaling (F
, F_Size
- E
);
1631 -- Compute Exponent and Fraction
1633 Exponent
:= Long_Unsigned
(E
+ E_Bias
);
1634 Fraction
:= Long_Unsigned
(F
* 2.0) / 2;
1639 for I
in reverse SF_L
- F_Bytes
+ 1 .. SF_L
loop
1640 S
(I
) := SE
(Fraction
mod BB
);
1641 Fraction
:= Fraction
/ BB
;
1644 -- Remove implicit bit
1646 S
(SF_L
- F_Bytes
+ 1) := S
(SF_L
- F_Bytes
+ 1) and F_Mask
;
1648 -- Store Exponent (not always at the beginning of a byte)
1650 Exponent
:= Shift_Left
(Exponent
, Integer (E_Bytes
) * SU
- E_Size
- 1);
1651 for N
in reverse 1 .. E_Bytes
loop
1652 S
(N
) := SE
(Exponent
mod BB
) + S
(N
);
1653 Exponent
:= Exponent
/ BB
;
1658 if not Positive then
1659 S
(1) := S
(1) + BS
;
1662 Ada
.Streams
.Write
(Stream
.all, S
);
1669 procedure W_SI
(Stream
: not null access RST
; Item
: Short_Integer) is
1674 if Optimize_Integers
then
1675 S
:= Short_Integer_To_XDR_S_SI
(Item
);
1678 -- Test sign and apply two complement's notation
1681 U
:= XDR_SU
'Last xor XDR_SU
(-(Item
+ 1));
1686 for N
in reverse S
'Range loop
1687 S
(N
) := SE
(U
mod BB
);
1696 Ada
.Streams
.Write
(Stream
.all, S
);
1704 (Stream
: not null access RST
;
1705 Item
: Short_Short_Integer)
1711 if Optimize_Integers
then
1712 S
:= Short_Short_Integer_To_XDR_S_SSI
(Item
);
1715 -- Test sign and apply two complement's notation
1718 U
:= XDR_SSU
'Last xor XDR_SSU
(-(Item
+ 1));
1720 U
:= XDR_SSU
(Item
);
1726 Ada
.Streams
.Write
(Stream
.all, S
);
1734 (Stream
: not null access RST
;
1735 Item
: Short_Short_Unsigned
)
1737 U
: constant XDR_SSU
:= XDR_SSU
(Item
);
1743 Ada
.Streams
.Write
(Stream
.all, S
);
1750 procedure W_SU
(Stream
: not null access RST
; Item
: Short_Unsigned
) is
1752 U
: XDR_SU
:= XDR_SU
(Item
);
1755 if Optimize_Integers
then
1756 S
:= Short_Unsigned_To_XDR_S_SU
(Item
);
1758 for N
in reverse S
'Range loop
1759 S
(N
) := SE
(U
mod BB
);
1768 Ada
.Streams
.Write
(Stream
.all, S
);
1775 procedure W_U
(Stream
: not null access RST
; Item
: Unsigned
) is
1777 U
: XDR_U
:= XDR_U
(Item
);
1780 if Optimize_Integers
then
1781 S
:= Unsigned_To_XDR_S_U
(Item
);
1783 for N
in reverse S
'Range loop
1784 S
(N
) := SE
(U
mod BB
);
1793 Ada
.Streams
.Write
(Stream
.all, S
);
1800 procedure W_WC
(Stream
: not null access RST
; Item
: Wide_Character) is
1806 -- Use Ada requirements on Wide_Character representation clause
1808 U
:= XDR_WC
(Wide_Character'Pos (Item
));
1810 for N
in reverse S
'Range loop
1811 S
(N
) := SE
(U
mod BB
);
1815 Ada
.Streams
.Write
(Stream
.all, S
);
1822 end System
.Stream_Attributes
;