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