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 --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index b350542fb71270b794cc6cb77ab87de189c34741..ef2a3a3250fc6a9e76a0e530ca459e2e249739a9 100644 (file)
--- 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 5ac8beb5a135bfcf9f50116cc8edefeefc3b476b..7cc98bef2dc56c3e21b210b5422059651788d8f4 100644 (file)
--- 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 ee540f1f5aab5600c595354cea86cbae24f62d2e..0900d18cebf9797d4fcf5cf775a933f4d2239a32 100644 (file)
--- 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 6d34533a6c1bdabf851bbba57bdb6b86990a81f1..62e9fa34df5e355398c5227513c762bb2f1f5a02 100644 (file)
--- 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 5cb3b98b84749674f3d17312b6865adba73ba563..f7a13ba7327c83a1dd26159b39e6239c38ad46b2 100644 (file)
--- 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 46f3eb46753096e0312cfd48b0630ea3e0888a1d..13cbcb54013d3a6931cc91dec0fe342788c32663 100644 (file)
--- 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 caf4fc6e76ae1776e46d0c89a0457c08dff7144d..8fa4c266f572283cc505b5ee03de2cd64edcd20d 100644 (file)
--- 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 83ffd716f632ab4ec4e1d8d394dca47f44655230..fe2babf3f3be7c26922caf163dbe2f450c4ba900 100644 (file)
--- 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 147a10ad66ea5c4b419d38e4b8f56da1dbb2038f..50e7f6a79febedcae9252c43f6de5229ccac91a4 100644 (file)
--- 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 70585477079d5a004d8728cfc519c24ffa30ea65..cc804f4be5503f1ca323c97e6d0d9b244f57c01a 100644 (file)
--- 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 e452e311933cc20e0bcc8570c811b8e2698107e9..4162bc1d8c738efcb855c907fbbca346bd9f0392 100644 (file)
--- 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