-- --
-- 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- --
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
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
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 --
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 --
----------
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;
-- --
-- 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- --
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 --
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);
pragma Inline (I_SU);
pragma Inline (I_U);
pragma Inline (I_WC);
+ pragma Inline (I_WWC);
pragma Inline (W_AD);
pragma Inline (W_AS);
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;
-- --
-- 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- --
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
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 --
----------
if L /= S'Last then
raise Data_Error;
+
else
for N in S'Range loop
U := U * BB + XDR_TM (S (N));
if L /= S'Last then
raise Data_Error;
- else
+ else
-- Use Ada requirements on Character representation clause
return Character'Val (S (1));
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.
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.
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.
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));
if L /= S'Last then
raise Data_Error;
+
else
U := XDR_SSU (S (1));
-
return Short_Short_Unsigned (U);
end if;
end I_SSU;
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));
if L /= S'Last then
raise Data_Error;
+
else
for N in S'Range loop
U := U * BB + XDR_WC (S (N));
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 --
----------
pragma Assert (C_L = 1);
begin
-
-- Use Ada requirements on Character representation clause
S (1) := SE (Character'Pos (Item));
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
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
-- 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;
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
-- 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;
begin
if Optimize_Integers then
S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
+
else
-- Compute using machine unsigned
-- rather than long_long_unsigned.
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.
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
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
begin
S (1) := SE (U);
-
Ada.Streams.Write (Stream.all, S);
end W_SSU;
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);
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 : XDR_WC;
begin
-
-- Use Ada requirements on Wide_Character representation clause
U := XDR_WC (Wide_Character'Pos (Item));
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;
OSDN Git Service
