gcc/ada/s-strxdr.adb

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