gcc/ada/s-strxdr.adb

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