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