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-2006, 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 endianess.
  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 completly used
  78          F_Bytes      : SEO;     --  N. of fraction bytes completly 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    --  Optimization: if we already have the correct Bit_Order, then some
 271    --  computations can be avoided since the source and the target will be
 272    --  identical anyway. They will be replaced by direct unchecked
 273    --  conversions.
 274
 275    Optimize_Integers : constant Boolean :=
 276      Default_Bit_Order = High_Order_First;
 277
 278    ----------
 279    -- I_AD --
 280    ----------
 281
 282    function I_AD (Stream : not null access RST) return Fat_Pointer is
 283       FP : Fat_Pointer;
 284
 285    begin
 286       FP.P1 := I_AS (Stream).P1;
 287       FP.P2 := I_AS (Stream).P1;
 288
 289       return FP;
 290    end I_AD;
 291
 292    ----------
 293    -- I_AS --
 294    ----------
 295
 296    function I_AS (Stream : not null access RST) return Thin_Pointer is
 297       S : XDR_S_TM;
 298       L : SEO;
 299       U : XDR_TM := 0;
 300
 301    begin
 302       Ada.Streams.Read (Stream.all, S, L);
 303
 304       if L /= S'Last then
 305          raise Data_Error;
 306       else
 307          for N in S'Range loop
 308             U := U * BB + XDR_TM (S (N));
 309          end loop;
 310
 311          return (P1 => To_XDR_SA (XDR_SA (U)));
 312       end if;
 313    end I_AS;
 314
 315    ---------
 316    -- I_B --
 317    ---------
 318
 319    function I_B (Stream : not null access RST) return Boolean is
 320    begin
 321       case I_SSU (Stream) is
 322          when 0      => return False;
 323          when 1      => return True;
 324          when others => raise Data_Error;
 325       end case;
 326    end I_B;
 327
 328    ---------
 329    -- I_C --
 330    ---------
 331
 332    function I_C (Stream : not null access RST) return Character is
 333       S : XDR_S_C;
 334       L : SEO;
 335
 336    begin
 337       Ada.Streams.Read (Stream.all, S, L);
 338
 339       if L /= S'Last then
 340          raise Data_Error;
 341       else
 342
 343          --  Use Ada requirements on Character representation clause
 344
 345          return Character'Val (S (1));
 346       end if;
 347    end I_C;
 348
 349    ---------
 350    -- I_F --
 351    ---------
 352
 353    function I_F (Stream : not null access RST) return Float is
 354       I       : constant Precision := Single;
 355       E_Size  : Integer  renames Fields (I).E_Size;
 356       E_Bias  : Integer  renames Fields (I).E_Bias;
 357       E_Last  : Integer  renames Fields (I).E_Last;
 358       F_Mask  : SE       renames Fields (I).F_Mask;
 359       E_Bytes : SEO      renames Fields (I).E_Bytes;
 360       F_Bytes : SEO      renames Fields (I).F_Bytes;
 361       F_Size  : Integer  renames Fields (I).F_Size;
 362
 363       Positive   : Boolean;
 364       Exponent   : Long_Unsigned;
 365       Fraction   : Long_Unsigned;
 366       Result     : Float;
 367       S          : SEA (1 .. F_L);
 368       L          : SEO;
 369
 370    begin
 371       Ada.Streams.Read (Stream.all, S, L);
 372
 373       if L /= S'Last then
 374          raise Data_Error;
 375       end if;
 376
 377       --  Extract Fraction, Sign and Exponent
 378
 379       Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);
 380       for N in F_L + 2 - F_Bytes .. F_L loop
 381          Fraction := Fraction * BB + Long_Unsigned (S (N));
 382       end loop;
 383       Result := Float'Scaling (Float (Fraction), -F_Size);
 384
 385       if BS <= S (1) then
 386          Positive := False;
 387          Exponent := Long_Unsigned (S (1) - BS);
 388       else
 389          Positive := True;
 390          Exponent := Long_Unsigned (S (1));
 391       end if;
 392
 393       for N in 2 .. E_Bytes loop
 394          Exponent := Exponent * BB + Long_Unsigned (S (N));
 395       end loop;
 396       Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
 397
 398       --  NaN or Infinities
 399
 400       if Integer (Exponent) = E_Last then
 401          raise Constraint_Error;
 402
 403       elsif Exponent = 0 then
 404
 405          --  Signed zeros
 406
 407          if Fraction = 0 then
 408             null;
 409
 410          --  Denormalized float
 411
 412          else
 413             Result := Float'Scaling (Result, 1 - E_Bias);
 414          end if;
 415
 416       --  Normalized float
 417
 418       else
 419          Result := Float'Scaling
 420            (1.0 + Result, Integer (Exponent) - E_Bias);
 421       end if;
 422
 423       if not Positive then
 424          Result := -Result;
 425       end if;
 426
 427       return Result;
 428    end I_F;
 429
 430    ---------
 431    -- I_I --
 432    ---------
 433
 434    function I_I (Stream : not null access RST) return Integer is
 435       S : XDR_S_I;
 436       L : SEO;
 437       U : XDR_U := 0;
 438
 439    begin
 440       Ada.Streams.Read (Stream.all, S, L);
 441
 442       if L /= S'Last then
 443          raise Data_Error;
 444
 445       elsif Optimize_Integers then
 446          return XDR_S_I_To_Integer (S);
 447
 448       else
 449          for N in S'Range loop
 450             U := U * BB + XDR_U (S (N));
 451          end loop;
 452
 453          --  Test sign and apply two complement notation
 454
 455          if S (1) < BL then
 456             return Integer (U);
 457
 458          else
 459             return Integer (-((XDR_U'Last xor U) + 1));
 460          end if;
 461       end if;
 462    end I_I;
 463
 464    ----------
 465    -- I_LF --
 466    ----------
 467
 468    function I_LF (Stream : not null access RST) return Long_Float is
 469       I       : constant Precision := Double;
 470       E_Size  : Integer  renames Fields (I).E_Size;
 471       E_Bias  : Integer  renames Fields (I).E_Bias;
 472       E_Last  : Integer  renames Fields (I).E_Last;
 473       F_Mask  : SE       renames Fields (I).F_Mask;
 474       E_Bytes : SEO      renames Fields (I).E_Bytes;
 475       F_Bytes : SEO      renames Fields (I).F_Bytes;
 476       F_Size  : Integer  renames Fields (I).F_Size;
 477
 478       Positive   : Boolean;
 479       Exponent   : Long_Unsigned;
 480       Fraction   : Long_Long_Unsigned;
 481       Result     : Long_Float;
 482       S          : SEA (1 .. LF_L);
 483       L          : SEO;
 484
 485    begin
 486       Ada.Streams.Read (Stream.all, S, L);
 487
 488       if L /= S'Last then
 489          raise Data_Error;
 490       end if;
 491
 492       --  Extract Fraction, Sign and Exponent
 493
 494       Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);
 495       for N in LF_L + 2 - F_Bytes .. LF_L loop
 496          Fraction := Fraction * BB + Long_Long_Unsigned (S (N));
 497       end loop;
 498
 499       Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
 500
 501       if BS <= S (1) then
 502          Positive := False;
 503          Exponent := Long_Unsigned (S (1) - BS);
 504       else
 505          Positive := True;
 506          Exponent := Long_Unsigned (S (1));
 507       end if;
 508
 509       for N in 2 .. E_Bytes loop
 510          Exponent := Exponent * BB + Long_Unsigned (S (N));
 511       end loop;
 512
 513       Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
 514
 515       --  NaN or Infinities
 516
 517       if Integer (Exponent) = E_Last then
 518          raise Constraint_Error;
 519
 520       elsif Exponent = 0 then
 521
 522          --  Signed zeros
 523
 524          if Fraction = 0 then
 525             null;
 526
 527          --  Denormalized float
 528
 529          else
 530             Result := Long_Float'Scaling (Result, 1 - E_Bias);
 531          end if;
 532
 533       --  Normalized float
 534
 535       else
 536          Result := Long_Float'Scaling
 537            (1.0 + Result, Integer (Exponent) - E_Bias);
 538       end if;
 539
 540       if not Positive then
 541          Result := -Result;
 542       end if;
 543
 544       return Result;
 545    end I_LF;
 546
 547    ----------
 548    -- I_LI --
 549    ----------
 550
 551    function I_LI (Stream : not null access RST) return Long_Integer is
 552       S : XDR_S_LI;
 553       L : SEO;
 554       U : Unsigned := 0;
 555       X : Long_Unsigned := 0;
 556
 557    begin
 558       Ada.Streams.Read (Stream.all, S, L);
 559
 560       if L /= S'Last then
 561          raise Data_Error;
 562
 563       elsif Optimize_Integers then
 564          return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));
 565
 566       else
 567
 568          --  Compute using machine unsigned
 569          --  rather than long_long_unsigned
 570
 571          for N in S'Range loop
 572             U := U * BB + Unsigned (S (N));
 573
 574             --  We have filled an unsigned
 575
 576             if N mod UB = 0 then
 577                X := Shift_Left (X, US) + Long_Unsigned (U);
 578                U := 0;
 579             end if;
 580          end loop;
 581
 582          --  Test sign and apply two complement notation
 583
 584          if S (1) < BL then
 585             return Long_Integer (X);
 586          else
 587             return Long_Integer (-((Long_Unsigned'Last xor X) + 1));
 588          end if;
 589
 590       end if;
 591    end I_LI;
 592
 593    -----------
 594    -- I_LLF --
 595    -----------
 596
 597    function I_LLF (Stream : not null access RST) return Long_Long_Float is
 598       I       : constant Precision := Quadruple;
 599       E_Size  : Integer  renames Fields (I).E_Size;
 600       E_Bias  : Integer  renames Fields (I).E_Bias;
 601       E_Last  : Integer  renames Fields (I).E_Last;
 602       E_Bytes : SEO      renames Fields (I).E_Bytes;
 603       F_Bytes : SEO      renames Fields (I).F_Bytes;
 604       F_Size  : Integer  renames Fields (I).F_Size;
 605
 606       Positive   : Boolean;
 607       Exponent   : Long_Unsigned;
 608       Fraction_1 : Long_Long_Unsigned := 0;
 609       Fraction_2 : Long_Long_Unsigned := 0;
 610       Result     : Long_Long_Float;
 611       HF         : constant Natural := F_Size / 2;
 612       S          : SEA (1 .. LLF_L);
 613       L          : SEO;
 614
 615    begin
 616       Ada.Streams.Read (Stream.all, S, L);
 617
 618       if L /= S'Last then
 619          raise Data_Error;
 620       end if;
 621
 622       --  Extract Fraction, Sign and Exponent
 623
 624       for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
 625          Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));
 626       end loop;
 627
 628       for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop
 629          Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));
 630       end loop;
 631
 632       Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);
 633       Result := Long_Long_Float (Fraction_1) + Result;
 634       Result := Long_Long_Float'Scaling (Result, HF - F_Size);
 635
 636       if BS <= S (1) then
 637          Positive := False;
 638          Exponent := Long_Unsigned (S (1) - BS);
 639       else
 640          Positive := True;
 641          Exponent := Long_Unsigned (S (1));
 642       end if;
 643
 644       for N in 2 .. E_Bytes loop
 645          Exponent := Exponent * BB + Long_Unsigned (S (N));
 646       end loop;
 647
 648       Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
 649
 650       --  NaN or Infinities
 651
 652       if Integer (Exponent) = E_Last then
 653          raise Constraint_Error;
 654
 655       elsif Exponent = 0 then
 656
 657          --  Signed zeros
 658
 659          if Fraction_1 = 0 and then Fraction_2 = 0 then
 660             null;
 661
 662          --  Denormalized float
 663
 664          else
 665             Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);
 666          end if;
 667
 668       --  Normalized float
 669
 670       else
 671          Result := Long_Long_Float'Scaling
 672            (1.0 + Result, Integer (Exponent) - E_Bias);
 673       end if;
 674
 675       if not Positive then
 676          Result := -Result;
 677       end if;
 678
 679       return Result;
 680    end I_LLF;
 681
 682    -----------
 683    -- I_LLI --
 684    -----------
 685
 686    function I_LLI (Stream : not null access RST) return Long_Long_Integer is
 687       S : XDR_S_LLI;
 688       L : SEO;
 689       U : Unsigned := 0;
 690       X : Long_Long_Unsigned := 0;
 691
 692    begin
 693       Ada.Streams.Read (Stream.all, S, L);
 694
 695       if L /= S'Last then
 696          raise Data_Error;
 697       elsif Optimize_Integers then
 698          return XDR_S_LLI_To_Long_Long_Integer (S);
 699       else
 700
 701          --  Compute using machine unsigned for computing
 702          --  rather than long_long_unsigned.
 703
 704          for N in S'Range loop
 705             U := U * BB + Unsigned (S (N));
 706
 707             --  We have filled an unsigned
 708
 709             if N mod UB = 0 then
 710                X := Shift_Left (X, US) + Long_Long_Unsigned (U);
 711                U := 0;
 712             end if;
 713          end loop;
 714
 715          --  Test sign and apply two complement notation
 716
 717          if S (1) < BL then
 718             return Long_Long_Integer (X);
 719          else
 720             return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));
 721          end if;
 722       end if;
 723    end I_LLI;
 724
 725    -----------
 726    -- I_LLU --
 727    -----------
 728
 729    function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is
 730       S : XDR_S_LLU;
 731       L : SEO;
 732       U : Unsigned := 0;
 733       X : Long_Long_Unsigned := 0;
 734
 735    begin
 736       Ada.Streams.Read (Stream.all, S, L);
 737
 738       if L /= S'Last then
 739          raise Data_Error;
 740       elsif Optimize_Integers then
 741          return XDR_S_LLU_To_Long_Long_Unsigned (S);
 742       else
 743
 744          --  Compute using machine unsigned
 745          --  rather than long_long_unsigned.
 746
 747          for N in S'Range loop
 748             U := U * BB + Unsigned (S (N));
 749
 750             --  We have filled an unsigned
 751
 752             if N mod UB = 0 then
 753                X := Shift_Left (X, US) + Long_Long_Unsigned (U);
 754                U := 0;
 755             end if;
 756          end loop;
 757
 758          return X;
 759       end if;
 760    end I_LLU;
 761
 762    ----------
 763    -- I_LU --
 764    ----------
 765
 766    function I_LU (Stream : not null access RST) return Long_Unsigned is
 767       S : XDR_S_LU;
 768       L : SEO;
 769       U : Unsigned := 0;
 770       X : Long_Unsigned := 0;
 771
 772    begin
 773       Ada.Streams.Read (Stream.all, S, L);
 774
 775       if L /= S'Last then
 776          raise Data_Error;
 777       elsif Optimize_Integers then
 778          return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S));
 779       else
 780
 781          --  Compute using machine unsigned
 782          --  rather than long_unsigned.
 783
 784          for N in S'Range loop
 785             U := U * BB + Unsigned (S (N));
 786
 787             --  We have filled an unsigned
 788
 789             if N mod UB = 0 then
 790                X := Shift_Left (X, US) + Long_Unsigned (U);
 791                U := 0;
 792             end if;
 793          end loop;
 794
 795          return X;
 796       end if;
 797    end I_LU;
 798
 799    ----------
 800    -- I_SF --
 801    ----------
 802
 803    function I_SF (Stream : not null access RST) return Short_Float is
 804       I       : constant Precision := Single;
 805       E_Size  : Integer  renames Fields (I).E_Size;
 806       E_Bias  : Integer  renames Fields (I).E_Bias;
 807       E_Last  : Integer  renames Fields (I).E_Last;
 808       F_Mask  : SE       renames Fields (I).F_Mask;
 809       E_Bytes : SEO      renames Fields (I).E_Bytes;
 810       F_Bytes : SEO      renames Fields (I).F_Bytes;
 811       F_Size  : Integer  renames Fields (I).F_Size;
 812
 813       Exponent   : Long_Unsigned;
 814       Fraction   : Long_Unsigned;
 815       Positive   : Boolean;
 816       Result     : Short_Float;
 817       S          : SEA (1 .. SF_L);
 818       L          : SEO;
 819
 820    begin
 821       Ada.Streams.Read (Stream.all, S, L);
 822
 823       if L /= S'Last then
 824          raise Data_Error;
 825       end if;
 826
 827       --  Extract Fraction, Sign and Exponent
 828
 829       Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask);
 830       for N in SF_L + 2 - F_Bytes .. SF_L loop
 831          Fraction := Fraction * BB + Long_Unsigned (S (N));
 832       end loop;
 833       Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
 834
 835       if BS <= S (1) then
 836          Positive := False;
 837          Exponent := Long_Unsigned (S (1) - BS);
 838       else
 839          Positive := True;
 840          Exponent := Long_Unsigned (S (1));
 841       end if;
 842
 843       for N in 2 .. E_Bytes loop
 844          Exponent := Exponent * BB + Long_Unsigned (S (N));
 845       end loop;
 846       Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
 847
 848       --  NaN or Infinities
 849
 850       if Integer (Exponent) = E_Last then
 851          raise Constraint_Error;
 852
 853       elsif Exponent = 0 then
 854
 855          --  Signed zeros
 856
 857          if Fraction = 0 then
 858             null;
 859
 860          --  Denormalized float
 861
 862          else
 863             Result := Short_Float'Scaling (Result, 1 - E_Bias);
 864          end if;
 865
 866       --  Normalized float
 867
 868       else
 869          Result := Short_Float'Scaling
 870            (1.0 + Result, Integer (Exponent) - E_Bias);
 871       end if;
 872
 873       if not Positive then
 874          Result := -Result;
 875       end if;
 876
 877       return Result;
 878    end I_SF;
 879
 880    ----------
 881    -- I_SI --
 882    ----------
 883
 884    function I_SI (Stream : not null access RST) return Short_Integer is
 885       S : XDR_S_SI;
 886       L : SEO;
 887       U : XDR_SU := 0;
 888
 889    begin
 890       Ada.Streams.Read (Stream.all, S, L);
 891
 892       if L /= S'Last then
 893          raise Data_Error;
 894
 895       elsif Optimize_Integers then
 896          return XDR_S_SI_To_Short_Integer (S);
 897
 898       else
 899          for N in S'Range loop
 900             U := U * BB + XDR_SU (S (N));
 901          end loop;
 902
 903          --  Test sign and apply two complement notation
 904
 905          if S (1) < BL then
 906             return Short_Integer (U);
 907          else
 908             return Short_Integer (-((XDR_SU'Last xor U) + 1));
 909          end if;
 910       end if;
 911    end I_SI;
 912
 913    -----------
 914    -- I_SSI --
 915    -----------
 916
 917    function I_SSI (Stream : not null access RST) return Short_Short_Integer is
 918       S : XDR_S_SSI;
 919       L : SEO;
 920       U : XDR_SSU;
 921
 922    begin
 923       Ada.Streams.Read (Stream.all, S, L);
 924
 925       if L /= S'Last then
 926          raise Data_Error;
 927       elsif Optimize_Integers then
 928          return XDR_S_SSI_To_Short_Short_Integer (S);
 929       else
 930          U := XDR_SSU (S (1));
 931
 932          --  Test sign and apply two complement notation
 933
 934          if S (1) < BL then
 935             return Short_Short_Integer (U);
 936          else
 937             return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1));
 938          end if;
 939       end if;
 940    end I_SSI;
 941
 942    -----------
 943    -- I_SSU --
 944    -----------
 945
 946    function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is
 947       S : XDR_S_SSU;
 948       L : SEO;
 949       U : XDR_SSU := 0;
 950
 951    begin
 952       Ada.Streams.Read (Stream.all, S, L);
 953
 954       if L /= S'Last then
 955          raise Data_Error;
 956       else
 957          U := XDR_SSU (S (1));
 958
 959          return Short_Short_Unsigned (U);
 960       end if;
 961    end I_SSU;
 962
 963    ----------
 964    -- I_SU --
 965    ----------
 966
 967    function I_SU (Stream : not null access RST) return Short_Unsigned is
 968       S : XDR_S_SU;
 969       L : SEO;
 970       U : XDR_SU := 0;
 971
 972    begin
 973       Ada.Streams.Read (Stream.all, S, L);
 974
 975       if L /= S'Last then
 976          raise Data_Error;
 977       elsif Optimize_Integers then
 978          return XDR_S_SU_To_Short_Unsigned (S);
 979       else
 980          for N in S'Range loop
 981             U := U * BB + XDR_SU (S (N));
 982          end loop;
 983
 984          return Short_Unsigned (U);
 985       end if;
 986    end I_SU;
 987
 988    ---------
 989    -- I_U --
 990    ---------
 991
 992    function I_U (Stream : not null access RST) return Unsigned is
 993       S : XDR_S_U;
 994       L : SEO;
 995       U : XDR_U := 0;
 996
 997    begin
 998       Ada.Streams.Read (Stream.all, S, L);
 999
1000       if L /= S'Last then
1001          raise Data_Error;
1002
1003       elsif Optimize_Integers then
1004          return XDR_S_U_To_Unsigned (S);
1005
1006       else
1007          for N in S'Range loop
1008             U := U * BB + XDR_U (S (N));
1009          end loop;
1010
1011          return Unsigned (U);
1012       end if;
1013    end I_U;
1014
1015    ----------
1016    -- I_WC --
1017    ----------
1018
1019    function I_WC (Stream : not null access RST) return Wide_Character is
1020       S : XDR_S_WC;
1021       L : SEO;
1022       U : XDR_WC := 0;
1023
1024    begin
1025       Ada.Streams.Read (Stream.all, S, L);
1026
1027       if L /= S'Last then
1028          raise Data_Error;
1029       else
1030          for N in S'Range loop
1031             U := U * BB + XDR_WC (S (N));
1032          end loop;
1033
1034          --  Use Ada requirements on Wide_Character representation clause
1035
1036          return Wide_Character'Val (U);
1037       end if;
1038    end I_WC;
1039
1040    ----------
1041    -- W_AD --
1042    ----------
1043
1044    procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
1045       S : XDR_S_TM;
1046       U : XDR_TM;
1047
1048    begin
1049       U := XDR_TM (To_XDR_SA (Item.P1));
1050       for N in reverse S'Range loop
1051          S (N) := SE (U mod BB);
1052          U := U / BB;
1053       end loop;
1054
1055       Ada.Streams.Write (Stream.all, S);
1056
1057       U := XDR_TM (To_XDR_SA (Item.P2));
1058       for N in reverse S'Range loop
1059          S (N) := SE (U mod BB);
1060          U := U / BB;
1061       end loop;
1062
1063       Ada.Streams.Write (Stream.all, S);
1064
1065       if U /= 0 then
1066          raise Data_Error;
1067       end if;
1068    end W_AD;
1069
1070    ----------
1071    -- W_AS --
1072    ----------
1073
1074    procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
1075       S : XDR_S_TM;
1076       U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
1077
1078    begin
1079       for N in reverse S'Range loop
1080          S (N) := SE (U mod BB);
1081          U := U / BB;
1082       end loop;
1083
1084       Ada.Streams.Write (Stream.all, S);
1085
1086       if U /= 0 then
1087          raise Data_Error;
1088       end if;
1089    end W_AS;
1090
1091    ---------
1092    -- W_B --
1093    ---------
1094
1095    procedure W_B (Stream : not null access RST; Item : Boolean) is
1096    begin
1097       if Item then
1098          W_SSU (Stream, 1);
1099       else
1100          W_SSU (Stream, 0);
1101       end if;
1102    end W_B;
1103
1104    ---------
1105    -- W_C --
1106    ---------
1107
1108    procedure W_C (Stream : not null access RST; Item : Character) is
1109       S : XDR_S_C;
1110
1111       pragma Assert (C_L = 1);
1112
1113    begin
1114
1115       --  Use Ada requirements on Character representation clause
1116
1117       S (1) := SE (Character'Pos (Item));
1118
1119       Ada.Streams.Write (Stream.all, S);
1120    end W_C;
1121
1122    ---------
1123    -- W_F --
1124    ---------
1125
1126    procedure W_F (Stream : not null access RST; Item : Float) is
1127       I       : constant Precision := Single;
1128       E_Size  : Integer  renames Fields (I).E_Size;
1129       E_Bias  : Integer  renames Fields (I).E_Bias;
1130       E_Bytes : SEO      renames Fields (I).E_Bytes;
1131       F_Bytes : SEO      renames Fields (I).F_Bytes;
1132       F_Size  : Integer  renames Fields (I).F_Size;
1133       F_Mask  : SE       renames Fields (I).F_Mask;
1134
1135       Exponent : Long_Unsigned;
1136       Fraction : Long_Unsigned;
1137       Positive : Boolean;
1138       E        : Integer;
1139       F        : Float;
1140       S        : SEA (1 .. F_L) := (others => 0);
1141
1142    begin
1143       if not Item'Valid then
1144          raise Constraint_Error;
1145       end if;
1146
1147       --  Compute Sign
1148
1149       Positive := (0.0 <= Item);
1150       F := abs (Item);
1151
1152       --  Signed zero
1153
1154       if F = 0.0 then
1155          Exponent := 0;
1156          Fraction := 0;
1157
1158       else
1159          E := Float'Exponent (F) - 1;
1160
1161          --  Denormalized float
1162
1163          if E <= -E_Bias then
1164             F := Float'Scaling (F, F_Size + E_Bias - 1);
1165             E := -E_Bias;
1166          else
1167             F := Float'Scaling (Float'Fraction (F), F_Size + 1);
1168          end if;
1169
1170          --  Compute Exponent and Fraction
1171
1172          Exponent := Long_Unsigned (E + E_Bias);
1173          Fraction := Long_Unsigned (F * 2.0) / 2;
1174       end if;
1175
1176       --  Store Fraction
1177
1178       for I in reverse F_L - F_Bytes + 1 .. F_L loop
1179          S (I) := SE (Fraction mod BB);
1180          Fraction := Fraction / BB;
1181       end loop;
1182
1183       --  Remove implicit bit
1184
1185       S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask;
1186
1187       --  Store Exponent (not always at the beginning of a byte)
1188
1189       Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
1190       for N in reverse 1 .. E_Bytes loop
1191          S (N) := SE (Exponent mod BB) + S (N);
1192          Exponent := Exponent / BB;
1193       end loop;
1194
1195       --  Store Sign
1196
1197       if not Positive then
1198          S (1) := S (1) + BS;
1199       end if;
1200
1201       Ada.Streams.Write (Stream.all, S);
1202    end W_F;
1203
1204    ---------
1205    -- W_I --
1206    ---------
1207
1208    procedure W_I (Stream : not null access RST; Item : Integer) is
1209       S : XDR_S_I;
1210       U : XDR_U;
1211
1212    begin
1213       if Optimize_Integers then
1214          S := Integer_To_XDR_S_I (Item);
1215       else
1216
1217          --  Test sign and apply two complement notation
1218
1219          if Item < 0 then
1220             U := XDR_U'Last xor XDR_U (-(Item + 1));
1221          else
1222             U := XDR_U (Item);
1223          end if;
1224
1225          for N in reverse S'Range loop
1226             S (N) := SE (U mod BB);
1227             U := U / BB;
1228          end loop;
1229
1230          if U /= 0 then
1231             raise Data_Error;
1232          end if;
1233       end if;
1234
1235       Ada.Streams.Write (Stream.all, S);
1236    end W_I;
1237
1238    ----------
1239    -- W_LF --
1240    ----------
1241
1242    procedure W_LF (Stream : not null access RST; Item : Long_Float) is
1243       I       : constant Precision := Double;
1244       E_Size  : Integer  renames Fields (I).E_Size;
1245       E_Bias  : Integer  renames Fields (I).E_Bias;
1246       E_Bytes : SEO      renames Fields (I).E_Bytes;
1247       F_Bytes : SEO      renames Fields (I).F_Bytes;
1248       F_Size  : Integer  renames Fields (I).F_Size;
1249       F_Mask  : SE       renames Fields (I).F_Mask;
1250
1251       Exponent : Long_Unsigned;
1252       Fraction : Long_Long_Unsigned;
1253       Positive : Boolean;
1254       E        : Integer;
1255       F        : Long_Float;
1256       S        : SEA (1 .. LF_L) := (others => 0);
1257
1258    begin
1259       if not Item'Valid then
1260          raise Constraint_Error;
1261       end if;
1262
1263       --  Compute Sign
1264
1265       Positive := (0.0 <= Item);
1266       F := abs (Item);
1267
1268       --  Signed zero
1269
1270       if F = 0.0 then
1271          Exponent := 0;
1272          Fraction := 0;
1273
1274       else
1275          E := Long_Float'Exponent (F) - 1;
1276
1277          --  Denormalized float
1278
1279          if E <= -E_Bias then
1280             E := -E_Bias;
1281             F := Long_Float'Scaling (F, F_Size + E_Bias - 1);
1282          else
1283             F := Long_Float'Scaling (F, F_Size - E);
1284          end if;
1285
1286          --  Compute Exponent and Fraction
1287
1288          Exponent := Long_Unsigned (E + E_Bias);
1289          Fraction := Long_Long_Unsigned (F * 2.0) / 2;
1290       end if;
1291
1292       --  Store Fraction
1293
1294       for I in reverse LF_L - F_Bytes + 1 .. LF_L loop
1295          S (I) := SE (Fraction mod BB);
1296          Fraction := Fraction / BB;
1297       end loop;
1298
1299       --  Remove implicit bit
1300
1301       S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask;
1302
1303       --  Store Exponent (not always at the beginning of a byte)
1304
1305       Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
1306       for N in reverse 1 .. E_Bytes loop
1307          S (N) := SE (Exponent mod BB) + S (N);
1308          Exponent := Exponent / BB;
1309       end loop;
1310
1311       --  Store Sign
1312
1313       if not Positive then
1314          S (1) := S (1) + BS;
1315       end if;
1316
1317       Ada.Streams.Write (Stream.all, S);
1318    end W_LF;
1319
1320    ----------
1321    -- W_LI --
1322    ----------
1323
1324    procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
1325       S : XDR_S_LI;
1326       U : Unsigned;
1327       X : Long_Unsigned;
1328
1329    begin
1330       if Optimize_Integers then
1331          S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item));
1332       else
1333
1334          --  Test sign and apply two complement notation
1335
1336          if Item < 0 then
1337             X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1));
1338          else
1339             X := Long_Unsigned (Item);
1340          end if;
1341
1342          --  Compute using machine unsigned
1343          --  rather than long_unsigned.
1344
1345          for N in reverse S'Range loop
1346
1347             --  We have filled an unsigned
1348
1349             if (LU_L - N) mod UB = 0 then
1350                U := Unsigned (X and UL);
1351                X := Shift_Right (X, US);
1352             end if;
1353
1354             S (N) := SE (U mod BB);
1355             U := U / BB;
1356          end loop;
1357
1358          if U /= 0 then
1359             raise Data_Error;
1360          end if;
1361       end if;
1362
1363       Ada.Streams.Write (Stream.all, S);
1364    end W_LI;
1365
1366    -----------
1367    -- W_LLF --
1368    -----------
1369
1370    procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
1371       I       : constant Precision := Quadruple;
1372       E_Size  : Integer  renames Fields (I).E_Size;
1373       E_Bias  : Integer  renames Fields (I).E_Bias;
1374       E_Bytes : SEO      renames Fields (I).E_Bytes;
1375       F_Bytes : SEO      renames Fields (I).F_Bytes;
1376       F_Size  : Integer  renames Fields (I).F_Size;
1377
1378       HFS : constant Integer := F_Size / 2;
1379
1380       Exponent   : Long_Unsigned;
1381       Fraction_1 : Long_Long_Unsigned;
1382       Fraction_2 : Long_Long_Unsigned;
1383       Positive   : Boolean;
1384       E          : Integer;
1385       F          : Long_Long_Float := Item;
1386       S          : SEA (1 .. LLF_L) := (others => 0);
1387
1388    begin
1389       if not Item'Valid then
1390          raise Constraint_Error;
1391       end if;
1392
1393       --  Compute Sign
1394
1395       Positive := (0.0 <= Item);
1396       if F < 0.0 then
1397          F := -Item;
1398       end if;
1399
1400       --  Signed zero
1401
1402       if F = 0.0 then
1403          Exponent   := 0;
1404          Fraction_1 := 0;
1405          Fraction_2 := 0;
1406
1407       else
1408          E := Long_Long_Float'Exponent (F) - 1;
1409
1410          --  Denormalized float
1411
1412          if E <= -E_Bias then
1413             F := Long_Long_Float'Scaling (F, E_Bias - 1);
1414             E := -E_Bias;
1415          else
1416             F := Long_Long_Float'Scaling
1417               (Long_Long_Float'Fraction (F), 1);
1418          end if;
1419
1420          --  Compute Exponent and Fraction
1421
1422          Exponent   := Long_Unsigned (E + E_Bias);
1423          F          := Long_Long_Float'Scaling (F, F_Size - HFS);
1424          Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
1425          F          := Long_Long_Float (F - Long_Long_Float (Fraction_1));
1426          F          := Long_Long_Float'Scaling (F, HFS);
1427          Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
1428       end if;
1429
1430       --  Store Fraction_1
1431
1432       for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
1433          S (I) := SE (Fraction_1 mod BB);
1434          Fraction_1 := Fraction_1 / BB;
1435       end loop;
1436
1437       --  Store Fraction_2
1438
1439       for I in reverse LLF_L - 6 .. LLF_L loop
1440          S (SEO (I)) := SE (Fraction_2 mod BB);
1441          Fraction_2 := Fraction_2 / BB;
1442       end loop;
1443
1444       --  Store Exponent (not always at the beginning of a byte)
1445
1446       Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
1447       for N in reverse 1 .. E_Bytes loop
1448          S (N) := SE (Exponent mod BB) + S (N);
1449          Exponent := Exponent / BB;
1450       end loop;
1451
1452       --  Store Sign
1453
1454       if not Positive then
1455          S (1) := S (1) + BS;
1456       end if;
1457
1458       Ada.Streams.Write (Stream.all, S);
1459    end W_LLF;
1460
1461    -----------
1462    -- W_LLI --
1463    -----------
1464
1465    procedure W_LLI (Stream : not null access RST;
1466                     Item   : Long_Long_Integer)
1467    is
1468       S : XDR_S_LLI;
1469       U : Unsigned;
1470       X : Long_Long_Unsigned;
1471
1472    begin
1473       if Optimize_Integers then
1474          S := Long_Long_Integer_To_XDR_S_LLI (Item);
1475       else
1476
1477          --  Test sign and apply two complement notation
1478
1479          if Item < 0 then
1480             X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1));
1481          else
1482             X := Long_Long_Unsigned (Item);
1483          end if;
1484
1485          --  Compute using machine unsigned
1486          --  rather than long_long_unsigned.
1487
1488          for N in reverse S'Range loop
1489
1490             --  We have filled an unsigned
1491
1492             if (LLU_L - N) mod UB = 0 then
1493                U := Unsigned (X and UL);
1494                X := Shift_Right (X, US);
1495             end if;
1496
1497             S (N) := SE (U mod BB);
1498             U := U / BB;
1499          end loop;
1500
1501          if U /= 0 then
1502             raise Data_Error;
1503          end if;
1504       end if;
1505
1506       Ada.Streams.Write (Stream.all, S);
1507    end W_LLI;
1508
1509    -----------
1510    -- W_LLU --
1511    -----------
1512
1513    procedure W_LLU (Stream : not null access RST;
1514                     Item   : Long_Long_Unsigned) is
1515       S : XDR_S_LLU;
1516       U : Unsigned;
1517       X : Long_Long_Unsigned := Item;
1518
1519    begin
1520       if Optimize_Integers then
1521          S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
1522       else
1523          --  Compute using machine unsigned
1524          --  rather than long_long_unsigned.
1525
1526          for N in reverse S'Range loop
1527
1528             --  We have filled an unsigned
1529
1530             if (LLU_L - N) mod UB = 0 then
1531                U := Unsigned (X and UL);
1532                X := Shift_Right (X, US);
1533             end if;
1534
1535             S (N) := SE (U mod BB);
1536             U := U / BB;
1537          end loop;
1538
1539          if U /= 0 then
1540             raise Data_Error;
1541          end if;
1542       end if;
1543
1544       Ada.Streams.Write (Stream.all, S);
1545    end W_LLU;
1546
1547    ----------
1548    -- W_LU --
1549    ----------
1550
1551    procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
1552       S : XDR_S_LU;
1553       U : Unsigned;
1554       X : Long_Unsigned := Item;
1555
1556    begin
1557       if Optimize_Integers then
1558          S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item));
1559       else
1560          --  Compute using machine unsigned
1561          --  rather than long_unsigned.
1562
1563          for N in reverse S'Range loop
1564
1565             --  We have filled an unsigned
1566
1567             if (LU_L - N) mod UB = 0 then
1568                U := Unsigned (X and UL);
1569                X := Shift_Right (X, US);
1570             end if;
1571             S (N) := SE (U mod BB);
1572             U := U / BB;
1573          end loop;
1574
1575          if U /= 0 then
1576             raise Data_Error;
1577          end if;
1578       end if;
1579
1580       Ada.Streams.Write (Stream.all, S);
1581    end W_LU;
1582
1583    ----------
1584    -- W_SF --
1585    ----------
1586
1587    procedure W_SF (Stream : not null access RST; Item : Short_Float) is
1588       I       : constant Precision := Single;
1589       E_Size  : Integer  renames Fields (I).E_Size;
1590       E_Bias  : Integer  renames Fields (I).E_Bias;
1591       E_Bytes : SEO      renames Fields (I).E_Bytes;
1592       F_Bytes : SEO      renames Fields (I).F_Bytes;
1593       F_Size  : Integer  renames Fields (I).F_Size;
1594       F_Mask  : SE       renames Fields (I).F_Mask;
1595
1596       Exponent : Long_Unsigned;
1597       Fraction : Long_Unsigned;
1598       Positive : Boolean;
1599       E        : Integer;
1600       F        : Short_Float;
1601       S        : SEA (1 .. SF_L) := (others => 0);
1602
1603    begin
1604       if not Item'Valid then
1605          raise Constraint_Error;
1606       end if;
1607
1608       --  Compute Sign
1609
1610       Positive := (0.0 <= Item);
1611       F := abs (Item);
1612
1613       --  Signed zero
1614
1615       if F = 0.0 then
1616          Exponent := 0;
1617          Fraction := 0;
1618
1619       else
1620          E := Short_Float'Exponent (F) - 1;
1621
1622          --  Denormalized float
1623
1624          if E <= -E_Bias then
1625             E := -E_Bias;
1626             F := Short_Float'Scaling (F, F_Size + E_Bias - 1);
1627          else
1628             F := Short_Float'Scaling (F, F_Size - E);
1629          end if;
1630
1631          --  Compute Exponent and Fraction
1632
1633          Exponent := Long_Unsigned (E + E_Bias);
1634          Fraction := Long_Unsigned (F * 2.0) / 2;
1635       end if;
1636
1637       --  Store Fraction
1638
1639       for I in reverse SF_L - F_Bytes + 1 .. SF_L loop
1640          S (I) := SE (Fraction mod BB);
1641          Fraction := Fraction / BB;
1642       end loop;
1643
1644       --  Remove implicit bit
1645
1646       S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask;
1647
1648       --  Store Exponent (not always at the beginning of a byte)
1649
1650       Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
1651       for N in reverse 1 .. E_Bytes loop
1652          S (N) := SE (Exponent mod BB) + S (N);
1653          Exponent := Exponent / BB;
1654       end loop;
1655
1656       --  Store Sign
1657
1658       if not Positive then
1659          S (1) := S (1) + BS;
1660       end if;
1661
1662       Ada.Streams.Write (Stream.all, S);
1663    end W_SF;
1664
1665    ----------
1666    -- W_SI --
1667    ----------
1668
1669    procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
1670       S : XDR_S_SI;
1671       U : XDR_SU;
1672
1673    begin
1674       if Optimize_Integers then
1675          S := Short_Integer_To_XDR_S_SI (Item);
1676       else
1677
1678          --  Test sign and apply two complement's notation
1679
1680          if Item < 0 then
1681             U := XDR_SU'Last xor XDR_SU (-(Item + 1));
1682          else
1683             U := XDR_SU (Item);
1684          end if;
1685
1686          for N in reverse S'Range loop
1687             S (N) := SE (U mod BB);
1688             U := U / BB;
1689          end loop;
1690
1691          if U /= 0 then
1692             raise Data_Error;
1693          end if;
1694       end if;
1695
1696       Ada.Streams.Write (Stream.all, S);
1697    end W_SI;
1698
1699    -----------
1700    -- W_SSI --
1701    -----------
1702
1703    procedure W_SSI
1704      (Stream : not null access RST;
1705       Item   : Short_Short_Integer)
1706    is
1707       S : XDR_S_SSI;
1708       U : XDR_SSU;
1709
1710    begin
1711       if Optimize_Integers then
1712          S := Short_Short_Integer_To_XDR_S_SSI (Item);
1713       else
1714
1715          --  Test sign and apply two complement's notation
1716
1717          if Item < 0 then
1718             U := XDR_SSU'Last xor XDR_SSU (-(Item + 1));
1719          else
1720             U := XDR_SSU (Item);
1721          end if;
1722
1723          S (1) := SE (U);
1724       end if;
1725
1726       Ada.Streams.Write (Stream.all, S);
1727    end W_SSI;
1728
1729    -----------
1730    -- W_SSU --
1731    -----------
1732
1733    procedure W_SSU
1734      (Stream : not null access RST;
1735       Item   : Short_Short_Unsigned)
1736    is
1737       U : constant XDR_SSU := XDR_SSU (Item);
1738       S : XDR_S_SSU;
1739
1740    begin
1741       S (1) := SE (U);
1742
1743       Ada.Streams.Write (Stream.all, S);
1744    end W_SSU;
1745
1746    ----------
1747    -- W_SU --
1748    ----------
1749
1750    procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is
1751       S : XDR_S_SU;
1752       U : XDR_SU := XDR_SU (Item);
1753
1754    begin
1755       if Optimize_Integers then
1756          S := Short_Unsigned_To_XDR_S_SU (Item);
1757       else
1758          for N in reverse S'Range loop
1759             S (N) := SE (U mod BB);
1760             U := U / BB;
1761          end loop;
1762
1763          if U /= 0 then
1764             raise Data_Error;
1765          end if;
1766       end if;
1767
1768       Ada.Streams.Write (Stream.all, S);
1769    end W_SU;
1770
1771    ---------
1772    -- W_U --
1773    ---------
1774
1775    procedure W_U (Stream : not null access RST; Item : Unsigned) is
1776       S : XDR_S_U;
1777       U : XDR_U := XDR_U (Item);
1778
1779    begin
1780       if Optimize_Integers then
1781          S := Unsigned_To_XDR_S_U (Item);
1782       else
1783          for N in reverse S'Range loop
1784             S (N) := SE (U mod BB);
1785             U := U / BB;
1786          end loop;
1787
1788          if U /= 0 then
1789             raise Data_Error;
1790          end if;
1791       end if;
1792
1793       Ada.Streams.Write (Stream.all, S);
1794    end W_U;
1795
1796    ----------
1797    -- W_WC --
1798    ----------
1799
1800    procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
1801       S : XDR_S_WC;
1802       U : XDR_WC;
1803
1804    begin
1805
1806       --  Use Ada requirements on Wide_Character representation clause
1807
1808       U := XDR_WC (Wide_Character'Pos (Item));
1809
1810       for N in reverse S'Range loop
1811          S (N) := SE (U mod BB);
1812          U := U / BB;
1813       end loop;
1814
1815       Ada.Streams.Write (Stream.all, S);
1816
1817       if U /= 0 then
1818          raise Data_Error;
1819       end if;
1820    end W_WC;
1821
1822 end System.Stream_Attributes;