pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
-with Atree; use Atree;
-with Nlists; use Nlists;
-
-with GNAT.HTable;
+with Atree; use Atree;
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
- GNAT.HTable.Simple_HTable
- (Header_Num => Hash_Range,
- Element => List_Id,
- No_Element => No_List,
- Key => Node_Id,
- Hash => AS_Hash,
- Equal => "=");
-
----------------------------
-- Field Access Functions --
----------------------------
pragma Assert (False
or else NT (N).Nkind = N_Access_Definition
or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Use_Type_Clause);
return Flag15 (N);
end All_Present;
return Node3 (N);
end Array_Aggregate;
+ function Aspect_Cancel
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return Flag11 (N);
+ end Aspect_Cancel;
+
+ function Aspect_Rep_Item
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ return Node2 (N);
+ end Aspect_Rep_Item;
+
function Assignment_OK
(N : Node_Id) return Boolean is
begin
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Pragma);
return Flag6 (N);
end Class_Present;
or else NT (N).Nkind = N_Exit_Statement
or else NT (N).Nkind = N_If_Statement
or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Raise_Constraint_Error
or else NT (N).Nkind = N_Raise_Program_Error
or else NT (N).Nkind = N_Raise_Storage_Error
return Node5 (N);
end Default_Expression;
+ function Default_Storage_Pool
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux);
+ return Node3 (N);
+ end Default_Storage_Pool;
+
function Default_Name
(N : Node_Id) return Node_Id is
begin
or else NT (N).Nkind = N_Full_Type_Declaration
or else NT (N).Nkind = N_Implicit_Label_Declaration
or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification
or else NT (N).Nkind = N_Number_Declaration
or else NT (N).Nkind = N_Object_Declaration
begin
pragma Assert (False
or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Freeze_Entity);
return Node4 (N);
end Entity;
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 Flag5 (N);
end Forwards_OK;
+ function From_Aspect_Specification
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Pragma);
+ return Flag13 (N);
+ end From_Aspect_Specification;
+
function From_At_End
(N : Node_Id) return Boolean 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
return Flag17 (N);
end Has_No_Elaboration_Code;
- function Has_Priority_Pragma
+ function Has_Pragma_CPU
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ return Flag14 (N);
+ end Has_Pragma_CPU;
+
+ function Has_Pragma_Priority
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
return Flag6 (N);
- end Has_Priority_Pragma;
+ end Has_Pragma_Priority;
+
+ function Has_Pragma_Suppress_All
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ return Flag14 (N);
+ end Has_Pragma_Suppress_All;
function Has_Private_View
(N : Node_Id) return Boolean is
return Flag16 (N);
end Is_Controlling_Actual;
+ function Is_Delayed_Aspect
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Pragma);
+ return Flag14 (N);
+ end Is_Delayed_Aspect;
+
function Is_Dynamic_Coextension
(N : Node_Id) return Boolean is
begin
return Node2 (N);
end Iteration_Scheme;
+ function Iterator_Specification
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
+ return Node2 (N);
+ end Iterator_Specification;
+
function Itype
(N : Node_Id) return Node_Id is
begin
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
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Iteration_Scheme);
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
return Node4 (N);
end Loop_Parameter_Specification;
or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Object_Renaming_Declaration
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Package_Renaming_Declaration
(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_Attribute_Definition_Clause
or else NT (N).Nkind = N_Enumeration_Representation_Clause
or else NT (N).Nkind = N_Pragma
return Node4 (N);
end Object_Definition;
+ function Of_Present
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification);
+ return Flag16 (N);
+ end Of_Present;
+
function Original_Discriminant
(N : Node_Id) return Node_Id is
begin
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification);
return Flag15 (N);
end Reverse_Present;
return Node1 (N);
end Specification;
+ function Split_PPC
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Pragma);
+ return Flag17 (N);
+ end Split_PPC;
+
function Statements
(N : Node_Id) return List_Id is
begin
or else NT (N).Nkind = N_Access_To_Object_Definition
or else NT (N).Nkind = N_Component_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
return Node5 (N);
end Subtype_Indication;
+ function Suppress_Assignment_Checks
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Object_Declaration);
+ return Flag18 (N);
+ end Suppress_Assignment_Checks;
+
function Suppress_Loop_Warnings
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Access_Definition
or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Use_Type_Clause);
Set_Flag15 (N, Val);
end Set_All_Present;
Set_Node3_With_Parent (N, Val);
end Set_Array_Aggregate;
+ procedure Set_Aspect_Cancel
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag11 (N, Val);
+ end Set_Aspect_Cancel;
+
+ procedure Set_Aspect_Rep_Item
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification);
+ Set_Node2 (N, Val);
+ end Set_Aspect_Rep_Item;
+
procedure Set_Assignment_OK
(N : Node_Id; Val : Boolean := True) is
begin
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification);
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Pragma);
Set_Flag6 (N, Val);
end Set_Class_Present;
or else NT (N).Nkind = N_Exit_Statement
or else NT (N).Nkind = N_If_Statement
or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Raise_Constraint_Error
or else NT (N).Nkind = N_Raise_Program_Error
or else NT (N).Nkind = N_Raise_Storage_Error
Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Default_Expression;
+ procedure Set_Default_Storage_Pool
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux);
+ Set_Node3 (N, Val); -- semantic field, no parent set
+ end Set_Default_Storage_Pool;
+
procedure Set_Default_Name
(N : Node_Id; Val : Node_Id) is
begin
or else NT (N).Nkind = N_Full_Type_Declaration
or else NT (N).Nkind = N_Implicit_Label_Declaration
or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification
or else NT (N).Nkind = N_Number_Declaration
or else NT (N).Nkind = N_Object_Declaration
begin
pragma Assert (False
or else NT (N).Nkind in N_Has_Entity
- or else NT (N).Nkind = N_Freeze_Entity
- or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Freeze_Entity);
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_Entity;
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_Flag5 (N, Val);
end Set_Forwards_OK;
+ procedure Set_From_Aspect_Specification
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag13 (N, Val);
+ end Set_From_Aspect_Specification;
+
procedure Set_From_At_End
(N : Node_Id; Val : Boolean := True) 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
Set_Flag17 (N, Val);
end Set_Has_No_Elaboration_Code;
- procedure Set_Has_Priority_Pragma
+ procedure Set_Has_Pragma_CPU
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Subprogram_Body
+ or else NT (N).Nkind = N_Task_Definition);
+ Set_Flag14 (N, Val);
+ end Set_Has_Pragma_CPU;
+
+ procedure Set_Has_Pragma_Priority
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subprogram_Body
or else NT (N).Nkind = N_Task_Definition);
Set_Flag6 (N, Val);
- end Set_Has_Priority_Pragma;
+ end Set_Has_Pragma_Priority;
+
+ procedure Set_Has_Pragma_Suppress_All
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit);
+ Set_Flag14 (N, Val);
+ end Set_Has_Pragma_Suppress_All;
procedure Set_Has_Private_View
(N : Node_Id; Val : Boolean := True) is
Set_Flag16 (N, Val);
end Set_Is_Controlling_Actual;
+ procedure Set_Is_Delayed_Aspect
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag14 (N, Val);
+ end Set_Is_Delayed_Aspect;
+
procedure Set_Is_Dynamic_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
Set_Node2_With_Parent (N, Val);
end Set_Iteration_Scheme;
+ procedure Set_Iterator_Specification
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
+ Set_Node2_With_Parent (N, Val);
+ end Set_Iterator_Specification;
+
procedure Set_Itype
(N : Node_Id; Val : Entity_Id) is
begin
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
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Iteration_Scheme);
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
Set_Node4_With_Parent (N, Val);
end Set_Loop_Parameter_Specification;
or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration
or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration
or else NT (N).Nkind = N_Goto_Statement
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Object_Renaming_Declaration
or else NT (N).Nkind = N_Package_Instantiation
or else NT (N).Nkind = N_Package_Renaming_Declaration
(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_Attribute_Definition_Clause
or else NT (N).Nkind = N_Enumeration_Representation_Clause
or else NT (N).Nkind = N_Pragma
Set_Node4_With_Parent (N, Val);
end Set_Object_Definition;
+ procedure Set_Of_Present
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification);
+ Set_Flag16 (N, Val);
+ end Set_Of_Present;
+
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id) is
begin
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification);
Set_Flag15 (N, Val);
end Set_Reverse_Present;
Set_Node1_With_Parent (N, Val);
end Set_Specification;
+ procedure Set_Split_PPC
+ (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag17 (N, Val);
+ end Set_Split_PPC;
+
procedure Set_Statements
(N : Node_Id; Val : List_Id) is
begin
or else NT (N).Nkind = N_Access_To_Object_Definition
or else NT (N).Nkind = N_Component_Definition
or else NT (N).Nkind = N_Derived_Type_Definition
+ or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Subtype_Declaration);
Set_Node5_With_Parent (N, Val);
Set_List2_With_Parent (N, Val);
end Set_Subtype_Marks;
+ procedure Set_Suppress_Assignment_Checks
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Object_Declaration);
+ Set_Flag18 (N, Val);
+ end Set_Suppress_Assignment_Checks;
+
procedure Set_Suppress_Loop_Warnings
(N : Node_Id; Val : Boolean := True) is
begin
end if;
end End_Location;
+ --------------------
+ -- Get_Pragma_Arg --
+ --------------------
+
+ function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
+ begin
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ return Expression (Arg);
+ else
+ return Arg;
+ end if;
+ end Get_Pragma_Arg;
+
----------------------
-- Set_End_Location --
----------------------
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;
OSDN Git Service
