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