From 9147cc0be70d7bcee6ad47ed11834f71ff161e99 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 8 Apr 2008 08:55:45 +0200 Subject: [PATCH] s-strxdr.adb, [...] (Block_IO_OK): New subprogram. 2008-04-08 Hristian Kirtchev * s-strxdr.adb, s-stratt.ads, s-stratt.adb (Block_IO_OK): New subprogram. Add new subtype S_WWC, unchecked conversion routines From_WWC and To_WWC. (I_WWC, O_WWC): New routines for input and output of Wide_Wide_Character. From-SVN: r134052 --- gcc/ada/s-stratt.adb | 44 +++++++++++++++- gcc/ada/s-stratt.ads | 15 +++++- gcc/ada/s-strxdr.adb | 117 ++++++++++++++++++++++++++++++++++++------- 3 files changed, 156 insertions(+), 20 deletions(-) diff --git a/gcc/ada/s-stratt.adb b/gcc/ada/s-stratt.adb index ebfd22cf3e0..757fad6e173 100644 --- a/gcc/ada/s-stratt.adb +++ b/gcc/ada/s-stratt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -74,6 +74,7 @@ package body System.Stream_Attributes is subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); + subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU); -- Unchecked conversions from the elementary type to the stream type @@ -94,6 +95,7 @@ package body System.Stream_Attributes is function From_SU is new UC (UST.Short_Unsigned, S_SU); function From_U is new UC (UST.Unsigned, S_U); function From_WC is new UC (Wide_Character, S_WC); + function From_WWC is new UC (Wide_Wide_Character, S_WWC); -- Unchecked conversions from the stream type to elementary type @@ -114,6 +116,16 @@ package body System.Stream_Attributes is function To_SU is new UC (S_SU, UST.Short_Unsigned); function To_U is new UC (S_U, UST.Unsigned); function To_WC is new UC (S_WC, Wide_Character); + function To_WWC is new UC (S_WWC, Wide_Wide_Character); + + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return True; + end Block_IO_OK; ---------- -- I_AD -- @@ -461,6 +473,24 @@ package body System.Stream_Attributes is end if; end I_WC; + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + T : S_WWC; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_WWC (T); + end if; + end I_WWC; + ---------- -- W_AD -- ---------- @@ -665,4 +695,16 @@ package body System.Stream_Attributes is Ada.Streams.Write (Stream.all, T); end W_WC; + ----------- + -- W_WWC -- + ----------- + + 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); + end W_WWC; + end System.Stream_Attributes; diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads index e1b5960d84e..7cb837fc96d 100644 --- a/gcc/ada/s-stratt.ads +++ b/gcc/ada/s-stratt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -121,6 +121,7 @@ package System.Stream_Attributes is 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_WC (Stream : not null access RST) return Wide_Character; + function I_WWC (Stream : not null access RST) return Wide_Wide_Character; ----------------------- -- Output Procedures -- @@ -154,6 +155,14 @@ package System.Stream_Attributes is Item : UST.Short_Unsigned); procedure W_U (Stream : not null access RST; Item : UST.Unsigned); procedure W_WC (Stream : not null access RST; Item : Wide_Character); + 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, s-strxdr.adb which is based on the XDR standard + -- and s-stratt.adb for Garlic. All three bodies share the same spec. The + -- role of this function is to determine whether the current version of + -- System.Stream_Attributes is able to support block IO. private pragma Inline (I_AD); @@ -175,6 +184,7 @@ private pragma Inline (I_SU); pragma Inline (I_U); pragma Inline (I_WC); + pragma Inline (I_WWC); pragma Inline (W_AD); pragma Inline (W_AS); @@ -195,5 +205,8 @@ private pragma Inline (W_SU); pragma Inline (W_U); pragma Inline (W_WC); + pragma Inline (W_WWC); + + pragma Inline (Block_IO_OK); end System.Stream_Attributes; diff --git a/gcc/ada/s-strxdr.adb b/gcc/ada/s-strxdr.adb index 053582ceee1..ca37a7fd4e7 100644 --- a/gcc/ada/s-strxdr.adb +++ b/gcc/ada/s-strxdr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2008, 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- -- @@ -267,6 +267,12 @@ package body System.Stream_Attributes is 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 @@ -275,6 +281,15 @@ package body System.Stream_Attributes is Optimize_Integers : constant Boolean := Default_Bit_Order = High_Order_First; + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return False; + end Block_IO_OK; + ---------- -- I_AD -- ---------- @@ -303,6 +318,7 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + else for N in S'Range loop U := U * BB + XDR_TM (S (N)); @@ -338,8 +354,8 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; - else + else -- Use Ada requirements on Character representation clause return Character'Val (S (1)); @@ -694,10 +710,11 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_LLI_To_Long_Long_Integer (S); - else + else -- Compute using machine unsigned for computing -- rather than long_long_unsigned. @@ -737,10 +754,11 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return XDR_S_LLU_To_Long_Long_Unsigned (S); - else + else -- Compute using machine unsigned -- rather than long_long_unsigned. @@ -774,10 +792,11 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + elsif Optimize_Integers then return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - else + else -- Compute using machine unsigned -- rather than long_unsigned. @@ -924,8 +943,10 @@ package body System.Stream_Attributes is 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)); @@ -953,9 +974,9 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + else U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); end if; end I_SSU; @@ -974,8 +995,10 @@ package body System.Stream_Attributes is 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)); @@ -1026,6 +1049,7 @@ package body System.Stream_Attributes is if L /= S'Last then raise Data_Error; + else for N in S'Range loop U := U * BB + XDR_WC (S (N)); @@ -1037,6 +1061,32 @@ package body System.Stream_Attributes is 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 -- ---------- @@ -1111,7 +1161,6 @@ package body System.Stream_Attributes is pragma Assert (C_L = 1); begin - -- Use Ada requirements on Character representation clause S (1) := SE (Character'Pos (Item)); @@ -1212,8 +1261,8 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Integer_To_XDR_S_I (Item); - else + else -- Test sign and apply two complement notation if Item < 0 then @@ -1329,8 +1378,8 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - else + else -- Test sign and apply two complement notation if Item < 0 then @@ -1462,8 +1511,9 @@ package body System.Stream_Attributes is -- W_LLI -- ----------- - procedure W_LLI (Stream : not null access RST; - Item : Long_Long_Integer) + procedure W_LLI + (Stream : not null access RST; + Item : Long_Long_Integer) is S : XDR_S_LLI; U : Unsigned; @@ -1472,8 +1522,8 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Long_Long_Integer_To_XDR_S_LLI (Item); - else + else -- Test sign and apply two complement notation if Item < 0 then @@ -1510,8 +1560,10 @@ package body System.Stream_Attributes is -- W_LLU -- ----------- - procedure W_LLU (Stream : not null access RST; - Item : Long_Long_Unsigned) is + procedure W_LLU + (Stream : not null access RST; + Item : Long_Long_Unsigned) + is S : XDR_S_LLU; U : Unsigned; X : Long_Long_Unsigned := Item; @@ -1519,6 +1571,7 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + else -- Compute using machine unsigned -- rather than long_long_unsigned. @@ -1556,6 +1609,7 @@ package body System.Stream_Attributes is 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. @@ -1673,8 +1727,8 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Short_Integer_To_XDR_S_SI (Item); - else + else -- Test sign and apply two complement's notation if Item < 0 then @@ -1710,8 +1764,8 @@ package body System.Stream_Attributes is begin if Optimize_Integers then S := Short_Short_Integer_To_XDR_S_SSI (Item); - else + else -- Test sign and apply two complement's notation if Item < 0 then @@ -1739,7 +1793,6 @@ package body System.Stream_Attributes is begin S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); end W_SSU; @@ -1754,6 +1807,7 @@ package body System.Stream_Attributes is 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); @@ -1779,6 +1833,7 @@ package body System.Stream_Attributes is 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); @@ -1802,7 +1857,6 @@ package body System.Stream_Attributes is U : XDR_WC; begin - -- Use Ada requirements on Wide_Character representation clause U := XDR_WC (Wide_Character'Pos (Item)); @@ -1819,4 +1873,31 @@ package body System.Stream_Attributes is 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; -- 2.30.2