{
int cores = 1;
-#if defined (linux) || defined (sun) || defined (AIX) || \
- (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__)
- cores = (int)sysconf(_SC_NPROCESSORS_ONLN);
+#if defined (linux) || defined (sun) || defined (AIX) \
+ || (defined (__alpha__) && defined (_osf_)) || defined (__APPLE__)
+ cores = (int) sysconf (_SC_NPROCESSORS_ONLN);
#elif (defined (__mips) && defined (__sgi))
- cores = (int)sysconf(_SC_NPROC_ONLN);
+ cores = (int) sysconf (_SC_NPROC_ONLN);
#elif defined (__hpux__)
- struct pst_dynamic psd;
- if (pstat_getdynamic(&psd, sizeof(psd), 1, 0) != -1)
- cores = (int)psd.psd_proc_cnt;
+ struct pst_dynamic psd;
+ if (pstat_getdynamic (&psd, sizeof (psd), 1, 0) != -1)
+ cores = (int) psd.psd_proc_cnt;
#endif
return From_Union (Nodes.Table (N + 3).Field8);
end Ureal21;
+ function Flag3 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (N <= Nodes.Last);
+ return Nodes.Table (N).Flag3;
+ end Flag3;
+
function Flag4 (N : Node_Id) return Boolean is
begin
pragma Assert (N <= Nodes.Last);
function Flag20 (N : Node_Id) return Boolean is
begin
pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 1).Unused_1;
+ return Nodes.Table (N + 1).Flag3;
end Flag20;
function Flag21 (N : Node_Id) return Boolean is
function Flag41 (N : Node_Id) return Boolean is
begin
pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 2).Unused_1;
+ return Nodes.Table (N + 2).Flag3;
end Flag41;
function Flag42 (N : Node_Id) return Boolean is
function Flag130 (N : Node_Id) return Boolean is
begin
pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 3).Unused_1;
+ return Nodes.Table (N + 3).Flag3;
end Flag130;
function Flag131 (N : Node_Id) return Boolean is
function Flag217 (N : Node_Id) return Boolean is
begin
pragma Assert (Nkind (N) in N_Entity);
- return Nodes.Table (N + 4).Unused_1;
+ return Nodes.Table (N + 4).Flag3;
end Flag217;
function Flag218 (N : Node_Id) return Boolean is
Nodes.Table (N + 3).Field8 := To_Union (Val);
end Set_Ureal21;
+ procedure Set_Flag3 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (N <= Nodes.Last);
+ Nodes.Table (N).Flag3 := Val;
+ end Set_Flag3;
+
procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (N <= Nodes.Last);
procedure Set_Flag20 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 1).Unused_1 := Val;
+ Nodes.Table (N + 1).Flag3 := Val;
end Set_Flag20;
procedure Set_Flag21 (N : Node_Id; Val : Boolean) is
procedure Set_Flag41 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 2).Unused_1 := Val;
+ Nodes.Table (N + 2).Flag3 := Val;
end Set_Flag41;
procedure Set_Flag42 (N : Node_Id; Val : Boolean) is
procedure Set_Flag130 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 3).Unused_1 := Val;
+ Nodes.Table (N + 3).Flag3 := Val;
end Set_Flag130;
procedure Set_Flag131 (N : Node_Id; Val : Boolean) is
procedure Set_Flag217 (N : Node_Id; Val : Boolean) is
begin
pragma Assert (Nkind (N) in N_Entity);
- Nodes.Table (N + 4).Unused_1 := Val;
+ Nodes.Table (N + 4).Flag3 := Val;
end Set_Flag217;
procedure Set_Flag218 (N : Node_Id; Val : Boolean) is
-- In_List A flag used to indicate if the node is a member
-- of a node list.
- -- Rewrite_Sub A flag set if the node has been rewritten using
- -- the Rewrite procedure. The original value of the
- -- node is retrievable with Original_Node.
-
-- Rewrite_Ins A flag set if a node is marked as a rewrite inserted
-- node as a result of a call to Mark_Rewrite_Insertion.
-- it is useful to be able to do untyped traversals, and an internal
-- package in Atree allows for direct untyped accesses in such cases.
- -- Flag4 Fifteen Boolean flags (use depends on Nkind and
+ -- Flag3
+ -- Flag4 Sixteen Boolean flags (use depends on Nkind and
-- Flag5 Ekind, as described for FieldN). Again the access
-- Flag6 is usually via subprograms in Sinfo and Einfo which
-- Flag7 provide high-level synonyms for these flags, and
-- Flag8 contain debugging code that checks that the values
-- Flag9 in Nkind and Ekind are appropriate for the access.
-- Flag10
- -- Flag11 Note that Flag1-3 are missing from this list. The
- -- Flag12 first three flag positions are reserved for the
- -- Flag13 standard flags (Comes_From_Source, Error_Posted,
- -- Flag14 and Analyzed)
+ -- Flag11 Note that Flag1-2 are missing from this list. For
+ -- Flag12 historical reasons, these flag names are unused.
+ -- Flag13
+ -- Flag14
-- Flag15
-- Flag16
-- Flag17
-- entity, it is of type Entity_Kind which is defined
-- in package Einfo.
- -- Flag19 229 additional flags
+ -- Flag19 235 additional flags
-- ...
- -- Flag247
+ -- Flag254
-- Convention Entity convention (Convention_Id value)
-------------------------------------
-- A subpackage Atree.Unchecked_Access provides routines for reading and
- -- writing the fields defined above (Field1-27, Node1-27, Flag1-247 etc).
+ -- writing the fields defined above (Field1-27, Node1-27, Flag3-254 etc).
-- These unchecked access routines can be used for untyped traversals.
-- In addition they are used in the implementations of the Sinfo and
-- Einfo packages. These packages both provide logical synonyms for
function Ureal21 (N : Node_Id) return Ureal;
pragma Inline (Ureal21);
+ function Flag3 (N : Node_Id) return Boolean;
+ pragma Inline (Flag3);
+
function Flag4 (N : Node_Id) return Boolean;
pragma Inline (Flag4);
procedure Set_Ureal21 (N : Node_Id; Val : Ureal);
pragma Inline (Set_Ureal21);
+ procedure Set_Flag3 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag3);
+
procedure Set_Flag4 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag4);
-- Flag used to indicate if node is a member of a list.
-- This field is considered private to the Atree package.
- Unused_1 : Boolean;
- -- Currently unused flag
+ Flag3 : Boolean;
Rewrite_Ins : Boolean;
-- Flag set by Mark_Rewrite_Insertion procedure.
-- used in component 5 (where we still have lots of room!)
-- In_List used as Flag19, Flag40, Flag129, Flag216
- -- Unused_1 used as Flag20, Flag41, Flag130, Flag217
+ -- Flag3 used as Flag20, Flag41, Flag130, Flag217
-- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218
-- Analyzed used as Flag22, Flag43, Flag132, Flag219
-- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220
Pflag1 => False,
Pflag2 => False,
In_List => False,
- Unused_1 => False,
+ Flag3 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
Pflag1 => False,
Pflag2 => False,
In_List => False,
- Unused_1 => False,
+ Flag3 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
struct NFK
{
- Boolean is_extension : 1;
- Boolean pflag1 : 1;
- Boolean pflag2 : 1;
- Boolean in_list : 1;
- Boolean rewrite_sub : 1;
- Boolean rewrite_ins : 1;
- Boolean analyzed : 1;
- Boolean c_f_s : 1;
-
+ Boolean is_extension : 1;
+ Boolean pflag1 : 1;
+ Boolean pflag2 : 1;
+ Boolean in_list : 1;
+ Boolean flag3 : 1;
+ Boolean rewrite_ins : 1;
+ Boolean analyzed : 1;
+ Boolean c_f_s : 1;
Boolean error_posted : 1;
+
Boolean flag4 : 1;
Boolean flag5 : 1;
Boolean flag6 : 1;
struct NFNK
{
- Boolean is_extension : 1;
- Boolean pflag1 : 1;
- Boolean pflag2 : 1;
- Boolean in_list : 1;
- Boolean rewrite_sub : 1;
- Boolean rewrite_ins : 1;
- Boolean analyzed : 1;
- Boolean c_f_s : 1;
-
+ Boolean is_extension : 1;
+ Boolean pflag1 : 1;
+ Boolean pflag2 : 1;
+ Boolean in_list : 1;
+ Boolean flag3 : 1;
+ Boolean rewrite_ins : 1;
+ Boolean analyzed : 1;
+ Boolean c_f_s : 1;
Boolean error_posted : 1;
+
Boolean flag4 : 1;
Boolean flag5 : 1;
Boolean flag6 : 1;
#define Convention(N) \
(Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention)
+#define Flag3(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag3)
#define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4)
#define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5)
#define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6)
#define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18)
#define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list)
-#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_sub)
+#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag3)
#define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins)
#define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed)
#define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s)
#define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18)
#define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list)
-#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_sub)
+#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag3)
#define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins)
#define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed)
#define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s)
#define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128)
#define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list)
-#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_sub)
+#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag3)
#define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins)
#define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed)
#define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s)
#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215)
#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list)
-#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_sub)
+#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag3)
#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins)
#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed)
#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Set (Special, "Etype", True);
Set (Special, "Evaluate_Once", True);
Set (Special, "First_Itype", True);
+ Set (Special, "Has_Aspect_Specifications", True);
Set (Special, "Has_Dynamic_Itype", True);
Set (Special, "Has_Dynamic_Range_Check", True);
Set (Special, "Has_Dynamic_Length_Check", True);
-- sense for them to be set true for certain subsets of entity kinds. See
-- the spec of Einfo for further details.
- -- Note: Flag1-Flag3 are absent from this list, since these flag positions
- -- are used for the flags Analyzed, Comes_From_Source, and Error_Posted,
- -- which are common to all nodes, including entity nodes.
+ -- Note: Flag1-Flag2 are absent from this list, for historical reasons
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
+ -- (unused) Flag3
-- (unused) Flag200
-- (unused) Flag232
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Aspect_Specification |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
+ N_Aspect_Specification |
N_Case_Expression_Alternative |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
("argument for pragma% must be library level entity", Arg1);
end if;
- -- AI05-0033 : pragma cannot appear within a generic body, because
+ -- AI05-0033: A pragma cannot appear within a generic body, because
-- instance can be in a nested scope. The check that protected type
-- is itself a library-level declaration is done elsewhere.
+ -- Note: we omit this check in Codepeer mode to properly handle code
+ -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
+
if Inside_A_Generic then
if Ekind (Scope (Current_Scope)) = E_Generic_Package
- and then In_Package_Body (Scope (Current_Scope))
+ and then In_Package_Body (Scope (Current_Scope))
+ and then not CodePeer_Mode
then
Error_Pragma ("pragma% cannot be used inside a generic");
end if;
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
-with Atree; use Atree;
+with Atree; use Atree;
+with Nlists; use Nlists;
+
+with System.HTable;
package body Sinfo is
NT : Nodes.Table_Ptr renames Nodes.Table;
-- A short hand abbreviation, useful for the debugging checks
+ ------------------------------------------
+ -- Hash Table for Aspect Specifications --
+ ------------------------------------------
+
+ type Hash_Range is range 0 .. 510;
+ -- Size of hash table headers
+
+ function AS_Hash (F : Node_Id) return Hash_Range;
+ -- Hash function for hash table
+
+ function AS_Hash (F : Node_Id) return Hash_Range is
+ begin
+ return Hash_Range (F mod 511);
+ end AS_Hash;
+
+ package Aspect_Specifications_Hash_Table is new
+ System.HTable.Simple_HTable
+ (Header_Num => Hash_Range,
+ Element => List_Id,
+ No_Element => No_List,
+ Key => Node_Id,
+ Hash => AS_Hash,
+ Equal => "=");
+
----------------------------
-- Field Access Functions --
----------------------------
return List1 (N);
end Choices;
+ function Class_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ return Flag6 (N);
+ end Class_Present;
+
function Coextensions
(N : Node_Id) return Elist_Id is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause
return List1 (N);
end Expressions;
+ function First_Aspect
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ return Flag4 (N);
+ end First_Aspect;
+
function First_Bit
(N : Node_Id) return Node_Id is
begin
return Node2 (N);
end Handler_List_Entry;
+ function Has_Aspect_Specifications
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Permits_Aspect_Specifications (N));
+ return Flag3 (N);
+ end Has_Aspect_Specifications;
+
function Has_Created_Identifier
(N : Node_Id) return Boolean is
begin
begin
return Flag10 (N);
end Has_Dynamic_Length_Check;
-
function Has_Dynamic_Range_Check
(N : Node_Id) return Boolean is
begin
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Designator
return Node2 (N);
end Label_Construct;
+ function Last_Aspect
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ return Flag5 (N);
+ end Last_Aspect;
+
function Last_Bit
(N : Node_Id) return Node_Id is
begin
Set_List1_With_Parent (N, Val);
end Set_Choices;
+ procedure Set_Class_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ Set_Flag6 (N, Val);
+ end Set_Class_Present;
+
procedure Set_Coextensions
(N : Node_Id; Val : Elist_Id) is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Allocator
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause
Set_List1_With_Parent (N, Val);
end Set_Expressions;
+ procedure Set_First_Aspect
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ Set_Flag4 (N, Val);
+ end Set_First_Aspect;
+
procedure Set_First_Bit
(N : Node_Id; Val : Node_Id) is
begin
Set_Node2 (N, Val);
end Set_Handler_List_Entry;
+ procedure Set_Has_Aspect_Specifications
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (Permits_Aspect_Specifications (N));
+ Set_Flag3 (N, Val);
+ end Set_Has_Aspect_Specifications;
+
procedure Set_Has_Created_Identifier
(N : Node_Id; Val : Boolean := True) is
begin
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Block_Statement
or else NT (N).Nkind = N_Designator
Set_Node4_With_Parent (N, Val);
end Set_Last_Bit;
+ procedure Set_Last_Aspect
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ Set_Flag5 (N, Val);
+ end Set_Last_Aspect;
+
procedure Set_Last_Name
(N : Node_Id; Val : Boolean := True) is
begin
return Chars (Pragma_Identifier (N));
end Pragma_Name;
+ -----------------------------------
+ -- Permits_Aspect_Specifications --
+ -----------------------------------
+
+ Has_Aspect_Specifications_Flag : constant array (Node_Kind) of Boolean :=
+ (N_Abstract_Subprogram_Declaration => True,
+ N_Component_Declaration => True,
+ N_Entry_Declaration => True,
+ N_Exception_Declaration => True,
+ N_Formal_Abstract_Subprogram_Declaration => True,
+ N_Formal_Concrete_Subprogram_Declaration => True,
+ N_Formal_Object_Declaration => True,
+ N_Formal_Package_Declaration => True,
+ N_Formal_Type_Declaration => True,
+ N_Full_Type_Declaration => True,
+ N_Function_Instantiation => True,
+ N_Generic_Package_Declaration => True,
+ N_Generic_Subprogram_Declaration => True,
+ N_Object_Declaration => True,
+ N_Package_Declaration => True,
+ N_Package_Instantiation => True,
+ N_Private_Extension_Declaration => True,
+ N_Private_Type_Declaration => True,
+ N_Procedure_Instantiation => True,
+ N_Protected_Type_Declaration => True,
+ N_Single_Protected_Declaration => True,
+ N_Single_Task_Declaration => True,
+ N_Subprogram_Declaration => True,
+ N_Subtype_Declaration => True,
+ N_Task_Type_Declaration => True,
+ others => False);
+
+ function Permits_Aspect_Specifications (N : Node_Id) return Boolean is
+ begin
+ return Has_Aspect_Specifications_Flag (Nkind (N));
+ end Permits_Aspect_Specifications;
+
+ ---------------------------
+ -- Aspect_Specifications --
+ ---------------------------
+
+ function Aspect_Specifications (N : Node_Id) return List_Id is
+ begin
+ return Aspect_Specifications_Hash_Table.Get (N);
+ end Aspect_Specifications;
+
+ -------------------------------
+ -- Set_Aspect_Specifications --
+ -------------------------------
+
+ procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is
+ begin
+ pragma Assert (Permits_Aspect_Specifications (N));
+ pragma Assert (not Has_Aspect_Specifications (N));
+ pragma Assert (L /= No_List);
+
+ Set_Has_Aspect_Specifications (N);
+ Set_Parent (L, N);
+ Aspect_Specifications_Hash_Table.Set (N, L);
+ end Set_Aspect_Specifications;
+
end Sinfo;
-- Discriminant_Specifications (List4) (set to No_List if none)
-- Type_Definition (Node3)
-- Discr_Check_Funcs_Built (Flag11-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
----------------------------
-- 3.2.1 Type Definition --
-- Subtype_Indication (Node5)
-- Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-- Exception_Junk (Flag8-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------
-- 3.2.2 Subtype Indication --
-- Exception_Junk (Flag8-Sem)
-- Is_Subprogram_Descriptor (Flag16-Sem)
-- Has_Init_Expression (Flag14)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------------
-- 3.3.1 Defining Identifier List --
-- Expression (Node3) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------
-- 3.8.1 Variant Part --
-- Body_To_Inline (Node3-Sem)
-- Corresponding_Body (Node5-Sem)
-- Parent_Spec (Node4-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
------------------------------------------
-- 6.1 Abstract Subprogram Declaration --
-- N_Abstract_Subprogram_Declaration
-- Sloc points to ABSTRACT
-- Specification (Node1)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-----------------------------------
-- 6.1 Subprogram Specification --
-- By_Ref (Flag5-Sem)
-- Note: Return_Statement_Entity points to an E_Return_Statement.
+
-- Note that Return_Object_Declarations is a list containing the
-- N_Object_Declaration -- see comment on this field above.
+
-- The declared object will have Is_Return_Object = True.
+
-- There is no such syntactic category as return_object_declaration
-- in the RM. Return_Object_Declarations represents this portion of
-- the syntax for EXTENDED_RETURN_STATEMENT:
-- Corresponding_Body (Node5-Sem)
-- Parent_Spec (Node4-Sem)
-- Activation_Chain_Entity (Node3-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
--------------------------------
-- 7.1 Package Specification --
-- Abstract_Present (Flag4)
-- Tagged_Present (Flag15)
-- Limited_Present (Flag17)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
----------------------------------------
-- 7.4 Private Extension Declaration --
-- Synchronized_Present (Flag7)
-- Subtype_Indication (Node5)
-- Interface_List (List2) (set to No_List if none)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
---------------------
-- 8.4 Use Clause --
-- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
-- Corresponding_Body (Node5-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
----------------------------------
-- 9.1 Single Task Declaration --
-- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
--------------------------
-- 9.1 Task Definition --
-- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
-- Corresponding_Body (Node5-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
---------------------------------------
-- 9.4 Single Protected Declaration --
-- Defining_Identifier (Node1)
-- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------
-- 9.4 Protected Definition --
-- Corresponding_Body (Node5-Sem)
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
+ -- Has_Aspect_Specifications (Flag3)
-- Note: overriding indicator is an Ada 2005 feature
+ -- Note: Aspect_Specification is an Ada 2012 feature
-----------------------------
-- 9.5.2 Accept statement --
-- Renaming_Exception (Node2-Sem)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
------------------------------------------
-- 11.2 Handled Sequence Of Statements --
-- Corresponding_Body (Node5-Sem)
-- Generic_Formal_Declarations (List2) from generic formal part
-- Parent_Spec (Node4-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
---------------------------------------
-- 12.1 Generic Package Declaration --
-- Generic_Formal_Declarations (List2) from generic formal part
-- Parent_Spec (Node4-Sem)
-- Activation_Chain_Entity (Node3-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------
-- 12.1 Generic Formal Part --
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem)
+ -- Has_Aspect_Specifications (Flag3)
-- N_Procedure_Instantiation
-- Sloc points to PROCEDURE
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
+ -- Has_Aspect_Specifications (Flag3)
-- N_Function_Instantiation
-- Sloc points to FUNCTION
-- Must_Override (Flag14) set if overriding indicator present
-- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
+ -- Has_Aspect_Specifications (Flag3)
-- Note: overriding indicator is an Ada 2005 feature
+ -- Note: Aspect_Specification is an Ada 2012 feature
-------------------------------
-- 12.3 Generic Actual Part --
-- Default_Expression (Node5) (set to Empty if no default expression)
-- More_Ids (Flag5) (set to False if no more identifiers in list)
-- Prev_Ids (Flag6) (set to False if no previous identifiers in list)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
-----------------------------------
-- 12.5 Formal Type Declaration --
-- Discriminant_Specifications (List4) (set to No_List if no
-- discriminant part)
-- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
----------------------------------
-- 12.5 Formal type definition --
-- Specification (Node1)
-- Default_Name (Node2) (set to Empty if no subprogram default)
-- Box_Present (Flag15)
+ -- Has_Aspect_Specifications (Flag3)
-- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False.
+ -- Note: Aspect_Specification is an Ada 2012 feature
+
--------------------------------------------------
-- 12.6 Formal Abstract Subprogram Declaration --
--------------------------------------------------
-- Specification (Node1)
-- Default_Name (Node2) (set to Empty if no subprogram default)
-- Box_Present (Flag15)
+ -- Has_Aspect_Specifications (Flag3)
-- Note: if no subprogram default is present, then Name is set
-- to Empty, and Box_Present is False.
+ -- Note: Aspect_Specification is an Ada 2012 feature
+
------------------------------
-- 12.6 Subprogram Default --
------------------------------
-- Box_Present (Flag15)
-- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem)
+ -- Has_Aspect_Specifications (Flag3)
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
--------------------------------------
-- 12.7 Formal Package Actual Part --
-- Check_Address_Alignment (Flag11-Sem)
-- Address_Warning_Posted (Flag18-Sem)
+ ----------------------------------
+ -- 13.3.1 Aspect Specification --
+ ----------------------------------
+
+ -- ASPECT_SPECIFICATION ::=
+ -- with ASPECT_MARK [=> ASPECT_DEFINITION] {.
+ -- ASPECT_MARK [=> ASPECT_DEFINITION] }
+
+ -- ASPECT_MARK ::= aspect_IDENTIFIER['Class]
+
+ -- ASPECT_DEFINITION ::= NAME | EXPRESSION
+
+ -- See separate section "Handling of Aspect Specifications" for details
+ -- on the incorporation of these nodes into the tree, and association
+ -- with the related declaration node.
+
+ -- N_Aspect_Specification
+ -- Sloc points to aspect identifier
+ -- Identifier (Node1) aspect identifier
+ -- Expression (Node3) Aspect_Definition (set to Empty if none)
+ -- First_Aspect (Flag4) Set for first aspect for a declaration
+ -- Last_Aspect (Flag5) Set for last aspect for a declaration
+ -- Class_Present (Flag6) Set if 'Class present
+
+ -- Note: Aspect_Specification is an Ada 2012 feature
+
---------------------------------------------
-- 13.4 Enumeration representation clause --
---------------------------------------------
N_Enumeration_Representation_Clause,
N_Mod_Clause,
N_Record_Representation_Clause,
+ N_Aspect_Specification,
-- N_Representation_Clause, N_Has_Chars
function Choices
(N : Node_Id) return List_Id; -- List1
+ function Class_Present
+ (N : Node_Id) return Boolean; -- Flag6
+
function Coextensions
(N : Node_Id) return Elist_Id; -- Elist4
function Expressions
(N : Node_Id) return List_Id; -- List1
+ function First_Aspect
+ (N : Node_Id) return Boolean; -- Flag4
+
function First_Bit
(N : Node_Id) return Node_Id; -- Node3
function Handler_List_Entry
(N : Node_Id) return Node_Id; -- Node2
+ function Has_Aspect_Specifications
+ (N : Node_Id) return Boolean; -- Flag3
+
function Has_Created_Identifier
(N : Node_Id) return Boolean; -- Flag15
function Left_Opnd
(N : Node_Id) return Node_Id; -- Node2
+ function Last_Aspect
+ (N : Node_Id) return Boolean; -- Flag5
+
function Last_Bit
(N : Node_Id) return Node_Id; -- Node4
procedure Set_Array_Aggregate
(N : Node_Id; Val : Node_Id); -- Node3
+ procedure Set_Has_Aspect_Specifications
+ (N : Node_Id; Val : Boolean := True); -- Flag3
+
procedure Set_Assignment_OK
(N : Node_Id; Val : Boolean := True); -- Flag15
procedure Set_Choice_Parameter
(N : Node_Id; Val : Node_Id); -- Node2
- procedure Set_Coextensions
- (N : Node_Id; Val : Elist_Id); -- Elist4
-
procedure Set_Choices
(N : Node_Id; Val : List_Id); -- List1
+ procedure Set_Class_Present
+ (N : Node_Id; Val : Boolean := True); -- Flag6
+
+ procedure Set_Coextensions
+ (N : Node_Id; Val : Elist_Id); -- Elist4
+
procedure Set_Comes_From_Extended_Return_Statement
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Expressions
(N : Node_Id; Val : List_Id); -- List1
+ procedure Set_First_Aspect
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_First_Bit
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Kill_Range_Check
(N : Node_Id; Val : Boolean := True); -- Flag11
+ procedure Set_Last_Aspect
+ (N : Node_Id; Val : Boolean := True); -- Flag5
+
procedure Set_Last_Bit
(N : Node_Id; Val : Node_Id); -- Node4
4 => False, -- unused
5 => False), -- Next_Rep_Item (Node5-Sem)
+ N_Aspect_Specification =>
+ (1 => True, -- Identifier (Node1)
+ 2 => False, -- unused
+ 3 => True, -- Expression (Node3)
+ 4 => False, -- unused
+ 5 => False), -- unused
+
N_Enumeration_Representation_Clause =>
(1 => True, -- Identifier (Node1)
2 => False, -- unused
4 => False, -- unused
5 => False), -- unused
- -- End of inserted output from makeisf program
-
-- Entries for SCIL nodes
N_SCIL_Dispatch_Table_Tag_Init =>
4 => False, -- unused
5 => False)); -- unused
+ ---------------------------------------
+ -- Handling of Aspect Specifications --
+ ---------------------------------------
+
+ -- Several kinds of declaration node permit aspect specifications in Ada
+ -- 2012 mode. If there was room in all these declaration nodes, we could
+ -- just have a field Aspect_Specifications pointing to a list of nodes
+ -- for the aspects (N_Aspect_Specification nodes). But there isn't room,
+ -- so we adopt a different approach.
+
+ -- The following subprograms provide access to a specialized interface
+ -- implemented internally with a hash table in the body, that provides
+ -- access to aspect specifications.
+
+ function Permits_Aspect_Specifications (N : Node_Id) return Boolean;
+ -- Returns True if the node N is a declaration node that permits aspect
+ -- specifications. All such nodes have the Has_Aspect_Specifications
+ -- flag defined. Returns False for all other nodes.
+
+ function Aspect_Specifications (N : Node_Id) return List_Id;
+ -- Given a node N, returns the list of N_Aspect_Specification nodes that
+ -- are attached to this declaration node. If the node is in the class of
+ -- declaration nodes that permit aspect specifications, as defined by the
+ -- predicate above, and if their Has_Aspect_Specifications flag is set to
+ -- True, then this will always be a non-empty list. If this flag is set to
+ -- False, or the node is not in the declaration class permitting aspect
+ -- specifications, then No_List is returned.
+
+ procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id);
+ -- The node N must be in the class of declaration nodes that permit aspect
+ -- specifications and the Has_Aspect_Specifications flag must be False on
+ -- entry. L must be a non-empty list of N_Aspect_Specification nodes. This
+ -- procedure sets the Has_Aspect_Specifications flag to True, and makes an
+ -- entry that can be retrieved by a subsequent Aspect_Specifications call.
+ -- The parent of list L is set to reference the declaration node N. It is
+ -- an error to call this procedure with a node that does not permit aspect
+ -- specifications, or a node that has its Has_Aspect_Specifications flag
+ -- set True on entry, or with L being an empty list or No_List.
+
--------------------
-- Inline Pragmas --
--------------------
pragma Inline (Check_Address_Alignment);
pragma Inline (Choice_Parameter);
pragma Inline (Choices);
+ pragma Inline (Class_Present);
pragma Inline (Coextensions);
pragma Inline (Comes_From_Extended_Return_Statement);
pragma Inline (Compile_Time_Known_Aggregate);
pragma Inline (Explicit_Generic_Actual_Parameter);
pragma Inline (Expression);
pragma Inline (Expressions);
+ pragma Inline (First_Aspect);
pragma Inline (First_Bit);
pragma Inline (First_Inlined_Subprogram);
pragma Inline (First_Name);
pragma Inline (Generic_Parent_Type);
pragma Inline (Handled_Statement_Sequence);
pragma Inline (Handler_List_Entry);
+ pragma Inline (Has_Aspect_Specifications);
pragma Inline (Has_Created_Identifier);
pragma Inline (Has_Dynamic_Length_Check);
pragma Inline (Has_Dynamic_Range_Check);
pragma Inline (Iteration_Scheme);
pragma Inline (Itype);
pragma Inline (Kill_Range_Check);
+ pragma Inline (Last_Aspect);
pragma Inline (Last_Bit);
pragma Inline (Last_Name);
pragma Inline (Library_Unit);
pragma Inline (Set_Check_Address_Alignment);
pragma Inline (Set_Choice_Parameter);
pragma Inline (Set_Choices);
+ pragma Inline (Set_Class_Present);
pragma Inline (Set_Coextensions);
pragma Inline (Set_Comes_From_Extended_Return_Statement);
pragma Inline (Set_Compile_Time_Known_Aggregate);
pragma Inline (Set_Explicit_Generic_Actual_Parameter);
pragma Inline (Set_Expression);
pragma Inline (Set_Expressions);
+ pragma Inline (Set_First_Aspect);
pragma Inline (Set_First_Bit);
pragma Inline (Set_First_Inlined_Subprogram);
pragma Inline (Set_First_Name);
pragma Inline (Set_Generic_Parent_Type);
pragma Inline (Set_Handled_Statement_Sequence);
pragma Inline (Set_Handler_List_Entry);
+ pragma Inline (Set_Has_Aspect_Specifications);
pragma Inline (Set_Has_Created_Identifier);
pragma Inline (Set_Has_Dynamic_Length_Check);
pragma Inline (Set_Has_Init_Expression);
pragma Inline (Set_Iteration_Scheme);
pragma Inline (Set_Itype);
pragma Inline (Set_Kill_Range_Check);
+ pragma Inline (Set_Last_Aspect);
pragma Inline (Set_Last_Bit);
pragma Inline (Set_Last_Name);
pragma Inline (Set_Library_Unit);
Write_Str_Sloc (" and then ");
Sprint_Right_Opnd (Node);
- when N_At_Clause =>
- Write_Indent_Str_Sloc ("for ");
- Write_Id (Identifier (Node));
- Write_Str_With_Col_Check (" use at ");
- Sprint_Node (Expression (Node));
- Write_Char (';');
+ when N_Aspect_Specification =>
+ raise Program_Error;
when N_Assignment_Statement =>
Write_Indent;
Sprint_Node (Abortable_Part (Node));
Write_Indent_Str ("end select;");
+ when N_At_Clause =>
+ Write_Indent_Str_Sloc ("for ");
+ Write_Id (Identifier (Node));
+ Write_Str_With_Col_Check (" use at ");
+ Sprint_Node (Expression (Node));
+ Write_Char (';');
+
when N_Attribute_Definition_Clause =>
Write_Indent_Str_Sloc ("for ");
Sprint_Node (Name (Node));
when F_Field5 =>
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
+ when F_Flag3 => Field_To_Be_Printed := Flag3 (N);
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
- -- Flag1,2,3 are no longer used
+ -- Flag1,2 are no longer used
when F_Flag1 => raise Program_Error;
when F_Flag2 => raise Program_Error;
- when F_Flag3 => raise Program_Error;
-
end case;
-- Print field if it is to be printed
projects / gcc.git / commitdiff