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