From 4199e8c6fbc5ac6de95d50181c0b6083d0b6f0ad Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 6 Jan 2015 09:35:30 +0000 Subject: [PATCH] exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry for Enum_Image. 2015-01-06 Robert Dewar * exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry for Enum_Image. * sem_attr.adb: Implement Enum_Image attribute. * snames.ads-tmpl: Add entries for Enum_Image attribute. From-SVN: r219236 --- gcc/ada/ChangeLog | 7 ++++ gcc/ada/exp_attr.adb | 5 ++- gcc/ada/sem_attr.adb | 82 ++++++++++++++++++++++++++++++++--------- gcc/ada/snames.ads-tmpl | 2 + 4 files changed, 76 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a64555ef5f9..16bb768e971 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2015-01-06 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry + for Enum_Image. + * sem_attr.adb: Implement Enum_Image attribute. + * snames.ads-tmpl: Add entries for Enum_Image attribute. + 2015-01-06 Robert Dewar * namet.ads: Document use of Boolean2 for No_Use_Of_Entity. diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 663507aa20e..5a66e3f55a2 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -3497,9 +3497,9 @@ package body Exp_Attr is begin Rewrite (N, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Image, - Expressions => New_List (Relocate_Node (Pref)))); + Expressions => New_List (Relocate_Node (Pref)))); Analyze_And_Resolve (N, Standard_String); end Img; @@ -7178,6 +7178,7 @@ package body Exp_Attr is Attribute_Digits | Attribute_Emax | Attribute_Enabled | + Attribute_Enum_Image | Attribute_Epsilon | Attribute_Fast_Math | Attribute_First_Valid | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 7ff79395be5..1fcda36b0b7 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -288,13 +288,13 @@ package body Sem_Attr is -- Check that two attribute arguments are present procedure Check_Enum_Image; - -- If the prefix type is an enumeration type, set all its literals - -- as referenced, since the image function could possibly end up - -- referencing any of the literals indirectly. Same for Enum_Val. + -- If the prefix type of 'Image is an enumeration type, set all its + -- literals as referenced, since the image function could possibly end + -- up referencing any of the literals indirectly. Same for Enum_Val. -- Set the flag only if the reference is in the main code unit. Same -- restriction when resolving 'Value; otherwise an improperly set - -- reference when analyzing an inlined body will lose a proper warning - -- on a useless with_clause. + -- reference when analyzing an inlined body will lose a proper + -- warning on a useless with_clause. procedure Check_First_Last_Valid; -- Perform all checks for First_Valid and Last_Valid attributes @@ -2455,7 +2455,7 @@ package body Sem_Attr is then Error_Msg_N ("in a constraint the current instance can only" - & " be used with an access attribute", N); + & " be used with an access attribute", N); end if; end if; end; @@ -3378,6 +3378,31 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); + ---------------- + -- Enum_Image -- + ---------------- + + when Attribute_Enum_Image => Enum_Image : + begin + Check_SPARK_05_Restriction_On_Attribute; + Check_Scalar_Type; + Set_Etype (N, Standard_String); + + if not Is_Enumeration_Type (P_Type) then + Error_Msg_Name_1 := Aname; + Error_Msg_N + ("% attribute only allowed for enumerated types", N); + end if; + + Check_E1; + Resolve (E1, P_Base_Type); + + if not Is_OK_Static_Expression (E1) then + Error_Msg_Name_1 := Aname; + Error_Msg_N ("% attribute requires static argument", E1); + end if; + end Enum_Image; + -------------- -- Enum_Rep -- -------------- @@ -7714,21 +7739,21 @@ package body Sem_Attr is case Id is - -- Attributes related to Ada 2012 iterators (placeholder ???) + -- Attributes related to Ada 2012 iterators (placeholder ???) - when Attribute_Constant_Indexing | - Attribute_Default_Iterator | - Attribute_Implicit_Dereference | - Attribute_Iterator_Element | - Attribute_Iterable | - Attribute_Variable_Indexing => null; + when Attribute_Constant_Indexing | + Attribute_Default_Iterator | + Attribute_Implicit_Dereference | + Attribute_Iterator_Element | + Attribute_Iterable | + Attribute_Variable_Indexing => null; - -- Internal attributes used to deal with Ada 2012 delayed aspects. - -- These were already rejected by the parser. Thus they shouldn't - -- appear here. + -- Internal attributes used to deal with Ada 2012 delayed aspects. + -- These were already rejected by the parser. Thus they shouldn't + -- appear here. - when Internal_Attribute_Id => - raise Program_Error; + when Internal_Attribute_Id => + raise Program_Error; -------------- -- Adjacent -- @@ -7910,6 +7935,27 @@ package body Sem_Attr is Fold_Uint (N, 4 * Mantissa, Static); + ---------------- + -- Enum_Image -- + ---------------- + + -- Enum_Image is always static and always has a string literal result + + when Attribute_Enum_Image => + declare + Lit : constant Entity_Id := Entity (E1); + Str : String_Id; + begin + Start_String; + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + Set_Casing (All_Upper_Case); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + Str := End_String; + Rewrite (N, Make_String_Literal (Loc, Strval => Str)); + Analyze_And_Resolve (N, Standard_String); + Set_Is_Static_Expression (N, True); + end; + -------------- -- Enum_Rep -- -------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 673a7530cd2..73b1e366d7e 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -962,6 +962,7 @@ package Snames is Name_Adjacent : constant Name_Id := N + $; Name_Ceiling : constant Name_Id := N + $; Name_Copy_Sign : constant Name_Id := N + $; + Name_Enum_Image : constant Name_Id := N + $; Name_Floor : constant Name_Id := N + $; Name_Fraction : constant Name_Id := N + $; Name_From_Any : constant Name_Id := N + $; -- GNAT @@ -1589,6 +1590,7 @@ package Snames is Attribute_Adjacent, Attribute_Ceiling, Attribute_Copy_Sign, + Attribute_Enum_Image, Attribute_Floor, Attribute_Fraction, Attribute_From_Any, -- 2.30.2