s-strxdr.adb, [...] (Block_IO_OK): New subprogram.

2008-04-08  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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

@@ -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;

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;

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;