Commit 4199e8c6 by Robert Dewar Committed by Arnaud Charlet

exp_attr.adb (Expand_N_Attribute_Reference): Add dummy entry for Enum_Image.

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* 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
parent db761fee
2015-01-06 Robert Dewar <dewar@adacore.com> 2015-01-06 Robert Dewar <dewar@adacore.com>
* 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 <dewar@adacore.com>
* namet.ads: Document use of Boolean2 for No_Use_Of_Entity. * namet.ads: Document use of Boolean2 for No_Use_Of_Entity.
* restrict.ads (No_Use_Of_Entity): New table. * restrict.ads (No_Use_Of_Entity): New table.
* sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
......
...@@ -3497,9 +3497,9 @@ package body Exp_Attr is ...@@ -3497,9 +3497,9 @@ package body Exp_Attr is
begin begin
Rewrite (N, Rewrite (N,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc), Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Image, Attribute_Name => Name_Image,
Expressions => New_List (Relocate_Node (Pref)))); Expressions => New_List (Relocate_Node (Pref))));
Analyze_And_Resolve (N, Standard_String); Analyze_And_Resolve (N, Standard_String);
end Img; end Img;
...@@ -7178,6 +7178,7 @@ package body Exp_Attr is ...@@ -7178,6 +7178,7 @@ package body Exp_Attr is
Attribute_Digits | Attribute_Digits |
Attribute_Emax | Attribute_Emax |
Attribute_Enabled | Attribute_Enabled |
Attribute_Enum_Image |
Attribute_Epsilon | Attribute_Epsilon |
Attribute_Fast_Math | Attribute_Fast_Math |
Attribute_First_Valid | Attribute_First_Valid |
......
...@@ -288,13 +288,13 @@ package body Sem_Attr is ...@@ -288,13 +288,13 @@ package body Sem_Attr is
-- Check that two attribute arguments are present -- Check that two attribute arguments are present
procedure Check_Enum_Image; procedure Check_Enum_Image;
-- If the prefix type is an enumeration type, set all its literals -- If the prefix type of 'Image is an enumeration type, set all its
-- as referenced, since the image function could possibly end up -- literals as referenced, since the image function could possibly end
-- referencing any of the literals indirectly. Same for Enum_Val. -- 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 -- Set the flag only if the reference is in the main code unit. Same
-- restriction when resolving 'Value; otherwise an improperly set -- restriction when resolving 'Value; otherwise an improperly set
-- reference when analyzing an inlined body will lose a proper warning -- reference when analyzing an inlined body will lose a proper
-- on a useless with_clause. -- warning on a useless with_clause.
procedure Check_First_Last_Valid; procedure Check_First_Last_Valid;
-- Perform all checks for First_Valid and Last_Valid attributes -- Perform all checks for First_Valid and Last_Valid attributes
...@@ -2455,7 +2455,7 @@ package body Sem_Attr is ...@@ -2455,7 +2455,7 @@ package body Sem_Attr is
then then
Error_Msg_N Error_Msg_N
("in a constraint the current instance can only" ("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 if; end if;
end; end;
...@@ -3378,6 +3378,31 @@ package body Sem_Attr is ...@@ -3378,6 +3378,31 @@ package body Sem_Attr is
Set_Etype (N, Standard_Boolean); 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 -- -- Enum_Rep --
-------------- --------------
...@@ -7714,21 +7739,21 @@ package body Sem_Attr is ...@@ -7714,21 +7739,21 @@ package body Sem_Attr is
case Id is case Id is
-- Attributes related to Ada 2012 iterators (placeholder ???) -- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing | when Attribute_Constant_Indexing |
Attribute_Default_Iterator | Attribute_Default_Iterator |
Attribute_Implicit_Dereference | Attribute_Implicit_Dereference |
Attribute_Iterator_Element | Attribute_Iterator_Element |
Attribute_Iterable | Attribute_Iterable |
Attribute_Variable_Indexing => null; Attribute_Variable_Indexing => null;
-- Internal attributes used to deal with Ada 2012 delayed aspects. -- Internal attributes used to deal with Ada 2012 delayed aspects.
-- These were already rejected by the parser. Thus they shouldn't -- These were already rejected by the parser. Thus they shouldn't
-- appear here. -- appear here.
when Internal_Attribute_Id => when Internal_Attribute_Id =>
raise Program_Error; raise Program_Error;
-------------- --------------
-- Adjacent -- -- Adjacent --
...@@ -7910,6 +7935,27 @@ package body Sem_Attr is ...@@ -7910,6 +7935,27 @@ package body Sem_Attr is
Fold_Uint (N, 4 * Mantissa, Static); 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 -- -- Enum_Rep --
-------------- --------------
......
...@@ -962,6 +962,7 @@ package Snames is ...@@ -962,6 +962,7 @@ package Snames is
Name_Adjacent : constant Name_Id := N + $; Name_Adjacent : constant Name_Id := N + $;
Name_Ceiling : constant Name_Id := N + $; Name_Ceiling : constant Name_Id := N + $;
Name_Copy_Sign : 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_Floor : constant Name_Id := N + $;
Name_Fraction : constant Name_Id := N + $; Name_Fraction : constant Name_Id := N + $;
Name_From_Any : constant Name_Id := N + $; -- GNAT Name_From_Any : constant Name_Id := N + $; -- GNAT
...@@ -1589,6 +1590,7 @@ package Snames is ...@@ -1589,6 +1590,7 @@ package Snames is
Attribute_Adjacent, Attribute_Adjacent,
Attribute_Ceiling, Attribute_Ceiling,
Attribute_Copy_Sign, Attribute_Copy_Sign,
Attribute_Enum_Image,
Attribute_Floor, Attribute_Floor,
Attribute_Fraction, Attribute_Fraction,
Attribute_From_Any, Attribute_From_Any,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment