[Ada] Implement new attribute Library_Level
Arnaud Charlet
charlet@adacore.com
Mon Oct 14 12:52:00 GMT 2013
This implements a new attribute Standard'Library_Level (Standard is
the only allowed prefix), which returns a Boolean value which is True
if the attribute is evaluated at the library level (e.g. with a package
declaration), and false if evaluated elsewhere (e.g. within a subprogram
body). In the case of generics, the value indicates the placement
of the instantiation, not the template, and indeed the use of this
attribute within a generic is the intended common application
as shown in this example:
1. generic
2. package LLTestP is
3. pragma Compile_Time_Warning
4. (not Standard'Library_Level,
5. "LLTest should be instantiated at library level");
6. end;
1. with LLTestP;
2. package LLTestP1 is
3. package P is new LLTestP;
4. P1L : constant Boolean := Standard'Library_Level;
5. end;
1. with LLTestP;
2. with LLTestP1; use LLTestP1;
3. with Text_IO; use Text_IO;
4. procedure LLTest is
5. package P1 is new LLTestP;
|
>>> warning: in instantiation at lltestp.ads:4
>>> warning: LLTest should be instantiated at library level
6. begin
7. Put_Line (Boolean'Image (Standard'Library_Level));
8. Put_Line (Boolean'Image (P1L));
9. end;
When run, LLTest outputs:
FALSE
TRUE
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-10-14 Robert Dewar <dewar@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Add error
entry for Library_Level attribute (which should not survive
to expansion)
* gnat_rm.texi: Document attribute Library_Level
* sem_attr.adb (Analyze_Attribute, case Library_Level): Implement
this new attribute (Set_Boolean_Result): Replaces Set_Result
(Check_Standard_Prefix): Document that Check_E0 is called
(Check_System_Prefix): New procedure
* snames.ads-tmpl: Add entry for Library_Level attribute
-------------- next part --------------
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 203527)
+++ gnat_rm.texi (working copy)
@@ -337,6 +337,7 @@
* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Large::
+* Attribute Library_Level::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
@@ -7842,6 +7843,7 @@
* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Large::
+* Attribute Library_Level::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
@@ -8341,6 +8343,31 @@
the Ada 83 reference manual for an exact description of the semantics of
this attribute.
+@node Attribute Library_Level
+@unnumberedsec Attribute Library_Level
+@findex Library_Level
+@noindent
+@noindent
+@code{Standard'Library_Level} (@code{Standard} is the only allowed
+prefix) returns a Boolean value which is True if the attribute is
+evaluated at the library level (e.g. with a package declaration),
+and false if evaluated elsewhere (e.g. within a subprogram body).
+In the case of generics, the value indicates the placement of
+the instantiation, not the template, and indeed the use of this
+attribute within a generic is the intended common application
+as shown in this example:
+
+@smallexample @c ada
+generic
+ ...
+package Gen is
+ pragma Compile_Time_Error
+ (not Standard'Library_Level,
+ "Gen can only be instantiated at library level");
+ ...
+end Gen;
+@end smallexample
+
@node Attribute Loop_Entry
@unnumberedsec Attribute Loop_Entry
@findex Loop_Entry
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 203521)
+++ exp_attr.adb (working copy)
@@ -6485,6 +6485,7 @@
Attribute_Has_Tagged_Values |
Attribute_Large |
Attribute_Last_Valid |
+ Attribute_Library_Level |
Attribute_Lock_Free |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 203521)
+++ sem_attr.adb (working copy)
@@ -189,6 +189,11 @@
-- where therefore the prefix of the attribute does not match the enclosing
-- scope.
+ procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
+ -- Rewrites node N with an occurrence of either Standard_False or
+ -- Standard_True, depending on the value of the parameter B. The
+ -- result is marked as a static expression.
+
-----------------------
-- Analyze_Attribute --
-----------------------
@@ -339,13 +344,17 @@
-- Verify that prefix of attribute N is a scalar type
procedure Check_Standard_Prefix;
- -- Verify that prefix of attribute N is package Standard
+ -- Verify that prefix of attribute N is package Standard. Also checks
+ -- that there are no arguments.
procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
-- Validity checking for stream attribute. Nam is the TSS name of the
-- corresponding possible defined attribute function (e.g. for the
-- Read attribute, Nam will be TSS_Stream_Read).
+ procedure Check_System_Prefix;
+ -- Verify that prefix of attribute N is package System
+
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
@@ -1972,6 +1981,17 @@
Check_Not_CPP_Type;
end Check_Stream_Attribute;
+ -------------------------
+ -- Check_System_Prefix --
+ -------------------------
+
+ procedure Check_System_Prefix is
+ begin
+ if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
+ Error_Attr ("only allowed prefix for % attribute is System", P);
+ end if;
+ end Check_System_Prefix;
+
-----------------------
-- Check_Task_Prefix --
-----------------------
@@ -3663,6 +3683,21 @@
Check_Array_Type;
Set_Etype (N, Universal_Integer);
+ -------------------
+ -- Library_Level --
+ -------------------
+
+ when Attribute_Library_Level =>
+ Check_E0;
+ Check_Standard_Prefix;
+
+ if not Inside_A_Generic then
+ Set_Boolean_Result (N,
+ Nearest_Dynamic_Scope (Current_Scope) = Standard_Standard);
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
---------------
-- Lock_Free --
---------------
@@ -4965,36 +5000,11 @@
U : Node_Id;
Unam : Unit_Name_Type;
- procedure Set_Result (B : Boolean);
- -- Replace restriction node by static constant False or True,
- -- depending on the value of B.
-
- ----------------
- -- Set_Result --
- ----------------
-
- procedure Set_Result (B : Boolean) is
- begin
- if B then
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
- else
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
- end if;
-
- Set_Is_Static_Expression (N);
- end Set_Result;
-
- -- Start of processing for Restriction_Set
-
begin
Check_E1;
Analyze (P);
+ Check_System_Prefix;
- if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
- Set_Result (False);
- Error_Attr_P ("prefix of % attribute must be System");
- end if;
-
-- No_Dependence case
if Nkind (E1) = N_Parameter_Association then
@@ -5002,7 +5012,7 @@
U := Explicit_Actual_Parameter (E1);
if not OK_No_Dependence_Unit_Name (U) then
- Set_Result (False);
+ Set_Boolean_Result (N, False);
Error_Attr;
end if;
@@ -5013,14 +5023,14 @@
if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
and then No_Dependences.Table (J).Warn = False
then
- Set_Result (True);
+ Set_Boolean_Result (N, True);
return;
end if;
end loop;
-- If not in the No_Dependence table, result is False
- Set_Result (False);
+ Set_Boolean_Result (N, False);
-- In this case, we must ensure that the binder will reject any
-- other unit in the partition that sets No_Dependence for this
@@ -5043,29 +5053,29 @@
else
if Nkind (E1) /= N_Identifier then
- Set_Result (False);
+ Set_Boolean_Result (N, False);
Error_Attr ("attribute % requires restriction identifier", E1);
else
R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
if R = Not_A_Restriction_Id then
- Set_Result (False);
+ Set_Boolean_Result (N, False);
Error_Msg_Node_1 := E1;
Error_Attr ("invalid restriction identifier &", E1);
elsif R not in Partition_Boolean_Restrictions then
- Set_Result (False);
+ Set_Boolean_Result (N, False);
Error_Msg_Node_1 := E1;
Error_Attr
("& is not a boolean partition-wide restriction", E1);
end if;
if Restriction_Active (R) then
- Set_Result (True);
+ Set_Boolean_Result (N, True);
else
Check_Restriction (R, N);
- Set_Result (False);
+ Set_Boolean_Result (N, False);
end if;
end if;
end if;
@@ -5596,11 +5606,8 @@
begin
Check_E1;
Analyze (P);
+ Check_System_Prefix;
- if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
- Error_Attr_P ("prefix of % attribute must be System");
- end if;
-
Generate_Reference (RTE (RE_Address), P);
Analyze_And_Resolve (E1, Any_Integer);
Set_Etype (N, RTE (RE_Address));
@@ -6809,8 +6816,8 @@
return;
end if;
- -- Cases where P is not an object. Cannot do anything if P is
- -- not the name of an entity.
+ -- Cases where P is not an object. Cannot do anything if P is not the
+ -- name of an entity.
elsif not Is_Entity_Name (P) then
Check_Expressions;
@@ -6908,10 +6915,9 @@
-- We can fold 'Alignment applied to a type if the alignment is known
-- (as happens for an alignment from an attribute definition clause).
- -- At this stage, this can happen only for types (e.g. record
- -- types) for which the size is always non-static. We exclude
- -- generic types from consideration (since they have bogus
- -- sizes set within templates).
+ -- At this stage, this can happen only for types (e.g. record types) for
+ -- which the size is always non-static. We exclude generic types from
+ -- consideration (since they have bogus sizes set within templates).
elsif Id = Attribute_Alignment
and then Is_Type (P_Entity)
@@ -9118,6 +9124,7 @@
Attribute_First_Bit |
Attribute_Input |
Attribute_Last_Bit |
+ Attribute_Library_Level |
Attribute_Maximum_Alignment |
Attribute_Old |
Attribute_Output |
@@ -10421,6 +10428,23 @@
Eval_Attribute (N);
end Resolve_Attribute;
+ ------------------------
+ -- Set_Boolean_Result --
+ ------------------------
+
+ procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ if B then
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ end if;
+
+ Set_Is_Static_Expression (N);
+ end Set_Boolean_Result;
+
--------------------------------
-- Stream_Attribute_Available --
--------------------------------
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 203525)
+++ snames.ads-tmpl (working copy)
@@ -807,20 +807,15 @@
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
- -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT.
+ -- attributes are implemented in all Ada modes in GNAT.
-- The entries marked GNAT are attributes that are defined by GNAT and
- -- implemented in both Ada 83 and Ada 95 modes. Full descriptions of these
- -- implementation dependent attributes may be found in the appropriate
- -- section in Sem_Attr.
+ -- implemented in all Ada modes. Full descriptions of these implementation
+ -- dependent attributes may be found in the appropriate Sem_Attr section.
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
- -- The entries marked HiLite are attributes that are defined by Hi-Lite
- -- and implemented in GNAT operating under formal verification mode. The
- -- entries are treated as illegal in all other contexts.
-
First_Attribute_Name : constant Name_Id := N + $;
Name_Abort_Signal : constant Name_Id := N + $; -- GNAT
Name_Access : constant Name_Id := N + $;
@@ -881,8 +876,9 @@
Name_Last_Valid : constant Name_Id := N + $; -- Ada 12
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
+ Name_Library_Level : constant Name_Id := N + $; -- GNAT
Name_Lock_Free : constant Name_Id := N + $; -- GNAT
- Name_Loop_Entry : constant Name_Id := N + $; -- HiLite
+ Name_Loop_Entry : constant Name_Id := N + $; -- GNAT
Name_Machine_Emax : constant Name_Id := N + $;
Name_Machine_Emin : constant Name_Id := N + $;
Name_Machine_Mantissa : constant Name_Id := N + $;
@@ -1498,6 +1494,7 @@
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
+ Attribute_Library_Level,
Attribute_Lock_Free,
Attribute_Loop_Entry,
Attribute_Machine_Emax,
More information about the Gcc-patches
mailing list