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 36with Ada.IO_Exceptions; 37with Ada.Streams; use Ada.Streams; 38with Ada.Unchecked_Conversion; 39 40package 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 1896end System.Stream_Attributes; 1897