https://gcc.gnu.org/g:c4d9a73e12b25a9f0ac152df2da5ceac80bd9d6a
commit r15-4163-gc4d9a73e12b25a9f0ac152df2da5ceac80bd9d6a
Author: Eric Botcazou <ebotca...@adacore.com>
Date: Thu Sep 12 12:45:27 2024 +0200
ada: Fix bogus Constraint_Error for 'Wide_Wide_Value on wide enumeration
literal
The problem is that 'Wide_Wide_Value is piggybacked on 'Value and the latter
invokes System.Val_Util.Normalize_String, which incorrectly normalizes the
input string in the presence of enumeration literals with wide characters.
gcc/ada/ChangeLog:
PR ada/115507
* exp_imgv.adb (Expand_Valid_Value_Attribute): Add actual parameter
for Is_Wide formal in the call to Valid_Value_Enumeration_NN.
(Expand_Value_Attribute): Likewise.
* libgnat/s-vaen16.ads (Value_Enumeration_16): Add Is_Wide formal.
(Valid_Value_Enumeration_16): Likewise.
* libgnat/s-vaen32.ads (Value_Enumeration_32): Likewise.
(Valid_Value_Enumeration_32): Likewise.
* libgnat/s-vaenu8.ads (Value_Enumeration_8): Likewise.
(Valid_Value_Enumeration_8): Likewise.
* libgnat/s-valboo.adb (Value_Boolean): Pass True for To_Upper_Case
formal parameter in call to Normalize_String.
* libgnat/s-valcha.adb (Value_Character): Likewise.
* libgnat/s-valuen.ads (Value_Enumeration): Add Is_Wide formal.
(Valid_Value_Enumeration): Likewise.
* libgnat/s-valuen.adb (Value_Enumeration_Pos): Likewise and pass
its negation for To_Upper_Case formal in call to Normalize_String.
(Valid_Value_Enumeration): Add Is_Wide formal and forward it in
call to Value_Enumeration_Pos.
(Value_Enumeration): Likewise.
* libgnat/s-valuti.ads (Normalize_String): Add To_Upper_Case formal
parameter and adjust post-condition accordingly.
* libgnat/s-valuti.adb (Normalize_String): Add To_Upper_Case formal
parameter and adjust implementation accordingly.
* libgnat/s-valwch.adb (Value_Wide_Wide_Character): Pass False for
To_Upper_Case formal parameter in call to Normalize_String.
Diff:
---
gcc/ada/exp_imgv.adb | 42 +++++++++++++++++++++++++++++++++---------
gcc/ada/libgnat/s-vaen16.ads | 2 ++
gcc/ada/libgnat/s-vaen32.ads | 2 ++
gcc/ada/libgnat/s-vaenu8.ads | 2 ++
gcc/ada/libgnat/s-valboo.adb | 2 +-
gcc/ada/libgnat/s-valcha.adb | 4 +++-
gcc/ada/libgnat/s-valuen.adb | 11 ++++++++---
gcc/ada/libgnat/s-valuen.ads | 5 ++++-
gcc/ada/libgnat/s-valuti.adb | 9 +++++----
gcc/ada/libgnat/s-valuti.ads | 14 ++++++++------
gcc/ada/libgnat/s-valwch.adb | 2 +-
11 files changed, 69 insertions(+), 26 deletions(-)
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index b350542fb712..ef2a3a3250fc 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -1431,11 +1431,11 @@ package body Exp_Imgv is
procedure Expand_Valid_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Args : constant List_Id := Expressions (N);
Btyp : constant Entity_Id := Base_Type (Entity (Prefix (N)));
Rtyp : constant Entity_Id := Root_Type (Btyp);
pragma Assert (Is_Enumeration_Type (Rtyp));
- Args : constant List_Id := Expressions (N);
Func : RE_Id;
Ttyp : Entity_Id;
@@ -1443,7 +1443,7 @@ package body Exp_Imgv is
-- Generate:
-- Valid_Value_Enumeration_NN
- -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X)
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
@@ -1455,6 +1455,10 @@ package body Exp_Imgv is
Func := RE_Valid_Value_Enumeration_32;
end if;
+ -- The Valid_[Wide_]Wide_Value attribute does not exist
+
+ Prepend_To (Args, New_Occurrence_Of (Standard_False, Loc));
+
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Rtyp, Loc),
@@ -1546,7 +1550,7 @@ package body Exp_Imgv is
-- Enum'Val
-- (Value_Enumeration_NN
- -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X))
-- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
-- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
@@ -1558,14 +1562,15 @@ package body Exp_Imgv is
procedure Expand_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Args : constant List_Id := Expressions (N);
Btyp : constant Entity_Id := Etype (N);
pragma Assert (Is_Base_Type (Btyp));
pragma Assert (Btyp = Base_Type (Entity (Prefix (N))));
Rtyp : constant Entity_Id := Root_Type (Btyp);
- Args : constant List_Id := Expressions (N);
- Ttyp : Entity_Id;
- Vid : RE_Id;
+ Is_Wide : Boolean;
+ Ttyp : Entity_Id;
+ Vid : RE_Id;
begin
-- Fall through for all cases except user-defined enumeration type
@@ -1717,9 +1722,9 @@ package body Exp_Imgv is
-- Normal case where we have enumeration tables, build
- -- T'Val
- -- (Value_Enumeration_NN
- -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
+ -- T'Val
+ -- (Value_Enumeration_NN
+ -- (typS, typN'Address, typH'Unrestricted_Access, Num, Is_Wide, X))
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
@@ -1732,6 +1737,25 @@ package body Exp_Imgv is
Vid := RE_Value_Enumeration_32;
end if;
+ if Nkind (First (Args)) = N_Function_Call
+ and then Is_Entity_Name (Name (First (Args)))
+ then
+ declare
+ E : constant Entity_Id := Entity (Name (First (Args)));
+
+ begin
+ Is_Wide := Is_RTE (E, RE_Wide_String_To_String)
+ or else
+ Is_RTE (E, RE_Wide_Wide_String_To_String);
+ end;
+
+ else
+ Is_Wide := False;
+ end if;
+
+ Prepend_To (Args,
+ New_Occurrence_Of (Boolean_Literals (Is_Wide), Loc));
+
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Rtyp, Loc),
diff --git a/gcc/ada/libgnat/s-vaen16.ads b/gcc/ada/libgnat/s-vaen16.ads
index 5ac8beb5a135..7cc98bef2dc5 100644
--- a/gcc/ada/libgnat/s-vaen16.ads
+++ b/gcc/ada/libgnat/s-vaen16.ads
@@ -45,6 +45,7 @@ package System.Val_Enum_16 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Natural
renames Impl.Value_Enumeration;
@@ -54,6 +55,7 @@ package System.Val_Enum_16 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Boolean
renames Impl.Valid_Value_Enumeration;
diff --git a/gcc/ada/libgnat/s-vaen32.ads b/gcc/ada/libgnat/s-vaen32.ads
index ee540f1f5aab..0900d18cebf9 100644
--- a/gcc/ada/libgnat/s-vaen32.ads
+++ b/gcc/ada/libgnat/s-vaen32.ads
@@ -45,6 +45,7 @@ package System.Val_Enum_32 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Natural
renames Impl.Value_Enumeration;
@@ -54,6 +55,7 @@ package System.Val_Enum_32 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Boolean
renames Impl.Valid_Value_Enumeration;
diff --git a/gcc/ada/libgnat/s-vaenu8.ads b/gcc/ada/libgnat/s-vaenu8.ads
index 6d34533a6c1b..62e9fa34df5e 100644
--- a/gcc/ada/libgnat/s-vaenu8.ads
+++ b/gcc/ada/libgnat/s-vaenu8.ads
@@ -45,6 +45,7 @@ package System.Val_Enum_8 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Natural
renames Impl.Value_Enumeration;
@@ -54,6 +55,7 @@ package System.Val_Enum_8 is
Indexes : System.Address;
Hash : Impl.Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Boolean
renames Impl.Valid_Value_Enumeration;
diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb
index 5cb3b98b8474..f7a13ba7327c 100644
--- a/gcc/ada/libgnat/s-valboo.adb
+++ b/gcc/ada/libgnat/s-valboo.adb
@@ -53,7 +53,7 @@ is
S : String (Str'Range) := Str;
begin
- Normalize_String (S, F, L);
+ Normalize_String (S, F, L, To_Upper_Case => True);
pragma Assert (F = System.Val_Spec.First_Non_Space_Ghost
(S, Str'First, Str'Last));
diff --git a/gcc/ada/libgnat/s-valcha.adb b/gcc/ada/libgnat/s-valcha.adb
index 46f3eb467530..13cbcb54013d 100644
--- a/gcc/ada/libgnat/s-valcha.adb
+++ b/gcc/ada/libgnat/s-valcha.adb
@@ -43,7 +43,9 @@ package body System.Val_Char is
S : String (Str'Range) := Str;
begin
- Normalize_String (S, F, L);
+ -- The names of control characters use upper case letters
+
+ Normalize_String (S, F, L, To_Upper_Case => True);
-- Accept any single character enclosed in quotes
diff --git a/gcc/ada/libgnat/s-valuen.adb b/gcc/ada/libgnat/s-valuen.adb
index caf4fc6e76ae..8fa4c266f572 100644
--- a/gcc/ada/libgnat/s-valuen.adb
+++ b/gcc/ada/libgnat/s-valuen.adb
@@ -40,6 +40,7 @@ package body System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Integer with Pure_Function;
-- Same as Value_Enumeration, except returns negative if Value_Enumeration
@@ -54,6 +55,7 @@ package body System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Integer
is
@@ -76,7 +78,7 @@ package body System.Value_N is
pragma Assert (Num + 1 in IndexesT'Range);
begin
- Normalize_String (S, F, L);
+ Normalize_String (S, F, L, To_Upper_Case => not Is_Wide);
declare
Normal : String renames S (F .. L);
@@ -120,11 +122,13 @@ package body System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Boolean
is
begin
- return Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str) >= 0;
+ return
+ Value_Enumeration_Pos (Names, Indexes, Hash, Num, Is_Wide, Str) >= 0;
end Valid_Value_Enumeration;
-----------------------
@@ -136,11 +140,12 @@ package body System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Natural
is
Result : constant Integer :=
- Value_Enumeration_Pos (Names, Indexes, Hash, Num, Str);
+ Value_Enumeration_Pos (Names, Indexes, Hash, Num, Is_Wide, Str);
begin
-- The comparison eliminates the need for a range check on return
diff --git a/gcc/ada/libgnat/s-valuen.ads b/gcc/ada/libgnat/s-valuen.ads
index 83ffd716f632..fe2babf3f3be 100644
--- a/gcc/ada/libgnat/s-valuen.ads
+++ b/gcc/ada/libgnat/s-valuen.ads
@@ -47,6 +47,7 @@ package System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Natural with Inline;
-- Used to compute Enum'Value (Str) where Enum is some enumeration type
@@ -60,7 +61,8 @@ package System.Value_N is
-- The parameter Hash is a (perfect) hash function for Names and Indexes.
-- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)).
-- The reason that Indexes is passed by address is that the actual type
- -- is created on the fly by the expander.
+ -- is created on the fly by the expander. The parameter Is_Wide is True
+ -- if the original attribute was [Wide_]Wide_Value.
--
-- Str is the argument of the attribute function, and may have leading
-- and trailing spaces, and letters can be upper or lower case or mixed.
@@ -72,6 +74,7 @@ package System.Value_N is
Indexes : System.Address;
Hash : Hash_Function_Ptr;
Num : Natural;
+ Is_Wide : Boolean;
Str : String)
return Boolean with Inline;
-- Returns True if Str is a valid Image of some enumeration literal, False
diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb
index 147a10ad66ea..50e7f6a79feb 100644
--- a/gcc/ada/libgnat/s-valuti.adb
+++ b/gcc/ada/libgnat/s-valuti.adb
@@ -67,8 +67,9 @@ is
----------------------
procedure Normalize_String
- (S : in out String;
- F, L : out Integer)
+ (S : in out String;
+ F, L : out Integer;
+ To_Upper_Case : Boolean)
is
begin
F := S'First;
@@ -106,9 +107,9 @@ is
L := L - 1;
end loop;
- -- Except in the case of a character literal, convert to upper case
+ -- Convert to upper case if requested and not a character literal
- if S (F) /= ''' then
+ if To_Upper_Case and then S (F) /= ''' then
for J in F .. L loop
S (J) := To_Upper (S (J));
pragma Loop_Invariant
diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads
index 70585477079d..cc804f4be550 100644
--- a/gcc/ada/libgnat/s-valuti.ads
+++ b/gcc/ada/libgnat/s-valuti.ads
@@ -60,8 +60,9 @@ is
-- Raises constraint error with message: bad input for 'Value: "xxx"
procedure Normalize_String
- (S : in out String;
- F, L : out Integer)
+ (S : in out String;
+ F, L : out Integer;
+ To_Upper_Case : Boolean)
with
Post => (if Sp.Only_Space_Ghost (S'Old, S'First, S'Last) then
F > L
@@ -76,7 +77,7 @@ is
(if L < S'Last then
Sp.Only_Space_Ghost (S'Old, L + 1, S'Last))
and then
- (if S'Old (F) /= ''' then
+ (if To_Upper_Case and then S'Old (F) /= ''' then
(for all J in S'Range =>
(if J in F .. L then
S (J) = System.Case_Util.To_Upper (S'Old (J))
@@ -84,9 +85,10 @@ is
S (J) = S'Old (J)))));
-- This procedure scans the string S setting F to be the index of the first
-- 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 (including when S = "") then we return with F > L.
+ -- character of S. If To_Upper_Case is True and S does not represent a
+ -- character literal, then any lower case characters in S are changed to
+ -- their upper case counterparts. If S consists of only blank characters
+ -- (including when S = "") then we return with F > L.
procedure Scan_Sign
(Str : String;
diff --git a/gcc/ada/libgnat/s-valwch.adb b/gcc/ada/libgnat/s-valwch.adb
index e452e311933c..4162bc1d8c73 100644
--- a/gcc/ada/libgnat/s-valwch.adb
+++ b/gcc/ada/libgnat/s-valwch.adb
@@ -67,7 +67,7 @@ package body System.Val_WChar is
S : String (Str'Range) := Str;
begin
- Normalize_String (S, F, L);
+ Normalize_String (S, F, L, To_Upper_Case => False);
-- Character literal case
