From 1ed0551d5adebbadca367dc8284a6c54afee495f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sat, 21 Mar 2020 15:03:58 -0400 Subject: [PATCH] [Ada] ACATS 4.1Q - CDD2A04 - RLS not followed 2020-06-12 Arnaud Charlet gcc/ada/ * exp_strm.adb (Build_Elementary_Input_Call): Add support for 24 bits elementary types. * rtsfind.ads: Add 24 bits integer streaming routines. * sem_ch13.adb (Analyze_Attribute_Definition_Clause [Attribute_Stream_Size]): Add support for 24 bits elementary types. * libgnat/s-stratt.ads, libgnat/s-stratt.adb, libgnat/s-stratt__xdr.adb: Add support for signed and unsigned 24 bits integers. --- gcc/ada/exp_strm.adb | 10 ++ gcc/ada/libgnat/s-stratt.adb | 62 +++++++++++ gcc/ada/libgnat/s-stratt.ads | 10 ++ gcc/ada/libgnat/s-stratt__xdr.adb | 168 +++++++++++++++++++++++++++--- gcc/ada/rtsfind.ads | 8 ++ gcc/ada/sem_ch13.adb | 10 +- 6 files changed, 246 insertions(+), 22 deletions(-) diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 5d73498be2e..6cda955760f 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -569,6 +569,9 @@ package body Exp_Strm is elsif P_Size <= Standard_Short_Integer_Size then Lib_RE := RE_I_SI; + elsif P_Size = 24 then + Lib_RE := RE_I_I24; + elsif P_Size <= Standard_Integer_Size then Lib_RE := RE_I_I; @@ -597,6 +600,9 @@ package body Exp_Strm is elsif P_Size <= Standard_Short_Integer_Size then Lib_RE := RE_I_SU; + elsif P_Size = 24 then + Lib_RE := RE_I_U24; + elsif P_Size <= Standard_Integer_Size then Lib_RE := RE_I_U; @@ -798,6 +804,8 @@ package body Exp_Strm is Lib_RE := RE_W_SSI; elsif P_Size <= Standard_Short_Integer_Size then Lib_RE := RE_W_SI; + elsif P_Size = 24 then + Lib_RE := RE_W_I24; elsif P_Size <= Standard_Integer_Size then Lib_RE := RE_W_I; elsif P_Size <= Standard_Long_Integer_Size then @@ -822,6 +830,8 @@ package body Exp_Strm is Lib_RE := RE_W_SSU; elsif P_Size <= Standard_Short_Integer_Size then Lib_RE := RE_W_SU; + elsif P_Size = 24 then + Lib_RE := RE_W_U24; elsif P_Size <= Standard_Integer_Size then Lib_RE := RE_W_U; elsif P_Size <= Standard_Long_Integer_Size then diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb index 66c05762f9b..64f3f040081 100644 --- a/gcc/ada/libgnat/s-stratt.adb +++ b/gcc/ada/libgnat/s-stratt.adb @@ -59,6 +59,7 @@ package body System.Stream_Attributes is subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU); subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU); subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU); + subtype S_I24 is SEA (1 .. (Integer_24'Size + SU - 1) / SU); subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU); subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU); subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU); @@ -71,6 +72,7 @@ package body System.Stream_Attributes is subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU); 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_U24 is SEA (1 .. (Unsigned_24'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); @@ -80,6 +82,7 @@ package body System.Stream_Attributes is function From_AS is new UC (Thin_Pointer, S_AS); function From_F is new UC (Float, S_F); function From_I is new UC (Integer, S_I); + function From_I24 is new UC (Integer_24, S_I24); function From_LF is new UC (Long_Float, S_LF); function From_LI is new UC (Long_Integer, S_LI); function From_LLF is new UC (Long_Long_Float, S_LLF); @@ -92,6 +95,7 @@ package body System.Stream_Attributes is function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU); function From_SU is new UC (UST.Short_Unsigned, S_SU); function From_U is new UC (UST.Unsigned, S_U); + function From_U24 is new UC (Unsigned_24, S_U24); function From_WC is new UC (Wide_Character, S_WC); function From_WWC is new UC (Wide_Wide_Character, S_WWC); @@ -101,6 +105,7 @@ package body System.Stream_Attributes is function To_AS is new UC (S_AS, Thin_Pointer); function To_F is new UC (S_F, Float); function To_I is new UC (S_I, Integer); + function To_I24 is new UC (S_I24, Integer_24); function To_LF is new UC (S_LF, Long_Float); function To_LI is new UC (S_LI, Long_Integer); function To_LLF is new UC (S_LLF, Long_Long_Float); @@ -113,6 +118,7 @@ package body System.Stream_Attributes is function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned); function To_SU is new UC (S_SU, UST.Short_Unsigned); function To_U is new UC (S_U, UST.Unsigned); + function To_U24 is new UC (S_U24, Unsigned_24); function To_WC is new UC (S_WC, Wide_Character); function To_WWC is new UC (S_WWC, Wide_Wide_Character); @@ -233,6 +239,24 @@ package body System.Stream_Attributes is end if; end I_I; + ----------- + -- I_I24 -- + ----------- + + function I_I24 (Stream : not null access RST) return Integer_24 is + T : S_I24; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_I24 (T); + end if; + end I_I24; + ---------- -- I_LF -- ---------- @@ -453,6 +477,24 @@ package body System.Stream_Attributes is end if; end I_U; + ----------- + -- I_U24 -- + ----------- + + function I_U24 (Stream : not null access RST) return Unsigned_24 is + T : S_U24; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_U24 (T); + end if; + end I_U24; + ---------- -- I_WC -- ---------- @@ -551,6 +593,16 @@ package body System.Stream_Attributes is Ada.Streams.Write (Stream.all, T); end W_I; + ----------- + -- W_I24 -- + ----------- + + 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); + end W_I24; + ---------- -- W_LF -- ---------- @@ -683,6 +735,16 @@ package body System.Stream_Attributes is Ada.Streams.Write (Stream.all, T); end W_U; + ----------- + -- W_U24 -- + ----------- + + 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); + end W_U24; + ---------- -- W_WC -- ---------- diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads index 8265289eb65..73369490146 100644 --- a/gcc/ada/libgnat/s-stratt.ads +++ b/gcc/ada/libgnat/s-stratt.ads @@ -53,6 +53,12 @@ package System.Stream_Attributes is subtype SEC is Ada.Streams.Stream_Element_Count; + type Integer_24 is range -2 ** 23 .. 2 ** 23 - 1; + for Integer_24'Size use 24; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + -- Enumeration types are usually transferred using the routine for the -- corresponding integer. The exception is that special routines are -- provided for Boolean and the character types, in case the protocol @@ -104,6 +110,7 @@ package System.Stream_Attributes is 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; @@ -117,6 +124,7 @@ package System.Stream_Attributes is 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; @@ -135,6 +143,7 @@ package System.Stream_Attributes is 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); @@ -149,6 +158,7 @@ package System.Stream_Attributes is 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); diff --git a/gcc/ada/libgnat/s-stratt__xdr.adb b/gcc/ada/libgnat/s-stratt__xdr.adb index 1cc933a5774..7e32fcf9b91 100644 --- a/gcc/ada/libgnat/s-stratt__xdr.adb +++ b/gcc/ada/libgnat/s-stratt__xdr.adb @@ -139,40 +139,47 @@ package body System.Stream_Attributes is 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); + 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); + 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); + 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); + 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); + 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); + 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); + 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); + 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); + 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 @@ -187,12 +194,14 @@ package body System.Stream_Attributes is 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); @@ -200,26 +209,32 @@ package body System.Stream_Attributes is 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); + 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); + 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); + new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); function XDR_S_U_To_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); + 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); + 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); + 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); + 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); + 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 @@ -484,6 +499,40 @@ package body System.Stream_Attributes is 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 -- ---------- @@ -1042,6 +1091,33 @@ package body System.Stream_Attributes is 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 -- ---------- @@ -1289,6 +1365,38 @@ package body System.Stream_Attributes is 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 -- ---------- @@ -1846,6 +1954,32 @@ package body System.Stream_Attributes is 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 -- ---------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ad113fd7244..3dee2c0b698 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1377,6 +1377,7 @@ package Rtsfind is RE_I_C, -- System.Stream_Attributes RE_I_F, -- System.Stream_Attributes RE_I_I, -- System.Stream_Attributes + RE_I_I24, -- System.Stream_Attributes RE_I_LF, -- System.Stream_Attributes RE_I_LI, -- System.Stream_Attributes RE_I_LLF, -- System.Stream_Attributes @@ -1389,6 +1390,7 @@ package Rtsfind is RE_I_SSU, -- System.Stream_Attributes RE_I_SU, -- System.Stream_Attributes RE_I_U, -- System.Stream_Attributes + RE_I_U24, -- System.Stream_Attributes RE_I_WC, -- System.Stream_Attributes RE_I_WWC, -- System.Stream_Attributes @@ -1398,6 +1400,7 @@ package Rtsfind is RE_W_C, -- System.Stream_Attributes RE_W_F, -- System.Stream_Attributes RE_W_I, -- System.Stream_Attributes + RE_W_I24, -- System.Stream_Attributes RE_W_LF, -- System.Stream_Attributes RE_W_LI, -- System.Stream_Attributes RE_W_LLF, -- System.Stream_Attributes @@ -1410,6 +1413,7 @@ package Rtsfind is RE_W_SSU, -- System.Stream_Attributes RE_W_SU, -- System.Stream_Attributes RE_W_U, -- System.Stream_Attributes + RE_W_U24, -- System.Stream_Attributes RE_W_WC, -- System.Stream_Attributes RE_W_WWC, -- System.Stream_Attributes @@ -2654,6 +2658,7 @@ package Rtsfind is RE_I_C => System_Stream_Attributes, RE_I_F => System_Stream_Attributes, RE_I_I => System_Stream_Attributes, + RE_I_I24 => System_Stream_Attributes, RE_I_LF => System_Stream_Attributes, RE_I_LI => System_Stream_Attributes, RE_I_LLF => System_Stream_Attributes, @@ -2666,6 +2671,7 @@ package Rtsfind is RE_I_SSU => System_Stream_Attributes, RE_I_SU => System_Stream_Attributes, RE_I_U => System_Stream_Attributes, + RE_I_U24 => System_Stream_Attributes, RE_I_WC => System_Stream_Attributes, RE_I_WWC => System_Stream_Attributes, @@ -2675,6 +2681,7 @@ package Rtsfind is RE_W_C => System_Stream_Attributes, RE_W_F => System_Stream_Attributes, RE_W_I => System_Stream_Attributes, + RE_W_I24 => System_Stream_Attributes, RE_W_LF => System_Stream_Attributes, RE_W_LI => System_Stream_Attributes, RE_W_LLF => System_Stream_Attributes, @@ -2687,6 +2694,7 @@ package Rtsfind is RE_W_SSU => System_Stream_Attributes, RE_W_SU => System_Stream_Attributes, RE_W_U => System_Stream_Attributes, + RE_W_U24 => System_Stream_Attributes, RE_W_WC => System_Stream_Attributes, RE_W_WWC => System_Stream_Attributes, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e9473af1eb2..61695fcbab3 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6593,19 +6593,19 @@ package body Sem_Ch13 is elsif Is_Elementary_Type (U_Ent) then if Size /= System_Storage_Unit and then Size /= System_Storage_Unit * 2 + and then Size /= System_Storage_Unit * 3 and then Size /= System_Storage_Unit * 4 and then Size /= System_Storage_Unit * 8 then - Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); Error_Msg_N - ("stream size for elementary type must be a power of 2 " - & "and at least ^", N); + ("stream size for elementary type must be 8, 16, 24, " & + "32 or 64", N); elsif RM_Size (U_Ent) > Size then Error_Msg_Uint_1 := RM_Size (U_Ent); Error_Msg_N - ("stream size for elementary type must be a power of 2 " - & "and at least ^", N); + ("stream size for elementary type must be 8, 16, 24, " & + "32 or 64 and at least ^", N); end if; Set_Has_Stream_Size_Clause (U_Ent); -- 2.30.2