From 336438b6d225c3a5f28d57fd766e36f53faf8f3e Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Wed, 31 Mar 2021 08:00:59 -0400 Subject: [Ada] Implement 'Valid_Value attribute gcc/ada/ * libgnat/s-valuen.ads, libgnat/s-valuen.adb (Value_Enumeration_Pos): New function to compute the 'Pos of the enumeration literal for a given String. Return a special value instead of raising an exception on invalid input. Called by both Valid_Enumeration_Image and Value_Enumeration. (Valid_Enumeration_Image): Return a Boolean indicating whether the String is a valid Image for the given enumeration type. (Value_Enumeration): Implement in terms of Value_Enumeration_Pos. * libgnat/s-vaenu8.ads, libgnat/s-vaen16.ads, libgnat/s-vaen32.ads: Rename Valid_Enumeration_Image from the instances. * libgnat/s-valuti.ads: Correct documentation (it was not true for the null string). * libgnat/s-valuti.adb (Normalize_String): Do not raise Constraint_Error for the null string, nor strings containing nothing but blanks, so that Valid_Enumeration_Image can return False in these cases, rather than raising an exception. * rtsfind.ads (RE_Value_Enumeration_8, RE_Value_Enumeration_16, RE_Value_Enumeration_32): New functions. (RTE_Available): Improve comment (E doesn't have to be a subprogram, although that's the usual case). * sem_attr.adb (nalid_Value): Semantic analysis for new attribute. * exp_attr.adb: Call Expand_Valid_Value_Attribute for new attribute. * exp_imgv.ads, exp_imgv.adb (Expand_Valid_Value_Attribute): New procedure to expand Valid_Value into a call to Valid_Enumeration_Image_NN. (Expand_Value_Attribute): Misc code cleanups. Remove two ??? mark comments. RTE_Available won't work here. For one thing, RTE_Available (X) shouldn't be called until the compiler has decided to make use of X (see comments on RTE_Available), and in this case we're trying to AVOID calling something. * snames.ads-tmpl: New attribute name. * doc/gnat_rm/implementation_defined_attributes.rst: Document new attribute. * gnat_rm.texi: Regenerate. --- gcc/ada/libgnat/s-vaen16.ads | 11 ++++- gcc/ada/libgnat/s-vaen32.ads | 9 ++++ gcc/ada/libgnat/s-vaenu8.ads | 11 ++++- gcc/ada/libgnat/s-valuen.adb | 98 +++++++++++++++++++++++++++++++------------- gcc/ada/libgnat/s-valuen.ads | 24 +++++++++++ gcc/ada/libgnat/s-valuti.adb | 4 +- gcc/ada/libgnat/s-valuti.ads | 4 +- 7 files changed, 126 insertions(+), 35 deletions(-) (limited to 'gcc/ada/libgnat') diff --git a/gcc/ada/libgnat/s-vaen16.ads b/gcc/ada/libgnat/s-vaen16.ads index f119778..86cdaa1 100644 --- a/gcc/ada/libgnat/s-vaen16.ads +++ b/gcc/ada/libgnat/s-vaen16.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ -- Instantiation of System.Value_N for enumeration types whose names table --- has a length that fits in a 16-bit but not a 8-bit integer. +-- has a length that fits in a 16-bit but not an 8-bit integer. with Interfaces; with System.Value_N; @@ -49,4 +49,13 @@ package System.Val_Enum_16 is return Natural renames Impl.Value_Enumeration; + function Valid_Enumeration_Value_16 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Boolean + renames Impl.Valid_Enumeration_Value; + end System.Val_Enum_16; diff --git a/gcc/ada/libgnat/s-vaen32.ads b/gcc/ada/libgnat/s-vaen32.ads index ba24af3..0dead07 100644 --- a/gcc/ada/libgnat/s-vaen32.ads +++ b/gcc/ada/libgnat/s-vaen32.ads @@ -49,4 +49,13 @@ package System.Val_Enum_32 is return Natural renames Impl.Value_Enumeration; + function Valid_Enumeration_Value_32 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Boolean + renames Impl.Valid_Enumeration_Value; + end System.Val_Enum_32; diff --git a/gcc/ada/libgnat/s-vaenu8.ads b/gcc/ada/libgnat/s-vaenu8.ads index 4de9b0e..db0b360 100644 --- a/gcc/ada/libgnat/s-vaenu8.ads +++ b/gcc/ada/libgnat/s-vaenu8.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ -- Instantiation of System.Value_N for enumeration types whose names table --- has a length that fits in a 8-bit integer. +-- has a length that fits in an 8-bit integer. with Interfaces; with System.Value_N; @@ -49,4 +49,13 @@ package System.Val_Enum_8 is return Natural renames Impl.Value_Enumeration; + function Valid_Enumeration_Value_8 + (Names : String; + Indexes : System.Address; + Hash : Impl.Hash_Function_Ptr; + Num : Natural; + Str : String) + return Boolean + renames Impl.Valid_Enumeration_Value; + end System.Val_Enum_8; diff --git a/gcc/ada/libgnat/s-valuen.adb b/gcc/ada/libgnat/s-valuen.adb index 08d1a738..7b72bc6 100644 --- a/gcc/ada/libgnat/s-valuen.adb +++ b/gcc/ada/libgnat/s-valuen.adb @@ -35,22 +35,21 @@ with System.Val_Util; use System.Val_Util; package body System.Value_N is - ----------------------- - -- Value_Enumeration -- - ----------------------- + --------------------------- + -- Value_Enumeration_Pos -- + --------------------------- - function Value_Enumeration + function Value_Enumeration_Pos (Names : String; Indexes : System.Address; Hash : Hash_Function_Ptr; Num : Natural; Str : String) - return Natural + return Integer is - F : Natural; - L : Natural; - H : Natural; - S : String (Str'Range) := Str; + F, L : Integer; + H : Natural; + S : String (Str'Range) := Str; subtype Names_Index is Index_Type range Index_Type (Names'First) @@ -69,32 +68,75 @@ package body System.Value_N is begin Normalize_String (S, F, L); - -- If we have a valid hash value, do a single lookup + declare + Normal : String renames S (F .. L); - H := (if Hash /= null then Hash.all (S (F .. L)) else Natural'Last); + begin + -- If we have a valid hash value, do a single lookup - if H /= Natural'Last then - if Names - (Natural (IndexesT (H)) .. - Natural (IndexesT (H + 1)) - 1) = S (F .. L) - then - return H; - end if; - - -- Otherwise do a linear search + H := (if Hash /= null then Hash.all (Normal) else Natural'Last); - else - for J in 0 .. Num loop + if H /= Natural'Last then if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) + (Natural (IndexesT (H)) .. + Natural (IndexesT (H + 1)) - 1) = Normal then - return J; + return H; end if; - end loop; - end if; - Bad_Value (Str); + -- Otherwise do a linear search + + else + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = Normal + then + return J; + end if; + end loop; + end if; + end; + + return Invalid; + end Value_Enumeration_Pos; + + ----------------------- + -- Value_Enumeration -- + ----------------------- + + function Value_Enumeration + (Names : String; + Indexes : System.Address; + Hash : Hash_Function_Ptr; + Num : Natural; + Str : String) + return Natural + is + Result : constant Integer := + Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str); + begin + if Result = Invalid then + Bad_Value (Str); + else + return Result; + end if; end Value_Enumeration; + ----------------------------- + -- Valid_Enumeration_Value -- + ----------------------------- + + function Valid_Enumeration_Value + (Names : String; + Indexes : System.Address; + Hash : Hash_Function_Ptr; + Num : Natural; + Str : String) + return Boolean + is + begin + return Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str) /= Invalid; + end Valid_Enumeration_Value; + end System.Value_N; diff --git a/gcc/ada/libgnat/s-valuen.ads b/gcc/ada/libgnat/s-valuen.ads index dafa451..258d279 100644 --- a/gcc/ada/libgnat/s-valuen.ads +++ b/gcc/ada/libgnat/s-valuen.ads @@ -67,4 +67,28 @@ package System.Value_N is -- If the image is found in Names, then the corresponding Pos value is -- returned. If not, Constraint_Error is raised. + function Valid_Enumeration_Value + (Names : String; + Indexes : System.Address; + Hash : Hash_Function_Ptr; + Num : Natural; + Str : String) + return Boolean; + -- Returns True if Str is a valid Image of some enumeration literal, False + -- otherwise. That is, returns False if and only if Value_Enumeration would + -- raise Constraint_Error. The parameters have the same meaning as for + -- Value_Enumeration. + + Invalid : constant Integer := -1; + + function Value_Enumeration_Pos + (Names : String; + Indexes : System.Address; + Hash : Hash_Function_Ptr; + Num : Natural; + Str : String) + return Integer; + -- Same as Value_Enumeration, except returns Invalid if Value_Enumeration + -- would raise Constraint_Error. + end System.Value_N; diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb index 1ad758b..31edc40 100644 --- a/gcc/ada/libgnat/s-valuti.adb +++ b/gcc/ada/libgnat/s-valuti.adb @@ -68,10 +68,10 @@ package body System.Val_Util is F := F + 1; end loop; - -- Check for case when the string contained no characters + -- Case of no nonspace characters found if F > L then - Bad_Value (S); + return; end if; -- Scan for trailing spaces diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads index 07b2c77..3d426d9 100644 --- a/gcc/ada/libgnat/s-valuti.ads +++ b/gcc/ada/libgnat/s-valuti.ads @@ -45,9 +45,7 @@ package System.Val_Util is -- non-blank character of S and L to be the index of the last non-blank -- character of S. Any lower case characters present in S will be folded to -- their upper case equivalent except for character literals. If S consists - -- of entirely blanks then Constraint_Error is raised. - -- - -- Note: if S is the null string, F is set to S'First, L to S'Last + -- of entirely blanks (including when S = "") then we return with F > L. procedure Scan_Sign (Str : String; -- cgit v1.1