@@ -273,6 +273,10 @@ package body Exp_Attr is
-- expansion. Typically used for rounding and truncation attributes that
-- appear directly inside a conversion to integer.
+ function Is_User_Defined_Enumeration_Type (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ is a user-defined enumeration type, in the sense
+ -- that its literals are declared in the source.
+
function Interunit_Ref_OK
(Subp_Unit, Attr_Ref_Unit : Node_Id) return Boolean is
(In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit)
@@ -8107,7 +8111,10 @@ package body Exp_Attr is
Expressions => New_List (
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
+ New_Occurrence_Of
+ (RTE (if Is_User_Defined_Enumeration_Type (Typ)
+ then RE_Enum_Wide_String_To_String
+ else RE_Wide_String_To_String), Loc),
Parameter_Associations => New_List (
Relocate_Node (First (Exprs)),
@@ -8139,7 +8146,9 @@ package body Exp_Attr is
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
- (RTE (RE_Wide_Wide_String_To_String), Loc),
+ (RTE (if Is_User_Defined_Enumeration_Type (Typ)
+ then RE_Enum_Wide_Wide_String_To_String
+ else RE_Wide_Wide_String_To_String), Loc),
Parameter_Associations => New_List (
Relocate_Node (First (Exprs)),
@@ -9458,4 +9467,20 @@ package body Exp_Attr is
or else Id = Attribute_Truncation;
end Is_Inline_Floating_Point_Attribute;
+ --------------------------------------
+ -- Is_User_Defined_Enumeration_Type --
+ --------------------------------------
+
+ function Is_User_Defined_Enumeration_Type (Typ : Entity_Id) return Boolean
+ is
+ Rtyp : constant Entity_Id := Root_Type (Base_Type (Typ));
+
+ begin
+ return Is_Enumeration_Type (Rtyp)
+ and then Rtyp not in Standard_Boolean
+ | Standard_Character
+ | Standard_Wide_Character
+ | Standard_Wide_Wide_Character;
+ end Is_User_Defined_Enumeration_Type;
+
end Exp_Attr;
@@ -1744,9 +1744,9 @@ package body Exp_Imgv is
E : constant Entity_Id := Entity (Name (First (Args)));
begin
- Is_Wide := Is_RTE (E, RE_Wide_String_To_String)
+ Is_Wide := Is_RTE (E, RE_Enum_Wide_String_To_String)
or else
- Is_RTE (E, RE_Wide_Wide_String_To_String);
+ Is_RTE (E, RE_Enum_Wide_Wide_String_To_String);
end;
else
@@ -29,8 +29,9 @@
-- --
------------------------------------------------------------------------------
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_Cnv; use System.WCh_Cnv;
+with System.Case_Util; use System.Case_Util;
+with System.WCh_Con; use System.WCh_Con;
+with System.WCh_Cnv; use System.WCh_Cnv;
package body System.WCh_WtS is
@@ -38,6 +39,14 @@ package body System.WCh_WtS is
-- Local Subprograms --
-----------------------
+ procedure Normalize_String
+ (S : in out String;
+ EM : WC_Encoding_Method);
+ -- If S does not represent a character literal, then any lower case
+ -- characters in S are changed to their upper case counterparts, while
+ -- wide characters are unchanged. EM indicates their encoding method.
+ -- This is the wide counterpart of System.Val_Util.Normalize_String.
+
procedure Store_UTF_32_Character
(U : UTF_32_Code;
S : out String;
@@ -48,6 +57,113 @@ package body System.WCh_WtS is
-- point to the last character stored. Raises CE if character cannot be
-- stored using the given encoding method.
+ ----------------------
+ -- Normalize_String --
+ ----------------------
+
+ procedure Normalize_String
+ (S : in out String;
+ EM : WC_Encoding_Method)
+ is
+ procedure Skip_Wide (S : String; P : in out Natural);
+ -- On entry S (P) points to an ESC character for a wide character escape
+ -- sequence or an upper half character if the encoding method uses the
+ -- upper bit, or a left bracket if the brackets encoding method is in
+ -- use. On exit, P is bumped past the wide character sequence.
+
+ ---------------
+ -- Skip_Wide --
+ ---------------
+
+ procedure Skip_Wide (S : String; P : in out Natural) is
+ function Skip_Char return Character;
+ -- Function to skip one character of wide character escape sequence
+
+ ---------------
+ -- Skip_Char --
+ ---------------
+
+ function Skip_Char return Character is
+ begin
+ P := P + 1;
+ return S (P - 1);
+ end Skip_Char;
+
+ function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char);
+
+ Discard : UTF_32_Code;
+ pragma Warnings (Off, Discard);
+
+ -- Start of processing for Skip_Wide
+
+ begin
+ -- Capture invalid wide characters errors since we are going to
+ -- discard the result anyway. We just want to move past it.
+
+ begin
+ Discard := WC_Skip (Skip_Char, EM);
+ exception
+ when Constraint_Error =>
+ null;
+ end;
+ end Skip_Wide;
+
+ F, L, Ptr : Natural;
+
+ begin
+ F := S'First;
+ L := S'Last;
+
+ -- Case of empty string
+
+ if F > L then
+ return;
+ end if;
+
+ -- Scan for leading spaces
+
+ while F < L and then S (F) = ' ' loop
+ F := F + 1;
+ end loop;
+
+ -- Case of no nonspace characters found. Decrease L to ensure L < F
+ -- without risking an overflow if F is Integer'Last.
+
+ if S (F) = ' ' then
+ L := L - 1;
+ return;
+ end if;
+
+ -- Scan for trailing spaces
+
+ while S (L) = ' ' loop
+ L := L - 1;
+ end loop;
+
+ -- Convert to upper case if S is not a character literal
+
+ if S (F) /= ''' then
+ Ptr := F;
+
+ while Ptr <= L loop
+ -- This mimics the handling of wide characters in a call to
+ -- Casing.Set_Casing (All_Upper_Case) in the compiler.
+
+ if S (Ptr) = ASCII.ESC
+ or else S (Ptr) = '['
+ or else (EM in WC_Upper_Half_Encoding_Method
+ and then Character'Pos (S (Ptr)) >= 16#80#)
+ then
+ Skip_Wide (S, Ptr);
+
+ else
+ S (Ptr) := To_Upper (S (Ptr));
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+ end if;
+ end Normalize_String;
+
----------------------------
-- Store_UTF_32_Character --
----------------------------
@@ -78,6 +194,36 @@ package body System.WCh_WtS is
Store_Chars (U, EM);
end Store_UTF_32_Character;
+ --------------------------------
+ -- Enum_Wide_String_To_String --
+ --------------------------------
+
+ function Enum_Wide_String_To_String
+ (S : Wide_String;
+ EM : WC_Encoding_Method) return String
+ is
+ Result : String := Wide_String_To_String (S, EM);
+
+ begin
+ Normalize_String (Result, EM);
+ return Result;
+ end Enum_Wide_String_To_String;
+
+ -------------------------------------
+ -- Enum_Wide_Wide_String_To_String --
+ -------------------------------------
+
+ function Enum_Wide_Wide_String_To_String
+ (S : Wide_Wide_String;
+ EM : WC_Encoding_Method) return String
+ is
+ Result : String := Wide_Wide_String_To_String (S, EM);
+
+ begin
+ Normalize_String (Result, EM);
+ return Result;
+ end Enum_Wide_Wide_String_To_String;
+
---------------------------
-- Wide_String_To_String --
---------------------------
@@ -55,9 +55,21 @@ package System.WCh_WtS is
-- for characters greater than 16#FF#. The lowest index of the returned
-- String is equal to S'First.
+ function Enum_Wide_String_To_String
+ (S : Wide_String;
+ EM : System.WCh_Con.WC_Encoding_Method) return String;
+ -- Same processing, except that the string is normalized to be usable
+ -- with the Wide_Value attribute of user-defined enumeration types.
+
function Wide_Wide_String_To_String
(S : Wide_Wide_String;
EM : System.WCh_Con.WC_Encoding_Method) return String;
-- Same processing, except for Wide_Wide_String
+ function Enum_Wide_Wide_String_To_String
+ (S : Wide_Wide_String;
+ EM : System.WCh_Con.WC_Encoding_Method) return String;
+ -- Same processing, except that the string is normalized to be usable
+ -- with the Wide_Wide_Value attribute of user-defined enumeration types.
+
end System.WCh_WtS;
@@ -2044,6 +2044,8 @@ package Rtsfind is
RE_String_To_Wide_String, -- System.WCh_StW
RE_String_To_Wide_Wide_String, -- System.WCh_StW
+ RE_Enum_Wide_String_To_String, -- System.WCh_WtS
+ RE_Enum_Wide_Wide_String_To_String, -- System.WCh_WtS
RE_Wide_String_To_String, -- System.WCh_WtS
RE_Wide_Wide_String_To_String, -- System.WCh_WtS
@@ -3701,6 +3703,8 @@ package Rtsfind is
RE_String_To_Wide_String => System_WCh_StW,
RE_String_To_Wide_Wide_String => System_WCh_StW,
+ RE_Enum_Wide_String_To_String => System_WCh_WtS,
+ RE_Enum_Wide_Wide_String_To_String => System_WCh_WtS,
RE_Wide_String_To_String => System_WCh_WtS,
RE_Wide_Wide_String_To_String => System_WCh_WtS,