Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT RUN-TIME COMPONENTS                         --

--                                                                          --

--             S Y S T E M . S T R E A M _ A T T R I B U T E S              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--         Copyright (C) 1996-2009, Free Software Foundation, Inc.          --

--                                                                          --

-- GARLIC is free software;  you can redistribute it and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  This file is an alternate version of s-stratt.adb based on the XDR

--  standard. It is especially useful for exchanging streams between two

--  different systems with different basic type representations and endianness.

with Ada.IO_Exceptions;

with Ada.Streams;              use Ada.Streams;

with Ada.Unchecked_Conversion;

package body System.Stream_Attributes is

   pragma Suppress (Range_Check);

   pragma Suppress (Overflow_Check);

   use UST;

   Data_Error : exception renames Ada.IO_Exceptions.End_Error;

   --  Exception raised if insufficient data read (End_Error is mandated by

   --  AI95-00132).

   SU : constant := System.Storage_Unit;

   --  The code in this body assumes that SU = 8

   BB : constant := 2 ** SU;           --  Byte base

   BL : constant := 2 ** SU - 1;       --  Byte last

   BS : constant := 2 ** (SU - 1);     --  Byte sign

   US : constant := Unsigned'Size;     --  Unsigned size

   UB : constant := (US - 1) / SU + 1; --  Unsigned byte

   UL : constant := 2 ** US - 1;       --  Unsigned last

   subtype SE  is Ada.Streams.Stream_Element;

   subtype SEA is Ada.Streams.Stream_Element_Array;

   subtype SEO is Ada.Streams.Stream_Element_Offset;

   generic function UC renames Ada.Unchecked_Conversion;

   type Field_Type is

      record

         E_Size       : Integer; --  Exponent bit size

         E_Bias       : Integer; --  Exponent bias

         F_Size       : Integer; --  Fraction bit size

         E_Last       : Integer; --  Max exponent value

         F_Mask       : SE;      --  Mask to apply on first fraction byte

         E_Bytes      : SEO;     --  N. of exponent bytes completely used

         F_Bytes      : SEO;     --  N. of fraction bytes completely used

         F_Bits       : Integer; --  N. of bits used on first fraction word

      end record;

   type Precision is (Single, Double, Quadruple);

   Fields : constant array (Precision) of Field_Type := (

               --  Single precision

              (E_Size  => 8,

               E_Bias  => 127,

               F_Size  => 23,

               E_Last  => 2 ** 8 - 1,

               F_Mask  => 16#7F#,                  --  2 ** 7 - 1,

               E_Bytes => 2,

               F_Bytes => 3,

               F_Bits  => 23 mod US),

               --  Double precision

              (E_Size  => 11,

               E_Bias  => 1023,

               F_Size  => 52,

               E_Last  => 2 ** 11 - 1,

               F_Mask  => 16#0F#,                  --  2 ** 4 - 1,

               E_Bytes => 2,

               F_Bytes => 7,

               F_Bits  => 52 mod US),

               --  Quadruple precision

              (E_Size  => 15,

               E_Bias  => 16383,

               F_Size  => 112,

               E_Last  => 2 ** 8 - 1,

               F_Mask  => 16#FF#,                  --  2 ** 8 - 1,

               E_Bytes => 2,

               F_Bytes => 14,

               F_Bits  => 112 mod US));

   --  The representation of all items requires a multiple of four bytes

   --  (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes

   --  are read or written to some byte stream such that byte m always

   --  precedes byte m+1. If the n bytes needed to contain the data are not

   --  a multiple of four, then the n bytes are followed by enough (0 to 3)

   --  residual zero bytes, r, to make the total byte count a multiple of 4.

   --  An XDR signed integer is a 32-bit datum that encodes an integer

   --  in the range [-2147483648,2147483647]. The integer is represented

   --  in two's complement notation. The most and least significant bytes

   --  are 0 and 3, respectively. Integers are declared as follows:

   --        (MSB)                   (LSB)

   --      +-------+-------+-------+-------+

   --      |byte 0 |byte 1 |byte 2 |byte 3 |

   --      +-------+-------+-------+-------+

   --      <------------32 bits------------>

   SSI_L : constant := 1;

   SI_L  : constant := 2;

   I_L   : constant := 4;

   LI_L  : constant := 8;

   LLI_L : constant := 8;

   subtype XDR_S_SSI is SEA (1 .. SSI_L);

   subtype XDR_S_SI  is SEA (1 .. SI_L);

   subtype XDR_S_I   is SEA (1 .. I_L);

   subtype XDR_S_LI  is SEA (1 .. LI_L);

   subtype XDR_S_LLI is SEA (1 .. LLI_L);

   function Short_Short_Integer_To_XDR_S_SSI is

      new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);

   function XDR_S_SSI_To_Short_Short_Integer is

      new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);

   function Short_Integer_To_XDR_S_SI is

      new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);

   function XDR_S_SI_To_Short_Integer is

      new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);

   function Integer_To_XDR_S_I is

      new Ada.Unchecked_Conversion (Integer, XDR_S_I);

   function XDR_S_I_To_Integer is

     new Ada.Unchecked_Conversion (XDR_S_I, Integer);

   function Long_Long_Integer_To_XDR_S_LI is

      new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);

   function XDR_S_LI_To_Long_Long_Integer is

      new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);

   function Long_Long_Integer_To_XDR_S_LLI is

      new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);

   function XDR_S_LLI_To_Long_Long_Integer is

      new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);

   --  An XDR unsigned integer is a 32-bit datum that encodes a nonnegative

   --  integer in the range [0,4294967295]. It is represented by an unsigned

   --  binary number whose most and least significant bytes are 0 and 3,

   --  respectively. An unsigned integer is declared as follows:

   --        (MSB)                   (LSB)

   --      +-------+-------+-------+-------+

   --      |byte 0 |byte 1 |byte 2 |byte 3 |

   --      +-------+-------+-------+-------+

   --      <------------32 bits------------>

   SSU_L : constant := 1;

   SU_L  : constant := 2;

   U_L   : constant := 4;

   LU_L  : constant := 8;

   LLU_L : constant := 8;

   subtype XDR_S_SSU is SEA (1 .. SSU_L);

   subtype XDR_S_SU  is SEA (1 .. SU_L);

   subtype XDR_S_U   is SEA (1 .. U_L);

   subtype XDR_S_LU  is SEA (1 .. LU_L);

   subtype XDR_S_LLU is SEA (1 .. LLU_L);

   type XDR_SSU is mod BB ** SSU_L;

   type XDR_SU  is mod BB ** SU_L;

   type XDR_U   is mod BB ** U_L;

   function Short_Unsigned_To_XDR_S_SU is

      new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);

   function XDR_S_SU_To_Short_Unsigned is

      new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);

   function Unsigned_To_XDR_S_U is

      new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);

   function XDR_S_U_To_Unsigned is

      new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);

   function Long_Long_Unsigned_To_XDR_S_LU is

      new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);

   function XDR_S_LU_To_Long_Long_Unsigned is

      new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);

   function Long_Long_Unsigned_To_XDR_S_LLU is

      new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);

   function XDR_S_LLU_To_Long_Long_Unsigned is

      new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);

   --  The standard defines the floating-point data type "float" (32 bits

   --  or 4 bytes). The encoding used is the IEEE standard for normalized

   --  single-precision floating-point numbers.

   --  The standard defines the encoding used for the double-precision

   --  floating-point data type "double" (64 bits or 8 bytes). The encoding

   --  used is the IEEE standard for normalized double-precision floating-point

   --  numbers.

   SF_L  : constant := 4;   --  Single precision

   F_L   : constant := 4;   --  Single precision

   LF_L  : constant := 8;   --  Double precision

   LLF_L : constant := 16;  --  Quadruple precision

   TM_L : constant := 8;

   subtype XDR_S_TM is SEA (1 .. TM_L);

   type XDR_TM is mod BB ** TM_L;

   type XDR_SA is mod 2 ** Standard'Address_Size;

   function To_XDR_SA is new UC (System.Address, XDR_SA);

   function To_XDR_SA is new UC (XDR_SA, System.Address);

   --  Enumerations have the same representation as signed integers.

   --  Enumerations are handy for describing subsets of the integers.

   --  Booleans are important enough and occur frequently enough to warrant

   --  their own explicit type in the standard. Booleans are declared as

   --  an enumeration, with FALSE = 0 and TRUE = 1.

   --  The standard defines a string of n (numbered 0 through n-1) ASCII

   --  bytes to be the number n encoded as an unsigned integer (as described

   --  above), and followed by the n bytes of the string. Byte m of the string

   --  always precedes byte m+1 of the string, and byte 0 of the string always

   --  follows the string's length. If n is not a multiple of four, then the

   --  n bytes are followed by enough (0 to 3) residual zero bytes, r, to make

   --  the total byte count a multiple of four.

   --  To fit with XDR string, do not consider character as an enumeration

   --  type.

   C_L   : constant := 1;

   subtype XDR_S_C is SEA (1 .. C_L);

   --  Consider Wide_Character as an enumeration type

   WC_L  : constant := 4;

   subtype XDR_S_WC is SEA (1 .. WC_L);

   type XDR_WC is mod BB ** WC_L;

   --  Consider Wide_Wide_Character as an enumeration type

   WWC_L : constant := 8;

   subtype XDR_S_WWC is SEA (1 .. WWC_L);

   type XDR_WWC is mod BB ** WWC_L;

   --  Optimization: if we already have the correct Bit_Order, then some

   --  computations can be avoided since the source and the target will be

   --  identical anyway. They will be replaced by direct unchecked

   --  conversions.

   Optimize_Integers : constant Boolean :=

     Default_Bit_Order = High_Order_First;

   -----------------

   -- Block_IO_OK --

   -----------------

   function Block_IO_OK return Boolean is

   begin

      return False;

   end Block_IO_OK;

   ----------

   -- I_AD --

   ----------

   function I_AD (Stream : not null access RST) return Fat_Pointer is

      FP : Fat_Pointer;

   begin

      FP.P1 := I_AS (Stream).P1;

      FP.P2 := I_AS (Stream).P1;

      return FP;

   end I_AD;

   ----------

   -- I_AS --

   ----------

   function I_AS (Stream : not null access RST) return Thin_Pointer is

      S : XDR_S_TM;

      L : SEO;

      U : XDR_TM := 0;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      else

         for N in S'Range loop

            U := U * BB + XDR_TM (S (N));

         end loop;

         return (P1 => To_XDR_SA (XDR_SA (U)));

      end if;

   end I_AS;

   ---------

   -- I_B --

   ---------

   function I_B (Stream : not null access RST) return Boolean is

   begin

      case I_SSU (Stream) is

         when 0      => return False;

         when 1      => return True;

         when others => raise Data_Error;

      end case;

   end I_B;

   ---------

   -- I_C --

   ---------

   function I_C (Stream : not null access RST) return Character is

      S : XDR_S_C;

      L : SEO;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      else

         --  Use Ada requirements on Character representation clause

         return Character'Val (S (1));

      end if;

   end I_C;

   ---------

   -- I_F --

   ---------

   function I_F (Stream : not null access RST) return Float is

      I       : constant Precision := Single;

      E_Size  : Integer  renames Fields (I).E_Size;

      E_Bias  : Integer  renames Fields (I).E_Bias;

      E_Last  : Integer  renames Fields (I).E_Last;

      F_Mask  : SE       renames Fields (I).F_Mask;

      E_Bytes : SEO      renames Fields (I).E_Bytes;

      F_Bytes : SEO      renames Fields (I).F_Bytes;

      F_Size  : Integer  renames Fields (I).F_Size;

      Positive   : Boolean;

      Exponent   : Long_Unsigned;

      Fraction   : Long_Unsigned;

      Result     : Float;

      S          : SEA (1 .. F_L);

      L          : SEO;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      end if;

      --  Extract Fraction, Sign and Exponent

      Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);

      for N in F_L + 2 - F_Bytes .. F_L loop

         Fraction := Fraction * BB + Long_Unsigned (S (N));

      end loop;

      Result := Float'Scaling (Float (Fraction), -F_Size);

      if BS <= S (1) then

         Positive := False;

         Exponent := Long_Unsigned (S (1) - BS);

      else

         Positive := True;

         Exponent := Long_Unsigned (S (1));

      end if;

      for N in 2 .. E_Bytes loop

         Exponent := Exponent * BB + Long_Unsigned (S (N));

      end loop;

      Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);

      --  NaN or Infinities

      if Integer (Exponent) = E_Last then

         raise Constraint_Error;

      elsif Exponent = 0 then

         --  Signed zeros

         if Fraction = 0 then

            null;

         --  Denormalized float

         else

            Result := Float'Scaling (Result, 1 - E_Bias);

         end if;

      --  Normalized float

      else

         Result := Float'Scaling

           (1.0 + Result, Integer (Exponent) - E_Bias);

      end if;

      if not Positive then

         Result := -Result;

      end if;

      return Result;

   end I_F;

   ---------

   -- I_I --

   ---------

   function I_I (Stream : not null access RST) return Integer is

      S : XDR_S_I;

      L : SEO;

      U : XDR_U := 0;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      elsif Optimize_Integers then

         return XDR_S_I_To_Integer (S);

      else

         for N in S'Range loop

            U := U * BB + XDR_U (S (N));

         end loop;

         --  Test sign and apply two complement notation

         if S (1) < BL then

            return Integer (U);

         else

            return Integer (-((XDR_U'Last xor U) + 1));

         end if;

      end if;

   end I_I;

   ----------

   -- I_LF --

   ----------

   function I_LF (Stream : not null access RST) return Long_Float is

      I       : constant Precision := Double;

      E_Size  : Integer  renames Fields (I).E_Size;

      E_Bias  : Integer  renames Fields (I).E_Bias;

      E_Last  : Integer  renames Fields (I).E_Last;

      F_Mask  : SE       renames Fields (I).F_Mask;

      E_Bytes : SEO      renames Fields (I).E_Bytes;

      F_Bytes : SEO      renames Fields (I).F_Bytes;

      F_Size  : Integer  renames Fields (I).F_Size;

      Positive   : Boolean;

      Exponent   : Long_Unsigned;

      Fraction   : Long_Long_Unsigned;

      Result     : Long_Float;

      S          : SEA (1 .. LF_L);

      L          : SEO;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      end if;

      --  Extract Fraction, Sign and Exponent

      Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);

      for N in LF_L + 2 - F_Bytes .. LF_L loop

         Fraction := Fraction * BB + Long_Long_Unsigned (S (N));

      end loop;

      Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);

      if BS <= S (1) then

         Positive := False;

         Exponent := Long_Unsigned (S (1) - BS);

      else

         Positive := True;

         Exponent := Long_Unsigned (S (1));

      end if;

      for N in 2 .. E_Bytes loop

         Exponent := Exponent * BB + Long_Unsigned (S (N));

      end loop;

      Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);

      --  NaN or Infinities

      if Integer (Exponent) = E_Last then

         raise Constraint_Error;

      elsif Exponent = 0 then

         --  Signed zeros

         if Fraction = 0 then

            null;

         --  Denormalized float

         else

            Result := Long_Float'Scaling (Result, 1 - E_Bias);

         end if;

      --  Normalized float

      else

         Result := Long_Float'Scaling

           (1.0 + Result, Integer (Exponent) - E_Bias);

      end if;

      if not Positive then

         Result := -Result;

      end if;

      return Result;

   end I_LF;

   ----------

   -- I_LI --

   ----------

   function I_LI (Stream : not null access RST) return Long_Integer is

      S : XDR_S_LI;

      L : SEO;

      U : Unsigned := 0;

      X : Long_Unsigned := 0;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      elsif Optimize_Integers then

         return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));

      else

         --  Compute using machine unsigned

         --  rather than long_long_unsigned

         for N in S'Range loop

            U := U * BB + Unsigned (S (N));

            --  We have filled an unsigned

            if N mod UB = 0 then

               X := Shift_Left (X, US) + Long_Unsigned (U);

               U := 0;

            end if;

         end loop;

         --  Test sign and apply two complement notation

         if S (1) < BL then

            return Long_Integer (X);

         else

            return Long_Integer (-((Long_Unsigned'Last xor X) + 1));

         end if;

      end if;

   end I_LI;

   -----------

   -- I_LLF --

   -----------

   function I_LLF (Stream : not null access RST) return Long_Long_Float is

      I       : constant Precision := Quadruple;

      E_Size  : Integer  renames Fields (I).E_Size;

      E_Bias  : Integer  renames Fields (I).E_Bias;

      E_Last  : Integer  renames Fields (I).E_Last;

      E_Bytes : SEO      renames Fields (I).E_Bytes;

      F_Bytes : SEO      renames Fields (I).F_Bytes;

      F_Size  : Integer  renames Fields (I).F_Size;

      Positive   : Boolean;

      Exponent   : Long_Unsigned;

      Fraction_1 : Long_Long_Unsigned := 0;

      Fraction_2 : Long_Long_Unsigned := 0;

      Result     : Long_Long_Float;

      HF         : constant Natural := F_Size / 2;

      S          : SEA (1 .. LLF_L);

      L          : SEO;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      end if;

      --  Extract Fraction, Sign and Exponent

      for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop

         Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));

      end loop;

      for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop

         Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));

      end loop;

      Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);

      Result := Long_Long_Float (Fraction_1) + Result;

      Result := Long_Long_Float'Scaling (Result, HF - F_Size);

      if BS <= S (1) then

         Positive := False;

         Exponent := Long_Unsigned (S (1) - BS);

      else

         Positive := True;

         Exponent := Long_Unsigned (S (1));

      end if;

      for N in 2 .. E_Bytes loop

         Exponent := Exponent * BB + Long_Unsigned (S (N));

      end loop;

      Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);

      --  NaN or Infinities

      if Integer (Exponent) = E_Last then

         raise Constraint_Error;

      elsif Exponent = 0 then

         --  Signed zeros

         if Fraction_1 = 0 and then Fraction_2 = 0 then

            null;

         --  Denormalized float

         else

            Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);

         end if;

      --  Normalized float

      else

         Result := Long_Long_Float'Scaling

           (1.0 + Result, Integer (Exponent) - E_Bias);

      end if;

      if not Positive then

         Result := -Result;

      end if;

      return Result;

   end I_LLF;

   -----------

   -- I_LLI --

   -----------

   function I_LLI (Stream : not null access RST) return Long_Long_Integer is

      S : XDR_S_LLI;

      L : SEO;

      U : Unsigned := 0;

      X : Long_Long_Unsigned := 0;

   begin

      Ada.Streams.Read (Stream.all, S, L);

      if L /= S'Last then

         raise Data_Error;

      elsif Optimize_Integers then

         return XDR_S_LLI_To_Long_Long_Integer (S);

      else

         --  Compute using machine unsigned for computing

         --  rather than long_long_unsigned.

         for N in S'Range loop

            U := U * BB + Unsigned (S (N));

            --  We have filled an unsigned

            if N mod UB = 0 then

               X := Shift_Left (X, US) + Long_Long_Unsigned (U);

               U := 0;

            end if;

         end loop;

         --  Test sign and apply two complement notation

         if S (1) < BL then

            return Long_Long_Integer (X);

         else

            return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));

         end if;

      end if;

   end I_LLI;

   -----------

   -- I_LLU --

   -----------

   function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is

      S : XDR_S_LLU;

      L : SEO;

      U : Unsigned := 0;

      X : Long_Long_Unsigned := 0;

   begin

      Ada.Streams.Read (Stream.all, S, L);