* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Large::
+* Attribute Library_Level::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
* Attribute Integer_Value::
* Attribute Invalid_Value::
* Attribute Large::
+* Attribute Library_Level::
* Attribute Loop_Entry::
* Attribute Machine_Size::
* Attribute Mantissa::
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
-- 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 --
-----------------------
-- 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
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 --
-----------------------
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 --
---------------
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);
-
- 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;
+ Check_System_Prefix;
-- No_Dependence case
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;
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
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;
begin
Check_E1;
Analyze (P);
-
- if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
- Error_Attr_P ("prefix of % attribute must be System");
- end if;
+ Check_System_Prefix;
Generate_Reference (RTE (RE_Address), P);
Analyze_And_Resolve (E1, Any_Integer);
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;
-- 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)
Attribute_First_Bit |
Attribute_Input |
Attribute_Last_Bit |
+ Attribute_Library_Level |
Attribute_Maximum_Alignment |
Attribute_Old |
Attribute_Output |
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 --
--------------------------------
-- 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 + $;
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 + $;
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
+ Attribute_Library_Level,
Attribute_Lock_Free,
Attribute_Loop_Entry,
Attribute_Machine_Emax,
projects / thirdparty / gcc.git / commitdiff
