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-2012, 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 function Block_IO_OK return Boolean is 287 begin 288 return False; 289 end Block_IO_OK; 290 291 ---------- 292 -- I_AD -- 293 ---------- 294 295 function I_AD (Stream : not null access RST) return Fat_Pointer is 296 FP : Fat_Pointer; 297 298 begin 299 FP.P1 := I_AS (Stream).P1; 300 FP.P2 := I_AS (Stream).P1; 301 302 return FP; 303 end I_AD; 304 305 ---------- 306 -- I_AS -- 307 ---------- 308 309 function I_AS (Stream : not null access RST) return Thin_Pointer is 310 S : XDR_S_TM; 311 L : SEO; 312 U : XDR_TM := 0; 313 314 begin 315 Ada.Streams.Read (Stream.all, S, L); 316 317 if L /= S'Last then 318 raise Data_Error; 319 320 else 321 for N in S'Range loop 322 U := U * BB + XDR_TM (S (N)); 323 end loop; 324 325 return (P1 => To_XDR_SA (XDR_SA (U))); 326 end if; 327 end I_AS; 328 329 --------- 330 -- I_B -- 331 --------- 332 333 function I_B (Stream : not null access RST) return Boolean is 334 begin 335 case I_SSU (Stream) is 336 when 0 => return False; 337 when 1 => return True; 338 when others => raise Data_Error; 339 end case; 340 end I_B; 341 342 --------- 343 -- I_C -- 344 --------- 345 346 function I_C (Stream : not null access RST) return Character is 347 S : XDR_S_C; 348 L : SEO; 349 350 begin 351 Ada.Streams.Read (Stream.all, S, L); 352 353 if L /= S'Last then 354 raise Data_Error; 355 356 else 357 -- Use Ada requirements on Character representation clause 358 359 return Character'Val (S (1)); 360 end if; 361 end I_C; 362 363 --------- 364 -- I_F -- 365 --------- 366 367 function I_F (Stream : not null access RST) return Float is 368 I : constant Precision := Single; 369 E_Size : Integer renames Fields (I).E_Size; 370 E_Bias : Integer renames Fields (I).E_Bias; 371 E_Last : Integer renames Fields (I).E_Last; 372 F_Mask : SE renames Fields (I).F_Mask; 373 E_Bytes : SEO renames Fields (I).E_Bytes; 374 F_Bytes : SEO renames Fields (I).F_Bytes; 375 F_Size : Integer renames Fields (I).F_Size; 376 377 Is_Positive : Boolean; 378 Exponent : Long_Unsigned; 379 Fraction : Long_Unsigned; 380 Result : Float; 381 S : SEA (1 .. F_L); 382 L : SEO; 383 384 begin 385 Ada.Streams.Read (Stream.all, S, L); 386 387 if L /= S'Last then 388 raise Data_Error; 389 end if; 390 391 -- Extract Fraction, Sign and Exponent 392 393 Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); 394 for N in F_L + 2 - F_Bytes .. F_L loop 395 Fraction := Fraction * BB + Long_Unsigned (S (N)); 396 end loop; 397 Result := Float'Scaling (Float (Fraction), -F_Size); 398 399 if BS <= S (1) then 400 Is_Positive := False; 401 Exponent := Long_Unsigned (S (1) - BS); 402 else 403 Is_Positive := True; 404 Exponent := Long_Unsigned (S (1)); 405 end if; 406 407 for N in 2 .. E_Bytes loop 408 Exponent := Exponent * BB + Long_Unsigned (S (N)); 409 end loop; 410 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 411 412 -- NaN or Infinities 413 414 if Integer (Exponent) = E_Last then 415 raise Constraint_Error; 416 417 elsif Exponent = 0 then 418 419 -- Signed zeros 420 421 if Fraction = 0 then 422 null; 423 424 -- Denormalized float 425 426 else 427 Result := Float'Scaling (Result, 1 - E_Bias); 428 end if; 429 430 -- Normalized float 431 432 else 433 Result := Float'Scaling 434 (1.0 + Result, Integer (Exponent) - E_Bias); 435 end if; 436 437 if not Is_Positive then 438 Result := -Result; 439 end if; 440 441 return Result; 442 end I_F; 443 444 --------- 445 -- I_I -- 446 --------- 447 448 function I_I (Stream : not null access RST) return Integer is 449 S : XDR_S_I; 450 L : SEO; 451 U : XDR_U := 0; 452 453 begin 454 Ada.Streams.Read (Stream.all, S, L); 455 456 if L /= S'Last then 457 raise Data_Error; 458 459 elsif Optimize_Integers then 460 return XDR_S_I_To_Integer (S); 461 462 else 463 for N in S'Range loop 464 U := U * BB + XDR_U (S (N)); 465 end loop; 466 467 -- Test sign and apply two complement notation 468 469 if S (1) < BL then 470 return Integer (U); 471 472 else 473 return Integer (-((XDR_U'Last xor U) + 1)); 474 end if; 475 end if; 476 end I_I; 477 478 ---------- 479 -- I_LF -- 480 ---------- 481 482 function I_LF (Stream : not null access RST) return Long_Float is 483 I : constant Precision := Double; 484 E_Size : Integer renames Fields (I).E_Size; 485 E_Bias : Integer renames Fields (I).E_Bias; 486 E_Last : Integer renames Fields (I).E_Last; 487 F_Mask : SE renames Fields (I).F_Mask; 488 E_Bytes : SEO renames Fields (I).E_Bytes; 489 F_Bytes : SEO renames Fields (I).F_Bytes; 490 F_Size : Integer renames Fields (I).F_Size; 491 492 Is_Positive : Boolean; 493 Exponent : Long_Unsigned; 494 Fraction : Long_Long_Unsigned; 495 Result : Long_Float; 496 S : SEA (1 .. LF_L); 497 L : SEO; 498 499 begin 500 Ada.Streams.Read (Stream.all, S, L); 501 502 if L /= S'Last then 503 raise Data_Error; 504 end if; 505 506 -- Extract Fraction, Sign and Exponent 507 508 Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); 509 for N in LF_L + 2 - F_Bytes .. LF_L loop 510 Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); 511 end loop; 512 513 Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); 514 515 if BS <= S (1) then 516 Is_Positive := False; 517 Exponent := Long_Unsigned (S (1) - BS); 518 else 519 Is_Positive := True; 520 Exponent := Long_Unsigned (S (1)); 521 end if; 522 523 for N in 2 .. E_Bytes loop 524 Exponent := Exponent * BB + Long_Unsigned (S (N)); 525 end loop; 526 527 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 528 529 -- NaN or Infinities 530 531 if Integer (Exponent) = E_Last then 532 raise Constraint_Error; 533 534 elsif Exponent = 0 then 535 536 -- Signed zeros 537 538 if Fraction = 0 then 539 null; 540 541 -- Denormalized float 542 543 else 544 Result := Long_Float'Scaling (Result, 1 - E_Bias); 545 end if; 546 547 -- Normalized float 548 549 else 550 Result := Long_Float'Scaling 551 (1.0 + Result, Integer (Exponent) - E_Bias); 552 end if; 553 554 if not Is_Positive then 555 Result := -Result; 556 end if; 557 558 return Result; 559 end I_LF; 560 561 ---------- 562 -- I_LI -- 563 ---------- 564 565 function I_LI (Stream : not null access RST) return Long_Integer is 566 S : XDR_S_LI; 567 L : SEO; 568 U : Unsigned := 0; 569 X : Long_Unsigned := 0; 570 571 begin 572 Ada.Streams.Read (Stream.all, S, L); 573 574 if L /= S'Last then 575 raise Data_Error; 576 577 elsif Optimize_Integers then 578 return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); 579 580 else 581 582 -- Compute using machine unsigned 583 -- rather than long_long_unsigned 584 585 for N in S'Range loop 586 U := U * BB + Unsigned (S (N)); 587 588 -- We have filled an unsigned 589 590 if N mod UB = 0 then 591 X := Shift_Left (X, US) + Long_Unsigned (U); 592 U := 0; 593 end if; 594 end loop; 595 596 -- Test sign and apply two complement notation 597 598 if S (1) < BL then 599 return Long_Integer (X); 600 else 601 return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); 602 end if; 603 604 end if; 605 end I_LI; 606 607 ----------- 608 -- I_LLF -- 609 ----------- 610 611 function I_LLF (Stream : not null access RST) return Long_Long_Float is 612 I : constant Precision := Quadruple; 613 E_Size : Integer renames Fields (I).E_Size; 614 E_Bias : Integer renames Fields (I).E_Bias; 615 E_Last : Integer renames Fields (I).E_Last; 616 E_Bytes : SEO renames Fields (I).E_Bytes; 617 F_Bytes : SEO renames Fields (I).F_Bytes; 618 F_Size : Integer renames Fields (I).F_Size; 619 620 Is_Positive : Boolean; 621 Exponent : Long_Unsigned; 622 Fraction_1 : Long_Long_Unsigned := 0; 623 Fraction_2 : Long_Long_Unsigned := 0; 624 Result : Long_Long_Float; 625 HF : constant Natural := F_Size / 2; 626 S : SEA (1 .. LLF_L); 627 L : SEO; 628 629 begin 630 Ada.Streams.Read (Stream.all, S, L); 631 632 if L /= S'Last then 633 raise Data_Error; 634 end if; 635 636 -- Extract Fraction, Sign and Exponent 637 638 for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop 639 Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); 640 end loop; 641 642 for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop 643 Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); 644 end loop; 645 646 Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); 647 Result := Long_Long_Float (Fraction_1) + Result; 648 Result := Long_Long_Float'Scaling (Result, HF - F_Size); 649 650 if BS <= S (1) then 651 Is_Positive := False; 652 Exponent := Long_Unsigned (S (1) - BS); 653 else 654 Is_Positive := True; 655 Exponent := Long_Unsigned (S (1)); 656 end if; 657 658 for N in 2 .. E_Bytes loop 659 Exponent := Exponent * BB + Long_Unsigned (S (N)); 660 end loop; 661 662 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 663 664 -- NaN or Infinities 665 666 if Integer (Exponent) = E_Last then 667 raise Constraint_Error; 668 669 elsif Exponent = 0 then 670 671 -- Signed zeros 672 673 if Fraction_1 = 0 and then Fraction_2 = 0 then 674 null; 675 676 -- Denormalized float 677 678 else 679 Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); 680 end if; 681 682 -- Normalized float 683 684 else 685 Result := Long_Long_Float'Scaling 686 (1.0 + Result, Integer (Exponent) - E_Bias); 687 end if; 688 689 if not Is_Positive then 690 Result := -Result; 691 end if; 692 693 return Result; 694 end I_LLF; 695 696 ----------- 697 -- I_LLI -- 698 ----------- 699 700 function I_LLI (Stream : not null access RST) return Long_Long_Integer is 701 S : XDR_S_LLI; 702 L : SEO; 703 U : Unsigned := 0; 704 X : Long_Long_Unsigned := 0; 705 706 begin 707 Ada.Streams.Read (Stream.all, S, L); 708 709 if L /= S'Last then 710 raise Data_Error; 711 712 elsif Optimize_Integers then 713 return XDR_S_LLI_To_Long_Long_Integer (S); 714 715 else 716 -- Compute using machine unsigned for computing 717 -- rather than long_long_unsigned. 718 719 for N in S'Range loop 720 U := U * BB + Unsigned (S (N)); 721 722 -- We have filled an unsigned 723 724 if N mod UB = 0 then 725 X := Shift_Left (X, US) + Long_Long_Unsigned (U); 726 U := 0; 727 end if; 728 end loop; 729 730 -- Test sign and apply two complement notation 731 732 if S (1) < BL then 733 return Long_Long_Integer (X); 734 else 735 return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); 736 end if; 737 end if; 738 end I_LLI; 739 740 ----------- 741 -- I_LLU -- 742 ----------- 743 744 function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is 745 S : XDR_S_LLU; 746 L : SEO; 747 U : Unsigned := 0; 748 X : Long_Long_Unsigned := 0; 749 750 begin 751 Ada.Streams.Read (Stream.all, S, L); 752 753 if L /= S'Last then 754 raise Data_Error; 755 756 elsif Optimize_Integers then 757 return XDR_S_LLU_To_Long_Long_Unsigned (S); 758 759 else 760 -- Compute using machine unsigned 761 -- rather than long_long_unsigned. 762 763 for N in S'Range loop 764 U := U * BB + Unsigned (S (N)); 765 766 -- We have filled an unsigned 767 768 if N mod UB = 0 then 769 X := Shift_Left (X, US) + Long_Long_Unsigned (U); 770 U := 0; 771 end if; 772 end loop; 773 774 return X; 775 end if; 776 end I_LLU; 777 778 ---------- 779 -- I_LU -- 780 ---------- 781 782 function I_LU (Stream : not null access RST) return Long_Unsigned is 783 S : XDR_S_LU; 784 L : SEO; 785 U : Unsigned := 0; 786 X : Long_Unsigned := 0; 787 788 begin 789 Ada.Streams.Read (Stream.all, S, L); 790 791 if L /= S'Last then 792 raise Data_Error; 793 794 elsif Optimize_Integers then 795 return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); 796 797 else 798 -- Compute using machine unsigned 799 -- rather than long_unsigned. 800 801 for N in S'Range loop 802 U := U * BB + Unsigned (S (N)); 803 804 -- We have filled an unsigned 805 806 if N mod UB = 0 then 807 X := Shift_Left (X, US) + Long_Unsigned (U); 808 U := 0; 809 end if; 810 end loop; 811 812 return X; 813 end if; 814 end I_LU; 815 816 ---------- 817 -- I_SF -- 818 ---------- 819 820 function I_SF (Stream : not null access RST) return Short_Float is 821 I : constant Precision := Single; 822 E_Size : Integer renames Fields (I).E_Size; 823 E_Bias : Integer renames Fields (I).E_Bias; 824 E_Last : Integer renames Fields (I).E_Last; 825 F_Mask : SE renames Fields (I).F_Mask; 826 E_Bytes : SEO renames Fields (I).E_Bytes; 827 F_Bytes : SEO renames Fields (I).F_Bytes; 828 F_Size : Integer renames Fields (I).F_Size; 829 830 Exponent : Long_Unsigned; 831 Fraction : Long_Unsigned; 832 Is_Positive : Boolean; 833 Result : Short_Float; 834 S : SEA (1 .. SF_L); 835 L : SEO; 836 837 begin 838 Ada.Streams.Read (Stream.all, S, L); 839 840 if L /= S'Last then 841 raise Data_Error; 842 end if; 843 844 -- Extract Fraction, Sign and Exponent 845 846 Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); 847 for N in SF_L + 2 - F_Bytes .. SF_L loop 848 Fraction := Fraction * BB + Long_Unsigned (S (N)); 849 end loop; 850 Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); 851 852 if BS <= S (1) then 853 Is_Positive := False; 854 Exponent := Long_Unsigned (S (1) - BS); 855 else 856 Is_Positive := True; 857 Exponent := Long_Unsigned (S (1)); 858 end if; 859 860 for N in 2 .. E_Bytes loop 861 Exponent := Exponent * BB + Long_Unsigned (S (N)); 862 end loop; 863 Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 864 865 -- NaN or Infinities 866 867 if Integer (Exponent) = E_Last then 868 raise Constraint_Error; 869 870 elsif Exponent = 0 then 871 872 -- Signed zeros 873 874 if Fraction = 0 then 875 null; 876 877 -- Denormalized float 878 879 else 880 Result := Short_Float'Scaling (Result, 1 - E_Bias); 881 end if; 882 883 -- Normalized float 884 885 else 886 Result := Short_Float'Scaling 887 (1.0 + Result, Integer (Exponent) - E_Bias); 888 end if; 889 890 if not Is_Positive then 891 Result := -Result; 892 end if; 893 894 return Result; 895 end I_SF; 896 897 ---------- 898 -- I_SI -- 899 ---------- 900 901 function I_SI (Stream : not null access RST) return Short_Integer is 902 S : XDR_S_SI; 903 L : SEO; 904 U : XDR_SU := 0; 905 906 begin 907 Ada.Streams.Read (Stream.all, S, L); 908 909 if L /= S'Last then 910 raise Data_Error; 911 912 elsif Optimize_Integers then 913 return XDR_S_SI_To_Short_Integer (S); 914 915 else 916 for N in S'Range loop 917 U := U * BB + XDR_SU (S (N)); 918 end loop; 919 920 -- Test sign and apply two complement notation 921 922 if S (1) < BL then 923 return Short_Integer (U); 924 else 925 return Short_Integer (-((XDR_SU'Last xor U) + 1)); 926 end if; 927 end if; 928 end I_SI; 929 930 ----------- 931 -- I_SSI -- 932 ----------- 933 934 function I_SSI (Stream : not null access RST) return Short_Short_Integer is 935 S : XDR_S_SSI; 936 L : SEO; 937 U : XDR_SSU; 938 939 begin 940 Ada.Streams.Read (Stream.all, S, L); 941 942 if L /= S'Last then 943 raise Data_Error; 944 945 elsif Optimize_Integers then 946 return XDR_S_SSI_To_Short_Short_Integer (S); 947 948 else 949 U := XDR_SSU (S (1)); 950 951 -- Test sign and apply two complement notation 952 953 if S (1) < BL then 954 return Short_Short_Integer (U); 955 else 956 return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); 957 end if; 958 end if; 959 end I_SSI; 960 961 ----------- 962 -- I_SSU -- 963 ----------- 964 965 function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is 966 S : XDR_S_SSU; 967 L : SEO; 968 U : XDR_SSU := 0; 969 970 begin 971 Ada.Streams.Read (Stream.all, S, L); 972 973 if L /= S'Last then 974 raise Data_Error; 975 976 else 977 U := XDR_SSU (S (1)); 978 return Short_Short_Unsigned (U); 979 end if; 980 end I_SSU; 981 982 ---------- 983 -- I_SU -- 984 ---------- 985 986 function I_SU (Stream : not null access RST) return Short_Unsigned is 987 S : XDR_S_SU; 988 L : SEO; 989 U : XDR_SU := 0; 990 991 begin 992 Ada.Streams.Read (Stream.all, S, L); 993 994 if L /= S'Last then 995 raise Data_Error; 996 997 elsif Optimize_Integers then 998 return XDR_S_SU_To_Short_Unsigned (S); 999 1000 else 1001 for N in S'Range loop 1002 U := U * BB + XDR_SU (S (N)); 1003 end loop; 1004 1005 return Short_Unsigned (U); 1006 end if; 1007 end I_SU; 1008 1009 --------- 1010 -- I_U -- 1011 --------- 1012 1013 function I_U (Stream : not null access RST) return Unsigned is 1014 S : XDR_S_U; 1015 L : SEO; 1016 U : XDR_U := 0; 1017 1018 begin 1019 Ada.Streams.Read (Stream.all, S, L); 1020 1021 if L /= S'Last then 1022 raise Data_Error; 1023 1024 elsif Optimize_Integers then 1025 return XDR_S_U_To_Unsigned (S); 1026 1027 else 1028 for N in S'Range loop 1029 U := U * BB + XDR_U (S (N)); 1030 end loop; 1031 1032 return Unsigned (U); 1033 end if; 1034 end I_U; 1035 1036 ---------- 1037 -- I_WC -- 1038 ---------- 1039 1040 function I_WC (Stream : not null access RST) return Wide_Character is 1041 S : XDR_S_WC; 1042 L : SEO; 1043 U : XDR_WC := 0; 1044 1045 begin 1046 Ada.Streams.Read (Stream.all, S, L); 1047 1048 if L /= S'Last then 1049 raise Data_Error; 1050 1051 else 1052 for N in S'Range loop 1053 U := U * BB + XDR_WC (S (N)); 1054 end loop; 1055 1056 -- Use Ada requirements on Wide_Character representation clause 1057 1058 return Wide_Character'Val (U); 1059 end if; 1060 end I_WC; 1061 1062 ----------- 1063 -- I_WWC -- 1064 ----------- 1065 1066 function I_WWC (Stream : not null access RST) return Wide_Wide_Character is 1067 S : XDR_S_WWC; 1068 L : SEO; 1069 U : XDR_WWC := 0; 1070 1071 begin 1072 Ada.Streams.Read (Stream.all, S, L); 1073 1074 if L /= S'Last then 1075 raise Data_Error; 1076 1077 else 1078 for N in S'Range loop 1079 U := U * BB + XDR_WWC (S (N)); 1080 end loop; 1081 1082 -- Use Ada requirements on Wide_Wide_Character representation clause 1083 1084 return Wide_Wide_Character'Val (U); 1085 end if; 1086 end I_WWC; 1087 1088 ---------- 1089 -- W_AD -- 1090 ---------- 1091 1092 procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is 1093 S : XDR_S_TM; 1094 U : XDR_TM; 1095 1096 begin 1097 U := XDR_TM (To_XDR_SA (Item.P1)); 1098 for N in reverse S'Range loop 1099 S (N) := SE (U mod BB); 1100 U := U / BB; 1101 end loop; 1102 1103 Ada.Streams.Write (Stream.all, S); 1104 1105 U := XDR_TM (To_XDR_SA (Item.P2)); 1106 for N in reverse S'Range loop 1107 S (N) := SE (U mod BB); 1108 U := U / BB; 1109 end loop; 1110 1111 Ada.Streams.Write (Stream.all, S); 1112 1113 if U /= 0 then 1114 raise Data_Error; 1115 end if; 1116 end W_AD; 1117 1118 ---------- 1119 -- W_AS -- 1120 ---------- 1121 1122 procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is 1123 S : XDR_S_TM; 1124 U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); 1125 1126 begin 1127 for N in reverse S'Range loop 1128 S (N) := SE (U mod BB); 1129 U := U / BB; 1130 end loop; 1131 1132 Ada.Streams.Write (Stream.all, S); 1133 1134 if U /= 0 then 1135 raise Data_Error; 1136 end if; 1137 end W_AS; 1138 1139 --------- 1140 -- W_B -- 1141 --------- 1142 1143 procedure W_B (Stream : not null access RST; Item : Boolean) is 1144 begin 1145 if Item then 1146 W_SSU (Stream, 1); 1147 else 1148 W_SSU (Stream, 0); 1149 end if; 1150 end W_B; 1151 1152 --------- 1153 -- W_C -- 1154 --------- 1155 1156 procedure W_C (Stream : not null access RST; Item : Character) is 1157 S : XDR_S_C; 1158 1159 pragma Assert (C_L = 1); 1160 1161 begin 1162 -- Use Ada requirements on Character representation clause 1163 1164 S (1) := SE (Character'Pos (Item)); 1165 1166 Ada.Streams.Write (Stream.all, S); 1167 end W_C; 1168 1169 --------- 1170 -- W_F -- 1171 --------- 1172 1173 procedure W_F (Stream : not null access RST; Item : Float) is 1174 I : constant Precision := Single; 1175 E_Size : Integer renames Fields (I).E_Size; 1176 E_Bias : Integer renames Fields (I).E_Bias; 1177 E_Bytes : SEO renames Fields (I).E_Bytes; 1178 F_Bytes : SEO renames Fields (I).F_Bytes; 1179 F_Size : Integer renames Fields (I).F_Size; 1180 F_Mask : SE renames Fields (I).F_Mask; 1181 1182 Exponent : Long_Unsigned; 1183 Fraction : Long_Unsigned; 1184 Is_Positive : Boolean; 1185 E : Integer; 1186 F : Float; 1187 S : SEA (1 .. F_L) := (others => 0); 1188 1189 begin 1190 if not Item'Valid then 1191 raise Constraint_Error; 1192 end if; 1193 1194 -- Compute Sign 1195 1196 Is_Positive := (0.0 <= Item); 1197 F := abs (Item); 1198 1199 -- Signed zero 1200 1201 if F = 0.0 then 1202 Exponent := 0; 1203 Fraction := 0; 1204 1205 else 1206 E := Float'Exponent (F) - 1; 1207 1208 -- Denormalized float 1209 1210 if E <= -E_Bias then 1211 F := Float'Scaling (F, F_Size + E_Bias - 1); 1212 E := -E_Bias; 1213 else 1214 F := Float'Scaling (Float'Fraction (F), F_Size + 1); 1215 end if; 1216 1217 -- Compute Exponent and Fraction 1218 1219 Exponent := Long_Unsigned (E + E_Bias); 1220 Fraction := Long_Unsigned (F * 2.0) / 2; 1221 end if; 1222 1223 -- Store Fraction 1224 1225 for I in reverse F_L - F_Bytes + 1 .. F_L loop 1226 S (I) := SE (Fraction mod BB); 1227 Fraction := Fraction / BB; 1228 end loop; 1229 1230 -- Remove implicit bit 1231 1232 S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; 1233 1234 -- Store Exponent (not always at the beginning of a byte) 1235 1236 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 1237 for N in reverse 1 .. E_Bytes loop 1238 S (N) := SE (Exponent mod BB) + S (N); 1239 Exponent := Exponent / BB; 1240 end loop; 1241 1242 -- Store Sign 1243 1244 if not Is_Positive then 1245 S (1) := S (1) + BS; 1246 end if; 1247 1248 Ada.Streams.Write (Stream.all, S); 1249 end W_F; 1250 1251 --------- 1252 -- W_I -- 1253 --------- 1254 1255 procedure W_I (Stream : not null access RST; Item : Integer) is 1256 S : XDR_S_I; 1257 U : XDR_U; 1258 1259 begin 1260 if Optimize_Integers then 1261 S := Integer_To_XDR_S_I (Item); 1262 1263 else 1264 -- Test sign and apply two complement notation 1265 1266 U := (if Item < 0 1267 then XDR_U'Last xor XDR_U (-(Item + 1)) 1268 else XDR_U (Item)); 1269 1270 for N in reverse S'Range loop 1271 S (N) := SE (U mod BB); 1272 U := U / BB; 1273 end loop; 1274 1275 if U /= 0 then 1276 raise Data_Error; 1277 end if; 1278 end if; 1279 1280 Ada.Streams.Write (Stream.all, S); 1281 end W_I; 1282 1283 ---------- 1284 -- W_LF -- 1285 ---------- 1286 1287 procedure W_LF (Stream : not null access RST; Item : Long_Float) is 1288 I : constant Precision := Double; 1289 E_Size : Integer renames Fields (I).E_Size; 1290 E_Bias : Integer renames Fields (I).E_Bias; 1291 E_Bytes : SEO renames Fields (I).E_Bytes; 1292 F_Bytes : SEO renames Fields (I).F_Bytes; 1293 F_Size : Integer renames Fields (I).F_Size; 1294 F_Mask : SE renames Fields (I).F_Mask; 1295 1296 Exponent : Long_Unsigned; 1297 Fraction : Long_Long_Unsigned; 1298 Is_Positive : Boolean; 1299 E : Integer; 1300 F : Long_Float; 1301 S : SEA (1 .. LF_L) := (others => 0); 1302 1303 begin 1304 if not Item'Valid then 1305 raise Constraint_Error; 1306 end if; 1307 1308 -- Compute Sign 1309 1310 Is_Positive := (0.0 <= Item); 1311 F := abs (Item); 1312 1313 -- Signed zero 1314 1315 if F = 0.0 then 1316 Exponent := 0; 1317 Fraction := 0; 1318 1319 else 1320 E := Long_Float'Exponent (F) - 1; 1321 1322 -- Denormalized float 1323 1324 if E <= -E_Bias then 1325 E := -E_Bias; 1326 F := Long_Float'Scaling (F, F_Size + E_Bias - 1); 1327 else 1328 F := Long_Float'Scaling (F, F_Size - E); 1329 end if; 1330 1331 -- Compute Exponent and Fraction 1332 1333 Exponent := Long_Unsigned (E + E_Bias); 1334 Fraction := Long_Long_Unsigned (F * 2.0) / 2; 1335 end if; 1336 1337 -- Store Fraction 1338 1339 for I in reverse LF_L - F_Bytes + 1 .. LF_L loop 1340 S (I) := SE (Fraction mod BB); 1341 Fraction := Fraction / BB; 1342 end loop; 1343 1344 -- Remove implicit bit 1345 1346 S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; 1347 1348 -- Store Exponent (not always at the beginning of a byte) 1349 1350 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 1351 for N in reverse 1 .. E_Bytes loop 1352 S (N) := SE (Exponent mod BB) + S (N); 1353 Exponent := Exponent / BB; 1354 end loop; 1355 1356 -- Store Sign 1357 1358 if not Is_Positive then 1359 S (1) := S (1) + BS; 1360 end if; 1361 1362 Ada.Streams.Write (Stream.all, S); 1363 end W_LF; 1364 1365 ---------- 1366 -- W_LI -- 1367 ---------- 1368 1369 procedure W_LI (Stream : not null access RST; Item : Long_Integer) is 1370 S : XDR_S_LI; 1371 U : Unsigned; 1372 X : Long_Unsigned; 1373 1374 begin 1375 if Optimize_Integers then 1376 S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); 1377 1378 else 1379 -- Test sign and apply two complement notation 1380 1381 if Item < 0 then 1382 X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); 1383 else 1384 X := Long_Unsigned (Item); 1385 end if; 1386 1387 -- Compute using machine unsigned rather than long_unsigned 1388 1389 for N in reverse S'Range loop 1390 1391 -- We have filled an unsigned 1392 1393 if (LU_L - N) mod UB = 0 then 1394 U := Unsigned (X and UL); 1395 X := Shift_Right (X, US); 1396 end if; 1397 1398 S (N) := SE (U mod BB); 1399 U := U / BB; 1400 end loop; 1401 1402 if U /= 0 then 1403 raise Data_Error; 1404 end if; 1405 end if; 1406 1407 Ada.Streams.Write (Stream.all, S); 1408 end W_LI; 1409 1410 ----------- 1411 -- W_LLF -- 1412 ----------- 1413 1414 procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is 1415 I : constant Precision := Quadruple; 1416 E_Size : Integer renames Fields (I).E_Size; 1417 E_Bias : Integer renames Fields (I).E_Bias; 1418 E_Bytes : SEO renames Fields (I).E_Bytes; 1419 F_Bytes : SEO renames Fields (I).F_Bytes; 1420 F_Size : Integer renames Fields (I).F_Size; 1421 1422 HFS : constant Integer := F_Size / 2; 1423 1424 Exponent : Long_Unsigned; 1425 Fraction_1 : Long_Long_Unsigned; 1426 Fraction_2 : Long_Long_Unsigned; 1427 Is_Positive : Boolean; 1428 E : Integer; 1429 F : Long_Long_Float := Item; 1430 S : SEA (1 .. LLF_L) := (others => 0); 1431 1432 begin 1433 if not Item'Valid then 1434 raise Constraint_Error; 1435 end if; 1436 1437 -- Compute Sign 1438 1439 Is_Positive := (0.0 <= Item); 1440 1441 if F < 0.0 then 1442 F := -Item; 1443 end if; 1444 1445 -- Signed zero 1446 1447 if F = 0.0 then 1448 Exponent := 0; 1449 Fraction_1 := 0; 1450 Fraction_2 := 0; 1451 1452 else 1453 E := Long_Long_Float'Exponent (F) - 1; 1454 1455 -- Denormalized float 1456 1457 if E <= -E_Bias then 1458 F := Long_Long_Float'Scaling (F, E_Bias - 1); 1459 E := -E_Bias; 1460 else 1461 F := Long_Long_Float'Scaling 1462 (Long_Long_Float'Fraction (F), 1); 1463 end if; 1464 1465 -- Compute Exponent and Fraction 1466 1467 Exponent := Long_Unsigned (E + E_Bias); 1468 F := Long_Long_Float'Scaling (F, F_Size - HFS); 1469 Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); 1470 F := F - Long_Long_Float (Fraction_1); 1471 F := Long_Long_Float'Scaling (F, HFS); 1472 Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); 1473 end if; 1474 1475 -- Store Fraction_1 1476 1477 for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop 1478 S (I) := SE (Fraction_1 mod BB); 1479 Fraction_1 := Fraction_1 / BB; 1480 end loop; 1481 1482 -- Store Fraction_2 1483 1484 for I in reverse LLF_L - 6 .. LLF_L loop 1485 S (SEO (I)) := SE (Fraction_2 mod BB); 1486 Fraction_2 := Fraction_2 / BB; 1487 end loop; 1488 1489 -- Store Exponent (not always at the beginning of a byte) 1490 1491 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 1492 for N in reverse 1 .. E_Bytes loop 1493 S (N) := SE (Exponent mod BB) + S (N); 1494 Exponent := Exponent / BB; 1495 end loop; 1496 1497 -- Store Sign 1498 1499 if not Is_Positive then 1500 S (1) := S (1) + BS; 1501 end if; 1502 1503 Ada.Streams.Write (Stream.all, S); 1504 end W_LLF; 1505 1506 ----------- 1507 -- W_LLI -- 1508 ----------- 1509 1510 procedure W_LLI 1511 (Stream : not null access RST; 1512 Item : Long_Long_Integer) 1513 is 1514 S : XDR_S_LLI; 1515 U : Unsigned; 1516 X : Long_Long_Unsigned; 1517 1518 begin 1519 if Optimize_Integers then 1520 S := Long_Long_Integer_To_XDR_S_LLI (Item); 1521 1522 else 1523 -- Test sign and apply two complement notation 1524 1525 if Item < 0 then 1526 X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); 1527 else 1528 X := Long_Long_Unsigned (Item); 1529 end if; 1530 1531 -- Compute using machine unsigned rather than long_long_unsigned 1532 1533 for N in reverse S'Range loop 1534 1535 -- We have filled an unsigned 1536 1537 if (LLU_L - N) mod UB = 0 then 1538 U := Unsigned (X and UL); 1539 X := Shift_Right (X, US); 1540 end if; 1541 1542 S (N) := SE (U mod BB); 1543 U := U / BB; 1544 end loop; 1545 1546 if U /= 0 then 1547 raise Data_Error; 1548 end if; 1549 end if; 1550 1551 Ada.Streams.Write (Stream.all, S); 1552 end W_LLI; 1553 1554 ----------- 1555 -- W_LLU -- 1556 ----------- 1557 1558 procedure W_LLU 1559 (Stream : not null access RST; 1560 Item : Long_Long_Unsigned) 1561 is 1562 S : XDR_S_LLU; 1563 U : Unsigned; 1564 X : Long_Long_Unsigned := Item; 1565 1566 begin 1567 if Optimize_Integers then 1568 S := Long_Long_Unsigned_To_XDR_S_LLU (Item); 1569 1570 else 1571 -- Compute using machine unsigned rather than long_long_unsigned 1572 1573 for N in reverse S'Range loop 1574 1575 -- We have filled an unsigned 1576 1577 if (LLU_L - N) mod UB = 0 then 1578 U := Unsigned (X and UL); 1579 X := Shift_Right (X, US); 1580 end if; 1581 1582 S (N) := SE (U mod BB); 1583 U := U / BB; 1584 end loop; 1585 1586 if U /= 0 then 1587 raise Data_Error; 1588 end if; 1589 end if; 1590 1591 Ada.Streams.Write (Stream.all, S); 1592 end W_LLU; 1593 1594 ---------- 1595 -- W_LU -- 1596 ---------- 1597 1598 procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is 1599 S : XDR_S_LU; 1600 U : Unsigned; 1601 X : Long_Unsigned := Item; 1602 1603 begin 1604 if Optimize_Integers then 1605 S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); 1606 1607 else 1608 -- Compute using machine unsigned rather than long_unsigned 1609 1610 for N in reverse S'Range loop 1611 1612 -- We have filled an unsigned 1613 1614 if (LU_L - N) mod UB = 0 then 1615 U := Unsigned (X and UL); 1616 X := Shift_Right (X, US); 1617 end if; 1618 S (N) := SE (U mod BB); 1619 U := U / BB; 1620 end loop; 1621 1622 if U /= 0 then 1623 raise Data_Error; 1624 end if; 1625 end if; 1626 1627 Ada.Streams.Write (Stream.all, S); 1628 end W_LU; 1629 1630 ---------- 1631 -- W_SF -- 1632 ---------- 1633 1634 procedure W_SF (Stream : not null access RST; Item : Short_Float) is 1635 I : constant Precision := Single; 1636 E_Size : Integer renames Fields (I).E_Size; 1637 E_Bias : Integer renames Fields (I).E_Bias; 1638 E_Bytes : SEO renames Fields (I).E_Bytes; 1639 F_Bytes : SEO renames Fields (I).F_Bytes; 1640 F_Size : Integer renames Fields (I).F_Size; 1641 F_Mask : SE renames Fields (I).F_Mask; 1642 1643 Exponent : Long_Unsigned; 1644 Fraction : Long_Unsigned; 1645 Is_Positive : Boolean; 1646 E : Integer; 1647 F : Short_Float; 1648 S : SEA (1 .. SF_L) := (others => 0); 1649 1650 begin 1651 if not Item'Valid then 1652 raise Constraint_Error; 1653 end if; 1654 1655 -- Compute Sign 1656 1657 Is_Positive := (0.0 <= Item); 1658 F := abs (Item); 1659 1660 -- Signed zero 1661 1662 if F = 0.0 then 1663 Exponent := 0; 1664 Fraction := 0; 1665 1666 else 1667 E := Short_Float'Exponent (F) - 1; 1668 1669 -- Denormalized float 1670 1671 if E <= -E_Bias then 1672 E := -E_Bias; 1673 F := Short_Float'Scaling (F, F_Size + E_Bias - 1); 1674 else 1675 F := Short_Float'Scaling (F, F_Size - E); 1676 end if; 1677 1678 -- Compute Exponent and Fraction 1679 1680 Exponent := Long_Unsigned (E + E_Bias); 1681 Fraction := Long_Unsigned (F * 2.0) / 2; 1682 end if; 1683 1684 -- Store Fraction 1685 1686 for I in reverse SF_L - F_Bytes + 1 .. SF_L loop 1687 S (I) := SE (Fraction mod BB); 1688 Fraction := Fraction / BB; 1689 end loop; 1690 1691 -- Remove implicit bit 1692 1693 S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; 1694 1695 -- Store Exponent (not always at the beginning of a byte) 1696 1697 Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); 1698 for N in reverse 1 .. E_Bytes loop 1699 S (N) := SE (Exponent mod BB) + S (N); 1700 Exponent := Exponent / BB; 1701 end loop; 1702 1703 -- Store Sign 1704 1705 if not Is_Positive then 1706 S (1) := S (1) + BS; 1707 end if; 1708 1709 Ada.Streams.Write (Stream.all, S); 1710 end W_SF; 1711 1712 ---------- 1713 -- W_SI -- 1714 ---------- 1715 1716 procedure W_SI (Stream : not null access RST; Item : Short_Integer) is 1717 S : XDR_S_SI; 1718 U : XDR_SU; 1719 1720 begin 1721 if Optimize_Integers then 1722 S := Short_Integer_To_XDR_S_SI (Item); 1723 1724 else 1725 -- Test sign and apply two complement's notation 1726 1727 U := (if Item < 0 1728 then XDR_SU'Last xor XDR_SU (-(Item + 1)) 1729 else XDR_SU (Item)); 1730 1731 for N in reverse S'Range loop 1732 S (N) := SE (U mod BB); 1733 U := U / BB; 1734 end loop; 1735 1736 if U /= 0 then 1737 raise Data_Error; 1738 end if; 1739 end if; 1740 1741 Ada.Streams.Write (Stream.all, S); 1742 end W_SI; 1743 1744 ----------- 1745 -- W_SSI -- 1746 ----------- 1747 1748 procedure W_SSI 1749 (Stream : not null access RST; 1750 Item : Short_Short_Integer) 1751 is 1752 S : XDR_S_SSI; 1753 U : XDR_SSU; 1754 1755 begin 1756 if Optimize_Integers then 1757 S := Short_Short_Integer_To_XDR_S_SSI (Item); 1758 1759 else 1760 -- Test sign and apply two complement's notation 1761 1762 U := (if Item < 0 1763 then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) 1764 else XDR_SSU (Item)); 1765 1766 S (1) := SE (U); 1767 end if; 1768 1769 Ada.Streams.Write (Stream.all, S); 1770 end W_SSI; 1771 1772 ----------- 1773 -- W_SSU -- 1774 ----------- 1775 1776 procedure W_SSU 1777 (Stream : not null access RST; 1778 Item : Short_Short_Unsigned) 1779 is 1780 U : constant XDR_SSU := XDR_SSU (Item); 1781 S : XDR_S_SSU; 1782 1783 begin 1784 S (1) := SE (U); 1785 Ada.Streams.Write (Stream.all, S); 1786 end W_SSU; 1787 1788 ---------- 1789 -- W_SU -- 1790 ---------- 1791 1792 procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is 1793 S : XDR_S_SU; 1794 U : XDR_SU := XDR_SU (Item); 1795 1796 begin 1797 if Optimize_Integers then 1798 S := Short_Unsigned_To_XDR_S_SU (Item); 1799 1800 else 1801 for N in reverse S'Range loop 1802 S (N) := SE (U mod BB); 1803 U := U / BB; 1804 end loop; 1805 1806 if U /= 0 then 1807 raise Data_Error; 1808 end if; 1809 end if; 1810 1811 Ada.Streams.Write (Stream.all, S); 1812 end W_SU; 1813 1814 --------- 1815 -- W_U -- 1816 --------- 1817 1818 procedure W_U (Stream : not null access RST; Item : Unsigned) is 1819 S : XDR_S_U; 1820 U : XDR_U := XDR_U (Item); 1821 1822 begin 1823 if Optimize_Integers then 1824 S := Unsigned_To_XDR_S_U (Item); 1825 1826 else 1827 for N in reverse S'Range loop 1828 S (N) := SE (U mod BB); 1829 U := U / BB; 1830 end loop; 1831 1832 if U /= 0 then 1833 raise Data_Error; 1834 end if; 1835 end if; 1836 1837 Ada.Streams.Write (Stream.all, S); 1838 end W_U; 1839 1840 ---------- 1841 -- W_WC -- 1842 ---------- 1843 1844 procedure W_WC (Stream : not null access RST; Item : Wide_Character) is 1845 S : XDR_S_WC; 1846 U : XDR_WC; 1847 1848 begin 1849 -- Use Ada requirements on Wide_Character representation clause 1850 1851 U := XDR_WC (Wide_Character'Pos (Item)); 1852 1853 for N in reverse S'Range loop 1854 S (N) := SE (U mod BB); 1855 U := U / BB; 1856 end loop; 1857 1858 Ada.Streams.Write (Stream.all, S); 1859 1860 if U /= 0 then 1861 raise Data_Error; 1862 end if; 1863 end W_WC; 1864 1865 ----------- 1866 -- W_WWC -- 1867 ----------- 1868 1869 procedure W_WWC 1870 (Stream : not null access RST; Item : Wide_Wide_Character) 1871 is 1872 S : XDR_S_WWC; 1873 U : XDR_WWC; 1874 1875 begin 1876 -- Use Ada requirements on Wide_Wide_Character representation clause 1877 1878 U := XDR_WWC (Wide_Wide_Character'Pos (Item)); 1879 1880 for N in reverse S'Range loop 1881 S (N) := SE (U mod BB); 1882 U := U / BB; 1883 end loop; 1884 1885 Ada.Streams.Write (Stream.all, S); 1886 1887 if U /= 0 then 1888 raise Data_Error; 1889 end if; 1890 end W_WWC; 1891 1892end System.Stream_Attributes; 1893