Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/s-stratt__xdr.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;