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