diff options
| -rw-r--r-- | gcc/ada/exp_attr.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/exp_imgv.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-wchwts.adb | 150 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-wchwts.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 4 |
5 files changed, 193 insertions, 6 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 702c4bb..cb068c1 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index ef2a3a3..20afebc 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -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 diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb index db2fd6a..771e7dd 100644 --- a/gcc/ada/libgnat/s-wchwts.adb +++ b/gcc/ada/libgnat/s-wchwts.adb @@ -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 -- --------------------------- diff --git a/gcc/ada/libgnat/s-wchwts.ads b/gcc/ada/libgnat/s-wchwts.ads index 63ee804..549a0b6 100644 --- a/gcc/ada/libgnat/s-wchwts.ads +++ b/gcc/ada/libgnat/s-wchwts.ads @@ -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; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 8c0c904..942c2f7 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, |