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