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