From: Arnaud Charlet Date: Thu, 23 Apr 2020 09:46:29 +0000 (-0400) Subject: [Ada] Add support for XDR streaming in the default runtime X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8cd7aec26f11d3d317e0e59e3dbe04b96b7052e4;p=gcc.git [Ada] Add support for XDR streaming in the default runtime 2020-06-18 Arnaud Charlet gcc/ada/ * Makefile.rtl: Add s-statxd.o. * bindgen.adb (Gen_Adainit): Add support for XDR_Stream. * bindusg.adb (Display): Add mention of -xdr. * gnatbind.adb: Process -xdr switch. * init.c (__gl_xdr_stream): New. * opt.ads (XDR_Stream): New. * libgnat/s-stratt__xdr.adb: Rename to... * libgnat/s-statxd.adb: this and adjust. * libgnat/s-statxd.ads: New. * libgnat/s-stratt.ads, libgnat/s-stratt.adb: Choose between default and XDR implementation at runtime. * libgnat/s-ststop.ads: Update comments. * doc/gnat_rm/implementation_advice.rst: Update doc on XDR streaming. * gnat_rm.texi: Regenerate. --- diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 2092c1773c9..92af01733df 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -707,6 +707,7 @@ GNATRTL_NONTASKING_OBJS= \ s-stopoo$(objext) \ s-stposu$(objext) \ s-stratt$(objext) \ + s-statxd$(objext) \ s-strhas$(objext) \ s-string$(objext) \ s-ststop$(objext) \ diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 99ad3009d13..91b4cb38486 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -197,6 +197,7 @@ package body Bindgen is -- Main_CPU : Integer; -- Default_Sized_SS_Pool : System.Address; -- Binder_Sec_Stacks_Count : Natural; + -- XDR_Stream : Integer; -- Main_Priority is the priority value set by pragma Priority in the main -- program. If no such pragma is present, the value is -1. @@ -295,6 +296,9 @@ package body Bindgen is -- Binder_Sec_Stacks_Count is the number of generated secondary stacks in -- the Default_Sized_SS_Pool. + -- XDR_Stream indicates whether streaming should be performed using the + -- XDR protocol. A value of one indicates that XDR streaming is enabled. + procedure WBI (Info : String) renames Osint.B.Write_Binder_Info; -- Convenient shorthand used throughout @@ -758,13 +762,21 @@ package body Bindgen is """__gnat_default_ss_size"");"); end if; - WBI (" Leap_Seconds_Support : Integer;"); - WBI (" pragma Import (C, Leap_Seconds_Support, " & - """__gl_leap_seconds_support"");"); + if Leap_Seconds_Support then + WBI (" Leap_Seconds_Support : Integer;"); + WBI (" pragma Import (C, Leap_Seconds_Support, " & + """__gl_leap_seconds_support"");"); + end if; + WBI (" Bind_Env_Addr : System.Address;"); WBI (" pragma Import (C, Bind_Env_Addr, " & """__gl_bind_env_addr"");"); + if XDR_Stream then + WBI (" XDR_Stream : Integer;"); + WBI (" pragma Import (C, XDR_Stream, ""__gl_xdr_stream"");"); + end if; + -- Import entry point for elaboration time signal handler -- installation, and indication of if it's been called previously. @@ -978,16 +990,13 @@ package body Bindgen is Set_String (";"); Write_Statement_Buffer; - Set_String (" Leap_Seconds_Support := "); - if Leap_Seconds_Support then - Set_Int (1); - else - Set_Int (0); + WBI (" Leap_Seconds_Support := 1;"); end if; - Set_String (";"); - Write_Statement_Buffer; + if XDR_Stream then + WBI (" XDR_Stream := 1;"); + end if; if Bind_Env_String_Built then WBI (" Bind_Env_Addr := Bind_Env'Address;"); diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 45215d2ebea..6fd55ee8721 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -315,6 +315,11 @@ package body Bindusg is Write_Line (" -x Exclude source files (check object consistency only)"); + -- Line for -xdr switch + + Write_Line + (" -xdr Use the XDR protocol for streaming"); + -- Line for -X switch Write_Line diff --git a/gcc/ada/doc/gnat_rm/implementation_advice.rst b/gcc/ada/doc/gnat_rm/implementation_advice.rst index 31376d92461..998d0c597df 100644 --- a/gcc/ada/doc/gnat_rm/implementation_advice.rst +++ b/gcc/ada/doc/gnat_rm/implementation_advice.rst @@ -712,43 +712,20 @@ RM 13.13.2(1.6): Stream Oriented Attributes to the nearest factor or multiple of the word size that is also a multiple of the stream element size." -Followed, except that the number of stream elements is a power of 2. +Followed, except that the number of stream elements is 1, 2, 3, 4 or 8. The Stream_Size may be used to override the default choice. -However, such an implementation is based on direct binary -representations and is therefore target- and endianness-dependent. To -address this issue, GNAT also supplies an alternate implementation of -the stream attributes ``Read`` and ``Write``, which uses the -target-independent XDR standard representation for scalar types. +The default implementation is based on direct binary representations and is +therefore target- and endianness-dependent. To address this issue, GNAT also +supplies an alternate implementation of the stream attributes ``Read`` and +``Write``, which uses the target-independent XDR standard representation for +scalar types. This XDR alternative can be enabled via the binder switch -xdr. .. index:: XDR representation - .. index:: Read attribute - .. index:: Write attribute - .. index:: Stream oriented attributes -The XDR implementation is provided as an alternative body of the -``System.Stream_Attributes`` package, in the file -:file:`s-stratt-xdr.adb` in the GNAT library. -There is no :file:`s-stratt-xdr.ads` file. -In order to install the XDR implementation, do the following: - -* Replace the default implementation of the - ``System.Stream_Attributes`` package with the XDR implementation. - For example on a Unix platform issue the commands: - - .. code-block:: sh - - $ mv s-stratt.adb s-stratt-default.adb - $ mv s-stratt-xdr.adb s-stratt.adb - - -* - Rebuild the GNAT run-time library as documented in - the *GNAT and Libraries* section of the :title:`GNAT User's Guide`. - RM A.1(52): Names of Predefined Numeric Types ============================================= diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index c174073d508..d72f905a2df 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -14445,14 +14445,14 @@ to the nearest factor or multiple of the word size that is also a multiple of the stream element size." @end quotation -Followed, except that the number of stream elements is a power of 2. +Followed, except that the number of stream elements is 1, 2, 3, 4 or 8. The Stream_Size may be used to override the default choice. -However, such an implementation is based on direct binary -representations and is therefore target- and endianness-dependent. To -address this issue, GNAT also supplies an alternate implementation of -the stream attributes @code{Read} and @code{Write}, which uses the -target-independent XDR standard representation for scalar types. +The default implementation is based on direct binary representations and is +therefore target- and endianness-dependent. To address this issue, GNAT also +supplies an alternate implementation of the stream attributes @code{Read} and +@code{Write}, which uses the target-independent XDR standard representation for +scalar types. This XDR alternative can be enabled via the binder switch -xdr. @geindex XDR representation @@ -14462,30 +14462,6 @@ target-independent XDR standard representation for scalar types. @geindex Stream oriented attributes -The XDR implementation is provided as an alternative body of the -@code{System.Stream_Attributes} package, in the file -@code{s-stratt-xdr.adb} in the GNAT library. -There is no @code{s-stratt-xdr.ads} file. -In order to install the XDR implementation, do the following: - - -@itemize * - -@item -Replace the default implementation of the -@code{System.Stream_Attributes} package with the XDR implementation. -For example on a Unix platform issue the commands: - -@example -$ mv s-stratt.adb s-stratt-default.adb -$ mv s-stratt-xdr.adb s-stratt.adb -@end example - -@item -Rebuild the GNAT run-time library as documented in -the @emph{GNAT and Libraries} section of the @cite{GNAT User's Guide}. -@end itemize - @node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 1 6 Stream Oriented Attributes,Implementation Advice @anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{236} @section RM A.1(52): Names of Predefined Numeric Types diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 4907082a42c..4372152b439 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -499,6 +499,11 @@ procedure Gnatbind is Opt.Bind_Alternate_Main_Name := True; Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last)); + -- -xdr + + elsif Argv (2 .. Argv'Last) = "xdr" then + Opt.XDR_Stream := True; + -- All other options are single character and are handled by -- Scan_Binder_Switches. diff --git a/gcc/ada/init.c b/gcc/ada/init.c index f9f627ebcff..e76aa79c5a8 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -122,6 +122,7 @@ int __gl_default_stack_size = -1; int __gl_leap_seconds_support = 0; int __gl_canonical_streams = 0; char *__gl_bind_env_addr = NULL; +int __gl_xdr_stream = 0; /* This value is not used anymore, but kept for bootstrapping purpose. */ int __gl_zero_cost_exceptions = 0; diff --git a/gcc/ada/libgnat/s-statxd.adb b/gcc/ada/libgnat/s-statxd.adb new file mode 100644 index 00000000000..fcefae7e6f2 --- /dev/null +++ b/gcc/ada/libgnat/s-statxd.adb @@ -0,0 +1,2010 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . X D R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2020, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; + +package body System.Stream_Attributes.XDR 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; + + 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; + I24_L : constant := 3; + 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_I24 is SEA (1 .. I24_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_I24 is + new Ada.Unchecked_Conversion (Integer_24, XDR_S_I24); + function XDR_S_I24_To_Integer is + new Ada.Unchecked_Conversion (XDR_S_I24, Integer_24); + + 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; + U24_L : constant := 3; + 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_U24 is SEA (1 .. U24_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; + type XDR_U24 is mod BB ** U24_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_U24 is + new Ada.Unchecked_Conversion (Unsigned_24, XDR_S_U24); + function XDR_S_U24_To_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_U24, Unsigned_24); + + 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 Ada.Unchecked_Conversion (System.Address, XDR_SA); + function To_XDR_SA is new Ada.Unchecked_Conversion (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; + + ---------- + -- 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; + + Is_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 + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_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 Is_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_I24 -- + ----------- + + function I_I24 (Stream : not null access RST) return Integer_24 is + S : XDR_S_I24; + L : SEO; + U : XDR_U24 := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_I24_To_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_U24 (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Integer_24 (U); + + else + return Integer_24 (-((XDR_U24'Last xor U) + 1)); + end if; + end if; + end I_I24; + + ---------- + -- 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; + + Is_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 + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_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 Is_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; + + Is_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 + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_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 Is_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); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLU_To_Long_Long_Unsigned (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_Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : not null access RST) return Long_Unsigned is + S : XDR_S_LU; + 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_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); + + else + -- Compute using machine unsigned + -- rather than 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; + + return X; + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : not null access RST) return Short_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; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + Result : Short_Float; + S : SEA (1 .. SF_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 (SF_L + 1 - F_Bytes) and F_Mask); + for N in SF_L + 2 - F_Bytes .. SF_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_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 := Short_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Short_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : not null access RST) return Short_Integer is + S : XDR_S_SI; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SI_To_Short_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Integer (U); + else + return Short_Integer (-((XDR_SU'Last xor U) + 1)); + end if; + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : not null access RST) return Short_Short_Integer is + S : XDR_S_SSI; + L : SEO; + U : XDR_SSU; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SSI_To_Short_Short_Integer (S); + + else + U := XDR_SSU (S (1)); + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Short_Integer (U); + else + return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); + end if; + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is + S : XDR_S_SSU; + L : SEO; + U : XDR_SSU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + U := XDR_SSU (S (1)); + return Short_Short_Unsigned (U); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : not null access RST) return Short_Unsigned is + S : XDR_S_SU; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SU_To_Short_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + return Short_Unsigned (U); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : not null access RST) return Unsigned is + S : XDR_S_U; + 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_U_To_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + return Unsigned (U); + end if; + end I_U; + + ----------- + -- I_U24 -- + ----------- + + function I_U24 (Stream : not null access RST) return Unsigned_24 is + S : XDR_S_U24; + L : SEO; + U : XDR_U24 := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_U24_To_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_U24 (S (N)); + end loop; + + return Unsigned_24 (U); + end if; + end I_U24; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : not null access RST) return Wide_Character is + S : XDR_S_WC; + L : SEO; + U : XDR_WC := 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_WC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Character representation clause + + return Wide_Character'Val (U); + end if; + end I_WC; + + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + S : XDR_S_WWC; + L : SEO; + U : XDR_WWC := 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_WWC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Wide_Character representation clause + + return Wide_Wide_Character'Val (U); + end if; + end I_WWC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is + S : XDR_S_TM; + U : XDR_TM; + + begin + U := XDR_TM (To_XDR_SA (Item.P1)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + U := XDR_TM (To_XDR_SA (Item.P2)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is + S : XDR_S_TM; + U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); + + begin + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : not null access RST; Item : Boolean) is + begin + if Item then + W_SSU (Stream, 1); + else + W_SSU (Stream, 0); + end if; + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : not null access RST; Item : Character) is + S : XDR_S_C; + + pragma Assert (C_L = 1); + + begin + -- Use Ada requirements on Character representation clause + + S (1) := SE (Character'Pos (Item)); + + Ada.Streams.Write (Stream.all, S); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : not null access RST; Item : Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Float; + S : SEA (1 .. F_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Float'Scaling (F, F_Size + E_Bias - 1); + E := -E_Bias; + else + F := Float'Scaling (Float'Fraction (F), F_Size + 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse F_L - F_Bytes + 1 .. F_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : not null access RST; Item : Integer) is + S : XDR_S_I; + U : XDR_U; + + begin + if Optimize_Integers then + S := Integer_To_XDR_S_I (Item); + + else + -- Test sign and apply two complement notation + + U := (if Item < 0 + then XDR_U'Last xor XDR_U (-(Item + 1)) + else XDR_U (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_I; + + ----------- + -- W_I24 -- + ----------- + + procedure W_I24 (Stream : not null access RST; Item : Integer_24) is + S : XDR_S_I24; + U : XDR_U24; + + begin + if Optimize_Integers then + S := Integer_To_XDR_S_I24 (Item); + + else + -- Test sign and apply two complement notation + + U := (if Item < 0 + then XDR_U24'Last xor XDR_U24 (-(Item + 1)) + else XDR_U24 (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_I24; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : not null access RST; Item : Long_Float) is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Float; + S : SEA (1 .. LF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Long_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Long_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse LF_L - F_Bytes + 1 .. LF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : not null access RST; Item : Long_Integer) is + S : XDR_S_LI; + U : Unsigned := 0; + X : Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); + else + X := Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : not null access RST; Item : 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_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + HFS : constant Integer := F_Size / 2; + + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned; + Fraction_2 : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Long_Float := Item; + S : SEA (1 .. LLF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + + if F < 0.0 then + F := -Item; + end if; + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction_1 := 0; + Fraction_2 := 0; + + else + E := Long_Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Long_Long_Float'Scaling (F, E_Bias - 1); + E := -E_Bias; + else + F := Long_Long_Float'Scaling + (Long_Long_Float'Fraction (F), 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + F := Long_Long_Float'Scaling (F, F_Size - HFS); + Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + F := F - Long_Long_Float (Fraction_1); + F := Long_Long_Float'Scaling (F, HFS); + Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + end if; + + -- Store Fraction_1 + + for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + S (I) := SE (Fraction_1 mod BB); + Fraction_1 := Fraction_1 / BB; + end loop; + + -- Store Fraction_2 + + for I in reverse LLF_L - 6 .. LLF_L loop + S (SEO (I)) := SE (Fraction_2 mod BB); + Fraction_2 := Fraction_2 / BB; + end loop; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI + (Stream : not null access RST; + Item : Long_Long_Integer) + is + S : XDR_S_LLI; + U : Unsigned := 0; + X : Long_Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LLI (Item); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); + else + X := Long_Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU + (Stream : not null access RST; + Item : Long_Long_Unsigned) + is + S : XDR_S_LLU; + U : Unsigned := 0; + X : Long_Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + + else + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is + S : XDR_S_LU; + U : Unsigned := 0; + X : Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); + + else + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : not null access RST; Item : Short_Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Short_Float; + S : SEA (1 .. SF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Short_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Short_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Short_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse SF_L - F_Bytes + 1 .. SF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : not null access RST; Item : Short_Integer) is + S : XDR_S_SI; + U : XDR_SU; + + begin + if Optimize_Integers then + S := Short_Integer_To_XDR_S_SI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SU'Last xor XDR_SU (-(Item + 1)) + else XDR_SU (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI + (Stream : not null access RST; + Item : Short_Short_Integer) + is + S : XDR_S_SSI; + U : XDR_SSU; + + begin + if Optimize_Integers then + S := Short_Short_Integer_To_XDR_S_SSI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) + else XDR_SSU (Item)); + + S (1) := SE (U); + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU + (Stream : not null access RST; + Item : Short_Short_Unsigned) + is + U : constant XDR_SSU := XDR_SSU (Item); + S : XDR_S_SSU; + + begin + S (1) := SE (U); + Ada.Streams.Write (Stream.all, S); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is + S : XDR_S_SU; + U : XDR_SU := XDR_SU (Item); + + begin + if Optimize_Integers then + S := Short_Unsigned_To_XDR_S_SU (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : not null access RST; Item : Unsigned) is + S : XDR_S_U; + U : XDR_U := XDR_U (Item); + + begin + if Optimize_Integers then + S := Unsigned_To_XDR_S_U (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_U; + + ----------- + -- W_U24 -- + ----------- + + procedure W_U24 (Stream : not null access RST; Item : Unsigned_24) is + S : XDR_S_U24; + U : XDR_U24 := XDR_U24 (Item); + + begin + if Optimize_Integers then + S := Unsigned_To_XDR_S_U24 (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_U24; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : not null access RST; Item : Wide_Character) is + S : XDR_S_WC; + U : XDR_WC; + + begin + -- Use Ada requirements on Wide_Character representation clause + + U := XDR_WC (Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WC; + + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + S : XDR_S_WWC; + U : XDR_WWC; + + begin + -- Use Ada requirements on Wide_Wide_Character representation clause + + U := XDR_WWC (Wide_Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WWC; + +end System.Stream_Attributes.XDR; diff --git a/gcc/ada/libgnat/s-statxd.ads b/gcc/ada/libgnat/s-statxd.ads new file mode 100644 index 00000000000..cca5e5471bd --- /dev/null +++ b/gcc/ada/libgnat/s-statxd.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . X D R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains alternate implementations of the stream attributes +-- for elementary types based on the XDR standard. These are the subprograms +-- that are directly accessed by occurrences of the stream attributes where +-- the type is elementary. + +-- It is especially useful for exchanging streams between two different +-- systems with different basic type representations and endianness. + +-- We only provide the subprograms for the standard base types. For user +-- defined types, the subprogram for the corresponding root type is called +-- with an appropriate conversion. + +package System.Stream_Attributes.XDR is + pragma Preelaborate; + + pragma Suppress (Accessibility_Check, XDR); + -- No need to check accessibility on arguments of subprograms + + --------------------- + -- Input Functions -- + --------------------- + + -- Functions for S'Input attribute. These functions are also used for + -- S'Read, with the obvious transformation, since the input operation + -- is the same for all elementary types (no bounds or discriminants + -- are involved). + + function I_AD (Stream : not null access RST) return Fat_Pointer; + function I_AS (Stream : not null access RST) return Thin_Pointer; + function I_B (Stream : not null access RST) return Boolean; + function I_C (Stream : not null access RST) return Character; + function I_F (Stream : not null access RST) return Float; + function I_I (Stream : not null access RST) return Integer; + function I_I24 (Stream : not null access RST) return Integer_24; + function I_LF (Stream : not null access RST) return Long_Float; + function I_LI (Stream : not null access RST) return Long_Integer; + function I_LLF (Stream : not null access RST) return Long_Long_Float; + function I_LLI (Stream : not null access RST) return Long_Long_Integer; + function I_LLU (Stream : not null access RST) return UST.Long_Long_Unsigned; + function I_LU (Stream : not null access RST) return UST.Long_Unsigned; + function I_SF (Stream : not null access RST) return Short_Float; + function I_SI (Stream : not null access RST) return Short_Integer; + function I_SSI (Stream : not null access RST) return Short_Short_Integer; + function I_SSU (Stream : not null access RST) return + UST.Short_Short_Unsigned; + function I_SU (Stream : not null access RST) return UST.Short_Unsigned; + function I_U (Stream : not null access RST) return UST.Unsigned; + function I_U24 (Stream : not null access RST) return Unsigned_24; + function I_WC (Stream : not null access RST) return Wide_Character; + function I_WWC (Stream : not null access RST) return Wide_Wide_Character; + + ----------------------- + -- Output Procedures -- + ----------------------- + + -- Procedures for S'Write attribute. These procedures are also used for + -- 'Output, since for elementary types there is no difference between + -- 'Write and 'Output because there are no discriminants or bounds to + -- be written. + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer); + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer); + procedure W_B (Stream : not null access RST; Item : Boolean); + procedure W_C (Stream : not null access RST; Item : Character); + procedure W_F (Stream : not null access RST; Item : Float); + procedure W_I (Stream : not null access RST; Item : Integer); + procedure W_I24 (Stream : not null access RST; Item : Integer_24); + procedure W_LF (Stream : not null access RST; Item : Long_Float); + procedure W_LI (Stream : not null access RST; Item : Long_Integer); + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float); + procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer); + procedure W_LLU (Stream : not null access RST; Item : + UST.Long_Long_Unsigned); + procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned); + procedure W_SF (Stream : not null access RST; Item : Short_Float); + procedure W_SI (Stream : not null access RST; Item : Short_Integer); + procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer); + procedure W_SSU (Stream : not null access RST; Item : + UST.Short_Short_Unsigned); + procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned); + procedure W_U (Stream : not null access RST; Item : UST.Unsigned); + procedure W_U24 (Stream : not null access RST; Item : Unsigned_24); + procedure W_WC (Stream : not null access RST; Item : Wide_Character); + procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); + +end System.Stream_Attributes.XDR; diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb index 64f3f040081..366dabdc7b6 100644 --- a/gcc/ada/libgnat/s-stratt.adb +++ b/gcc/ada/libgnat/s-stratt.adb @@ -32,9 +32,20 @@ with Ada.IO_Exceptions; with Ada.Streams; use Ada.Streams; with Ada.Unchecked_Conversion; +with System.Stream_Attributes.XDR; package body System.Stream_Attributes is + XDR_Flag : Integer; + pragma Import (C, XDR_Flag, "__gl_xdr_stream"); + -- This imported value is used to determine whether the build had the + -- binder switch "-xdr" present which enables XDR streaming and sets this + -- flag to 1. + + function XDR_Support return Boolean; + pragma Inline (XDR_Support); + -- Return True if XDR streaming should be used + Err : exception renames Ada.IO_Exceptions.End_Error; -- Exception raised if insufficient data read (note that the RM implies -- that Data_Error might be the appropriate choice, but AI95-00132 @@ -122,13 +133,22 @@ package body System.Stream_Attributes is function To_WC is new UC (S_WC, Wide_Character); function To_WWC is new UC (S_WWC, Wide_Wide_Character); + ----------------- + -- XDR_Support -- + ----------------- + + function XDR_Support return Boolean is + begin + return XDR_Flag = 1; + end XDR_Support; + ----------------- -- Block_IO_OK -- ----------------- function Block_IO_OK return Boolean is begin - return True; + return not XDR_Support; end Block_IO_OK; ---------- @@ -140,6 +160,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_AD (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -158,6 +182,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_AS (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -176,6 +204,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_B (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -194,6 +226,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_C (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -212,6 +248,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_F (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -230,6 +270,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_I (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -248,6 +292,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_I24 (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -266,6 +314,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LF (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -284,6 +336,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LI (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -302,6 +358,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LLF (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -320,6 +380,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LLI (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -340,6 +404,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LLU (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -358,6 +426,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_LU (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -376,6 +448,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_SF (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -394,6 +470,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_SI (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -412,6 +492,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_SSI (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -432,6 +516,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_SSU (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -450,6 +538,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_SU (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -468,6 +560,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_U (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -486,6 +582,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_U24 (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -504,6 +604,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_WC (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -522,6 +626,10 @@ package body System.Stream_Attributes is L : SEO; begin + if XDR_Support then + return XDR.I_WWC (Stream); + end if; + Ada.Streams.Read (Stream.all, T, L); if L < T'Last then @@ -538,6 +646,11 @@ package body System.Stream_Attributes is procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is T : constant S_AD := From_AD (Item); begin + if XDR_Support then + XDR.W_AD (Stream, Item); + return; + end if; + Ada.Streams.Write (Stream.all, T); end W_AD; @@ -548,6 +661,11 @@ package body System.Stream_Attributes is procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is T : constant S_AS := From_AS (Item); begin + if XDR_Support then + XDR.W_AS (Stream, Item); + return; + end if; + Ada.Streams.Write (Stream.all, T); end W_AS; @@ -558,6 +676,11 @@ package body System.Stream_Attributes is procedure W_B (Stream : not null access RST; Item : Boolean) is T : S_B; begin + if XDR_Support then + XDR.W_B (Stream, Item); + return; + end if; + T (1) := Boolean'Pos (Item); Ada.Streams.Write (Stream.all, T); end W_B; @@ -569,6 +692,11 @@ package body System.Stream_Attributes is procedure W_C (Stream : not null access RST; Item : Character) is T : S_C; begin + if XDR_Support then + XDR.W_C (Stream, Item); + return; + end if; + T (1) := Character'Pos (Item); Ada.Streams.Write (Stream.all, T); end W_C; @@ -578,9 +706,13 @@ package body System.Stream_Attributes is --------- procedure W_F (Stream : not null access RST; Item : Float) is - T : constant S_F := From_F (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_F (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_F (Item)); end W_F; --------- @@ -588,9 +720,13 @@ package body System.Stream_Attributes is --------- procedure W_I (Stream : not null access RST; Item : Integer) is - T : constant S_I := From_I (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_I (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_I (Item)); end W_I; ----------- @@ -598,9 +734,13 @@ package body System.Stream_Attributes is ----------- procedure W_I24 (Stream : not null access RST; Item : Integer_24) is - T : constant S_I24 := From_I24 (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_I24 (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_I24 (Item)); end W_I24; ---------- @@ -608,9 +748,13 @@ package body System.Stream_Attributes is ---------- procedure W_LF (Stream : not null access RST; Item : Long_Float) is - T : constant S_LF := From_LF (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LF (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LF (Item)); end W_LF; ---------- @@ -618,9 +762,13 @@ package body System.Stream_Attributes is ---------- procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - T : constant S_LI := From_LI (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LI (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LI (Item)); end W_LI; ----------- @@ -628,21 +776,27 @@ package body System.Stream_Attributes is ----------- procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is - T : constant S_LLF := From_LLF (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LLF (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LLF (Item)); end W_LLF; ----------- -- W_LLI -- ----------- - procedure W_LLI - (Stream : not null access RST; Item : Long_Long_Integer) - is - T : constant S_LLI := From_LLI (Item); + procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer) is begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LLI (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LLI (Item)); end W_LLI; ----------- @@ -652,21 +806,27 @@ package body System.Stream_Attributes is procedure W_LLU (Stream : not null access RST; Item : UST.Long_Long_Unsigned) is - T : constant S_LLU := From_LLU (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LLU (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LLU (Item)); end W_LLU; ---------- -- W_LU -- ---------- - procedure W_LU - (Stream : not null access RST; Item : UST.Long_Unsigned) - is - T : constant S_LU := From_LU (Item); + procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned) is begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_LU (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_LU (Item)); end W_LU; ---------- @@ -674,9 +834,13 @@ package body System.Stream_Attributes is ---------- procedure W_SF (Stream : not null access RST; Item : Short_Float) is - T : constant S_SF := From_SF (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_SF (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_SF (Item)); end W_SF; ---------- @@ -684,9 +848,13 @@ package body System.Stream_Attributes is ---------- procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - T : constant S_SI := From_SI (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_SI (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_SI (Item)); end W_SI; ----------- @@ -696,9 +864,13 @@ package body System.Stream_Attributes is procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer) is - T : constant S_SSI := From_SSI (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_SSI (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_SSI (Item)); end W_SSI; ----------- @@ -708,21 +880,27 @@ package body System.Stream_Attributes is procedure W_SSU (Stream : not null access RST; Item : UST.Short_Short_Unsigned) is - T : constant S_SSU := From_SSU (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_SSU (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_SSU (Item)); end W_SSU; ---------- -- W_SU -- ---------- - procedure W_SU - (Stream : not null access RST; Item : UST.Short_Unsigned) - is - T : constant S_SU := From_SU (Item); + procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned) is begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_SU (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_SU (Item)); end W_SU; --------- @@ -730,9 +908,13 @@ package body System.Stream_Attributes is --------- procedure W_U (Stream : not null access RST; Item : UST.Unsigned) is - T : constant S_U := From_U (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_U (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_U (Item)); end W_U; ----------- @@ -740,9 +922,13 @@ package body System.Stream_Attributes is ----------- procedure W_U24 (Stream : not null access RST; Item : Unsigned_24) is - T : constant S_U24 := From_U24 (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_U24 (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_U24 (Item)); end W_U24; ---------- @@ -750,9 +936,13 @@ package body System.Stream_Attributes is ---------- procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - T : constant S_WC := From_WC (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_WC (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_WC (Item)); end W_WC; ----------- @@ -762,9 +952,13 @@ package body System.Stream_Attributes is procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character) is - T : constant S_WWC := From_WWC (Item); begin - Ada.Streams.Write (Stream.all, T); + if XDR_Support then + XDR.W_WWC (Stream, Item); + return; + end if; + + Ada.Streams.Write (Stream.all, From_WWC (Item)); end W_WWC; end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads index 73369490146..c8c453aad2a 100644 --- a/gcc/ada/libgnat/s-stratt.ads +++ b/gcc/ada/libgnat/s-stratt.ads @@ -163,11 +163,8 @@ package System.Stream_Attributes is procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); function Block_IO_OK return Boolean; - -- Package System.Stream_Attributes has several bodies - the default one - -- distributed with GNAT, and s-stratt__xdr.adb, which is based on the XDR - -- standard. Both bodies share the same spec. The role of this function is - -- to indicate whether the current version of System.Stream_Attributes - -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details. + -- Indicate whether the current setting supports block IO. See + -- System.Strings.Stream_Ops (s-ststop) for details on block IO. private pragma Inline (I_AD); diff --git a/gcc/ada/libgnat/s-stratt__xdr.adb b/gcc/ada/libgnat/s-stratt__xdr.adb deleted file mode 100644 index 7e32fcf9b91..00000000000 --- a/gcc/ada/libgnat/s-stratt__xdr.adb +++ /dev/null @@ -1,2035 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2020, 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 -- --- . -- --- -- --- 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. - -pragma Warnings (Off, "*not allowed in compiler unit"); --- This body is used only when rebuilding the runtime library, not when --- building the compiler, so it's OK to depend on features that would --- otherwise break bootstrap (e.g. IF-expressions). - -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; - I24_L : constant := 3; - 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_I24 is SEA (1 .. I24_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_I24 is - new Ada.Unchecked_Conversion (Integer_24, XDR_S_I24); - function XDR_S_I24_To_Integer is - new Ada.Unchecked_Conversion (XDR_S_I24, Integer_24); - - 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; - U24_L : constant := 3; - 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_U24 is SEA (1 .. U24_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; - type XDR_U24 is mod BB ** U24_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_U24 is - new Ada.Unchecked_Conversion (Unsigned_24, XDR_S_U24); - function XDR_S_U24_To_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_U24, Unsigned_24); - - 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 -- - ----------------- - - -- We must inhibit Block_IO, because in XDR mode, each element is output - -- according to XDR requirements, which is not at all the same as writing - -- the whole array in one block. - - 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; - - Is_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 - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_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 Is_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_I24 -- - ----------- - - function I_I24 (Stream : not null access RST) return Integer_24 is - S : XDR_S_I24; - L : SEO; - U : XDR_U24 := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_I24_To_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_U24 (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Integer_24 (U); - - else - return Integer_24 (-((XDR_U24'Last xor U) + 1)); - end if; - end if; - end I_I24; - - ---------- - -- 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; - - Is_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 - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_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 Is_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; - - Is_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 - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_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 Is_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); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLU_To_Long_Long_Unsigned (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_Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LLU; - - ---------- - -- I_LU -- - ---------- - - function I_LU (Stream : not null access RST) return Long_Unsigned is - S : XDR_S_LU; - 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_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - - else - -- Compute using machine unsigned - -- rather than 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; - - return X; - end if; - end I_LU; - - ---------- - -- I_SF -- - ---------- - - function I_SF (Stream : not null access RST) return Short_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; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - Result : Short_Float; - S : SEA (1 .. SF_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 (SF_L + 1 - F_Bytes) and F_Mask); - for N in SF_L + 2 - F_Bytes .. SF_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_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 := Short_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Short_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_SF; - - ---------- - -- I_SI -- - ---------- - - function I_SI (Stream : not null access RST) return Short_Integer is - S : XDR_S_SI; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SI_To_Short_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Integer (U); - else - return Short_Integer (-((XDR_SU'Last xor U) + 1)); - end if; - end if; - end I_SI; - - ----------- - -- I_SSI -- - ----------- - - function I_SSI (Stream : not null access RST) return Short_Short_Integer is - S : XDR_S_SSI; - L : SEO; - U : XDR_SSU; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SSI_To_Short_Short_Integer (S); - - else - U := XDR_SSU (S (1)); - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Short_Integer (U); - else - return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); - end if; - end if; - end I_SSI; - - ----------- - -- I_SSU -- - ----------- - - function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is - S : XDR_S_SSU; - L : SEO; - U : XDR_SSU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); - end if; - end I_SSU; - - ---------- - -- I_SU -- - ---------- - - function I_SU (Stream : not null access RST) return Short_Unsigned is - S : XDR_S_SU; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SU_To_Short_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - return Short_Unsigned (U); - end if; - end I_SU; - - --------- - -- I_U -- - --------- - - function I_U (Stream : not null access RST) return Unsigned is - S : XDR_S_U; - 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_U_To_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - return Unsigned (U); - end if; - end I_U; - - ----------- - -- I_U24 -- - ----------- - - function I_U24 (Stream : not null access RST) return Unsigned_24 is - S : XDR_S_U24; - L : SEO; - U : XDR_U24 := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_U24_To_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_U24 (S (N)); - end loop; - - return Unsigned_24 (U); - end if; - end I_U24; - - ---------- - -- I_WC -- - ---------- - - function I_WC (Stream : not null access RST) return Wide_Character is - S : XDR_S_WC; - L : SEO; - U : XDR_WC := 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_WC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Character representation clause - - return Wide_Character'Val (U); - end if; - end I_WC; - - ----------- - -- I_WWC -- - ----------- - - function I_WWC (Stream : not null access RST) return Wide_Wide_Character is - S : XDR_S_WWC; - L : SEO; - U : XDR_WWC := 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_WWC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Wide_Character representation clause - - return Wide_Wide_Character'Val (U); - end if; - end I_WWC; - - ---------- - -- W_AD -- - ---------- - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is - S : XDR_S_TM; - U : XDR_TM; - - begin - U := XDR_TM (To_XDR_SA (Item.P1)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - U := XDR_TM (To_XDR_SA (Item.P2)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AD; - - ---------- - -- W_AS -- - ---------- - - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is - S : XDR_S_TM; - U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); - - begin - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AS; - - --------- - -- W_B -- - --------- - - procedure W_B (Stream : not null access RST; Item : Boolean) is - begin - if Item then - W_SSU (Stream, 1); - else - W_SSU (Stream, 0); - end if; - end W_B; - - --------- - -- W_C -- - --------- - - procedure W_C (Stream : not null access RST; Item : Character) is - S : XDR_S_C; - - pragma Assert (C_L = 1); - - begin - -- Use Ada requirements on Character representation clause - - S (1) := SE (Character'Pos (Item)); - - Ada.Streams.Write (Stream.all, S); - end W_C; - - --------- - -- W_F -- - --------- - - procedure W_F (Stream : not null access RST; Item : Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Float; - S : SEA (1 .. F_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Float'Scaling (F, F_Size + E_Bias - 1); - E := -E_Bias; - else - F := Float'Scaling (Float'Fraction (F), F_Size + 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse F_L - F_Bytes + 1 .. F_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_F; - - --------- - -- W_I -- - --------- - - procedure W_I (Stream : not null access RST; Item : Integer) is - S : XDR_S_I; - U : XDR_U; - - begin - if Optimize_Integers then - S := Integer_To_XDR_S_I (Item); - - else - -- Test sign and apply two complement notation - - U := (if Item < 0 - then XDR_U'Last xor XDR_U (-(Item + 1)) - else XDR_U (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_I; - - ----------- - -- W_I24 -- - ----------- - - procedure W_I24 (Stream : not null access RST; Item : Integer_24) is - S : XDR_S_I24; - U : XDR_U24; - - begin - if Optimize_Integers then - S := Integer_To_XDR_S_I24 (Item); - - else - -- Test sign and apply two complement notation - - U := (if Item < 0 - then XDR_U24'Last xor XDR_U24 (-(Item + 1)) - else XDR_U24 (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_I24; - - ---------- - -- W_LF -- - ---------- - - procedure W_LF (Stream : not null access RST; Item : Long_Float) is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Float; - S : SEA (1 .. LF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Long_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Long_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse LF_L - F_Bytes + 1 .. LF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LF; - - ---------- - -- W_LI -- - ---------- - - procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - S : XDR_S_LI; - U : Unsigned; - X : Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); - else - X := Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LI; - - ----------- - -- W_LLF -- - ----------- - - procedure W_LLF (Stream : not null access RST; Item : 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_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - HFS : constant Integer := F_Size / 2; - - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned; - Fraction_2 : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Long_Float := Item; - S : SEA (1 .. LLF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - - if F < 0.0 then - F := -Item; - end if; - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction_1 := 0; - Fraction_2 := 0; - - else - E := Long_Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Long_Long_Float'Scaling (F, E_Bias - 1); - E := -E_Bias; - else - F := Long_Long_Float'Scaling - (Long_Long_Float'Fraction (F), 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - F := Long_Long_Float'Scaling (F, F_Size - HFS); - Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - F := F - Long_Long_Float (Fraction_1); - F := Long_Long_Float'Scaling (F, HFS); - Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - end if; - - -- Store Fraction_1 - - for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - S (I) := SE (Fraction_1 mod BB); - Fraction_1 := Fraction_1 / BB; - end loop; - - -- Store Fraction_2 - - for I in reverse LLF_L - 6 .. LLF_L loop - S (SEO (I)) := SE (Fraction_2 mod BB); - Fraction_2 := Fraction_2 / BB; - end loop; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLF; - - ----------- - -- W_LLI -- - ----------- - - procedure W_LLI - (Stream : not null access RST; - Item : Long_Long_Integer) - is - S : XDR_S_LLI; - U : Unsigned; - X : Long_Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LLI (Item); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); - else - X := Long_Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLI; - - ----------- - -- W_LLU -- - ----------- - - procedure W_LLU - (Stream : not null access RST; - Item : Long_Long_Unsigned) - is - S : XDR_S_LLU; - U : Unsigned; - X : Long_Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LLU (Item); - - else - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLU; - - ---------- - -- W_LU -- - ---------- - - procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is - S : XDR_S_LU; - U : Unsigned; - X : Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); - - else - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LU; - - ---------- - -- W_SF -- - ---------- - - procedure W_SF (Stream : not null access RST; Item : Short_Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Short_Float; - S : SEA (1 .. SF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Short_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Short_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Short_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse SF_L - F_Bytes + 1 .. SF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SF; - - ---------- - -- W_SI -- - ---------- - - procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - S : XDR_S_SI; - U : XDR_SU; - - begin - if Optimize_Integers then - S := Short_Integer_To_XDR_S_SI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SU'Last xor XDR_SU (-(Item + 1)) - else XDR_SU (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SI; - - ----------- - -- W_SSI -- - ----------- - - procedure W_SSI - (Stream : not null access RST; - Item : Short_Short_Integer) - is - S : XDR_S_SSI; - U : XDR_SSU; - - begin - if Optimize_Integers then - S := Short_Short_Integer_To_XDR_S_SSI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) - else XDR_SSU (Item)); - - S (1) := SE (U); - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SSI; - - ----------- - -- W_SSU -- - ----------- - - procedure W_SSU - (Stream : not null access RST; - Item : Short_Short_Unsigned) - is - U : constant XDR_SSU := XDR_SSU (Item); - S : XDR_S_SSU; - - begin - S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); - end W_SSU; - - ---------- - -- W_SU -- - ---------- - - procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is - S : XDR_S_SU; - U : XDR_SU := XDR_SU (Item); - - begin - if Optimize_Integers then - S := Short_Unsigned_To_XDR_S_SU (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SU; - - --------- - -- W_U -- - --------- - - procedure W_U (Stream : not null access RST; Item : Unsigned) is - S : XDR_S_U; - U : XDR_U := XDR_U (Item); - - begin - if Optimize_Integers then - S := Unsigned_To_XDR_S_U (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_U; - - ----------- - -- W_U24 -- - ----------- - - procedure W_U24 (Stream : not null access RST; Item : Unsigned_24) is - S : XDR_S_U24; - U : XDR_U24 := XDR_U24 (Item); - - begin - if Optimize_Integers then - S := Unsigned_To_XDR_S_U24 (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_U24; - - ---------- - -- W_WC -- - ---------- - - procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - S : XDR_S_WC; - U : XDR_WC; - - begin - -- Use Ada requirements on Wide_Character representation clause - - U := XDR_WC (Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WC; - - ----------- - -- W_WWC -- - ----------- - - procedure W_WWC - (Stream : not null access RST; Item : Wide_Wide_Character) - is - S : XDR_S_WWC; - U : XDR_WWC; - - begin - -- Use Ada requirements on Wide_Wide_Character representation clause - - U := XDR_WWC (Wide_Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WWC; - -end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-ststop.ads b/gcc/ada/libgnat/s-ststop.ads index d0da0609d9d..321460b89d8 100644 --- a/gcc/ada/libgnat/s-ststop.ads +++ b/gcc/ada/libgnat/s-ststop.ads @@ -60,8 +60,8 @@ -- Note that if System.Stream_Attributes.Block_IO_OK is False, then the BLK_IO -- form is treated as equivalent to the normal case, so that the optimization -- is inhibited anyway, regardless of the setting of the restriction. This --- handles versions of System.Stream_Attributes (in particular the XDR version --- found in s-stratt-xdr) which do not permit block io optimization. +-- handles the XDR implementation of System.Stream_Attributes in particular +-- which does not permit block io optimization. pragma Compiler_Unit_Warning; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9e0263b431d..37f3d030e3f 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -915,7 +915,7 @@ package Opt is Leap_Seconds_Support : Boolean := False; -- GNATBIND -- Set to True to enable leap seconds support in Ada.Calendar and its - -- children. + -- children. Set by -y. Legacy_Elaboration_Checks : Boolean := False; -- GNAT @@ -1007,6 +1007,10 @@ package Opt is -- before preprocessing occurs. Set to True by switch -s of gnatprep or -- -s in preprocessing data file for the compiler. + XDR_Stream : Boolean := False; + -- GNATBIND + -- Set to True to enable XDR in s-stratt.adb. Set by -xdr. + type Create_Repinfo_File_Proc is access procedure (Src : String); type Write_Repinfo_Line_Proc is access procedure (Info : String); type Close_Repinfo_File_Proc is access procedure;