home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Geek Gadgets 1
/
ADE-1.bin
/
ade-dist
/
gnat-2.06-src.tgz
/
tar.out
/
fsf
/
gnat
/
ada
/
einfo.adb
< prev
next >
Wrap
Text File
|
1996-09-28
|
116KB
|
3,946 lines
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E I N F O --
-- --
-- B o d y --
-- --
-- $Revision: 1.334 $ --
-- --
-- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved --
-- --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software Foundation; either version 2, or (at your option) any --
-- later version. The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty --
-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- Library General Public License for more details. You should have --
-- received a copy of the GNU Library General Public License along with --
-- the GNAT library; see the file COPYING.LIB. If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Output; use Output;
package body Einfo is
use Atree.Unchecked_Access;
-- This is one of the packages that is allowed direct untyped access to
-- the fields in a node, since it provides the next level abstraction
-- which incorporates appropriate checks.
----------------------------------------------
-- Usage of Fields in Defining Entity Nodes --
----------------------------------------------
-- The first five of these fields are defined in Sinfo, since they in
-- the base part of the node. The access routines for these fields and
-- the corresponding set procedures are defined in Sinfo. The are all
-- present in all entities.
-- Chars Name1
-- Next_Entity Node2
-- Scope Node3
-- Homonym Node4
-- Etype Node5
-- The remaining fields are in the node extension and are present only
-- in entities. The usage of each field depends on the particular entity
-- kind (see Einfo spec for details).
-- Discriminant_Constraint Elist6
-- Small_Value Ureal6
-- Accept_Address Elist6
-- Interface_Name Node6
-- Alias Node7
-- Corresponding_Concurrent_Type Node7
-- Delta_Value Ureal7
-- Entry_Parameters_Type Node7
-- Equivalent_Type Node7
-- Lit_Name_Table Node7
-- Renamed_Entity Node7
-- Renamed_Object Node7
-- Corresponding_Record_Type Node7
-- Corresponding_Discriminant Node7
-- Private_Dependents Elist7
-- Alignment_Clause Node8
-- Enumeration_Rep_Expr Node8
-- Original_Record_Component Node8
-- Protected_Formal Node8
-- Scope_Depth Uint8
-- Actual_Subtype Node9
-- Digits_Value Uint9
-- Discriminal Node9
-- First_Entity Node9
-- First_Index Node9
-- First_Literal Node9
-- Master_Id Node9
-- Modulus Uint9
-- Object_Ref Node9
-- Prival Node9
-- Component_Type Node10
-- Default_Value Node10
-- Directly_Designated_Type Node10
-- Discriminant_Checking_Func Node10
-- Discriminant_Default_Value Node10
-- Last_Entity Node10
-- Scalar_Range Node10
-- Protected_Body_Subprogram Node11
-- Component_First_Bit Uint11
-- Full_View Node11
-- Entry_Component Node11
-- Enumeration_Pos Uint11
-- First_Private_Entity Node11
-- String_Literal_Length Uint11
-- Table_High_Bound Node11
-- Barrier_Function Node12
-- Enumeration_Rep Uint12
-- Esize Uint12
-- Next_Inlined_Subprogram Node12
-- Associated_Storage_Pool Node13
-- Component_Clause Node13
-- Component_Size_Clause Node13
-- Finalization_Chain_Entity Node13
-- Primitive_Operations Elist13
-- Associated_Final_Chain Node14
-- Enum_Pos_To_Rep Node14
-- Packed_Array_Type Node14
-- Protected_Operation Node14
-- Storage_Size_Variable Node14
-- Task_Activation_Chain_Entity Node14
-- Access_Disp_Table Node15
-- Vtable_Entry_Count Uint15
-- DT_Position Uint15
-- DT_Entry_Count Uint15
-- Entry_Bodies_Array Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- Next_Itype Node16
-- DTC_Entity Node16
-- Class_Wide_Type Node17
-- Machine_Attribute Node17
-- Freeze_Node Node18
-- Task_Body_Procedure Node19
-- Address_Clause Node20
-- (unused) Node21
-- (unused) Node22
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
---------------------------------------------
-- All flags are unique, there is no overlaying, so each flag is physically
-- present in every entity. However, for many of the flags, it only makes
-- sense for them to be set true for certain subsets of entity kinds. See
-- the spec of Einfo for futher details.
-- Is_Generic_Type Flag1
-- Is_Constrained Flag3
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- Is_Dispatching_Operation Flag6
-- Is_Immediately_Visible Flag7
-- In_Use Flag8
-- Is_Potentially_Use_Visible Flag9
-- Is_Public Flag10
-- Is_Inlined Flag11
-- Analyzed Flag12
-- Error_Posted Flag13
-- Depends_On_Private Flag14
-- Is_Aliased Flag15
-- Is_Volatile Flag16
-- Is_Internal Flag17
-- Has_Delayed_Freeze Flag18
-- Is_Abstract Flag19
-- Is_Concurrent_Record_Type Flag20
-- Has_Master_Entity Flag21
-- Needs_No_Actuals Flag22
-- Has_Storage_Size_Clause Flag23
-- Is_Imported Flag24
-- Is_Limited_Record Flag25
-- Has_Completion Flag26
-- Has_Pragma_Controlled Flag27
-- (unused) Flag28
-- Has_Size_Clause Flag29
-- Has_Tasks Flag30
-- Suppress_Access_Checks Flag31
-- Suppress_Accessibility_Checks Flag32
-- Suppress_Discriminant_Checks Flag33
-- Suppress_Division_Checks Flag34
-- Suppress_Elaboration_Checks Flag35
-- Suppress_Index_Checks Flag36
-- Suppress_Length_Checks Flag37
-- Suppress_Overflow_Checks Flag38
-- Suppress_Range_Checks Flag39
-- Suppress_Storage_Checks Flag40
-- Suppress_Tag_Checks Flag41
-- Is_Controlled Flag42
-- Has_Controlled Flag43
-- Is_Pure Flag44
-- In_Private_Part Flag45
-- Has_Alignment_Clause Flag46
-- Has_Exit Flag47
-- In_Package_Body Flag48
-- Reachable Flag49
-- Needs_Discr_Check Flag50
-- Is_Packed Flag51
-- Is_Entry_Formal Flag52
-- Is_Private_Descendant Flag53
-- Return_Present Flag54
-- Is_Tagged_Type Flag55
-- Has_Homonym Flag56
-- Is_Private Flag57
-- Non_Binary_Modulus Flag58
-- Is_Preelaborated Flag59
-- Is_Shared_Passive Flag60
-- Is_Remote_Types Flag61
-- Is_Remote_Call_Interface Flag62
-- Is_Character_Type Flag63
-- Is_Intrinsic_Subprogram Flag64
-- Has_Record_Rep_Clause Flag65
-- Has_Enumeration_Rep_Clause Flag66
-- Has_Small_Clause Flag67
-- Has_Component_Size_Clause Flag68
-- Is_Access_Constant Flag69
-- Is_First_Subtype Flag70
-- Has_Completion_In_Body Flag71
-- Has_Unknown_Discriminants Flag72
-- Is_Child_Unit Flag73
-- Is_CPP_CLass Flag74
-- Has_Non_Standard_Rep Flag75
-- Is_Constructor Flag76
-- Is_Destructor Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Has_U_Nominal_Subtype Flag80
-- Is_Asynchronous Flag81
-- Has_Machine_Attribute Flag82
-- Has_Machine_Radix_Clause Flag83
-- Machine_Radix_10 Flag84
-- Is_Atomic Flag85
-- Has_Atomic_Components Flag86
-- Has_Volatile_Components Flag87
-- Discard_Names Flag88
-- Is_Interrupt_Handler Flag89
-- Returns_By_Ref Flag90
-- Is_Itype Flag91
-- Size_Known_At_Compile_Time Flag92
-- Is_Declared_In_Package_Body Flag93
-- Is_Generic_Actual_Type Flag94
-- Uses_Sec_Stack Flag95
-- Return_By_Ref Flag96
-- Is_Controlling_Formal Flag97
-- Has_Controlling_Result Flag98
-- Is_Exported Flag99
-- Has_Specified_Layout Flag100
-- Has_Nested_Block_With_Handler Flag101
-- Is_Called Flag102
-- (unused) Flag103
-- (unused) Flag104
-- (unused) Flag105
-- (unused) Flag106
-- (unused) Flag107
-- (unused) Flag108
-- (unused) Flag109
-- (unused) Flag110
-- (unused) Flag111
-- (unused) Flag112
--------------------------------
-- Attribute Access Functions --
--------------------------------
function Accept_Address (Id : E) return L is
begin
return Elist6 (Id);
end Accept_Address;
function Access_Disp_Table (Id : E) return E is
begin
pragma Assert (Is_Tagged_Type (Id));
return Node15 (Id);
end Access_Disp_Table;
function Actual_Subtype (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable
or else Ekind (Id) = E_Generic_In_Out_Parameter
or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter);
return Node9 (Id);
end Actual_Subtype;
function Address_Clause (Id : E) return N is
begin
return Node20 (Id);
end Address_Clause;
function Alias (Id : E) return E is
begin
pragma Assert
(Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
return Node7 (Id);
end Alias;
function Alignment_Clause (Id : E) return N is
begin
pragma Assert
(Is_Type (Id)
or else Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable);
return Node8 (Id);
end Alignment_Clause;
function Associated_Formal_Package (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
return Node12 (Id);
end Associated_Formal_Package;
function Associated_Storage_Pool (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
return Node13 (Id);
end Associated_Storage_Pool;
function Associated_Final_Chain (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
return Node14 (Id);
end Associated_Final_Chain;
function Barrier_Function (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Entry or else Ekind (Id) = E_Entry_Family);
return Node12 (Id);
end Barrier_Function;
function Class_Wide_Type (Id : E) return E is
begin
return Node17 (Id);
end Class_Wide_Type;
function Component_Clause (Id : E) return N is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
return Node13 (Id);
end Component_Clause;
function Component_First_Bit (Id : E) return U is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
return Uint11 (Id);
end Component_First_Bit;
function Component_Size_Clause (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Array_Type);
return Node13 (Id);
end Component_Size_Clause;
function Component_Type (Id : E) return E is
begin
return Node10 (Id);
end Component_Type;
function Corresponding_Concurrent_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
return Node7 (Id);
end Corresponding_Concurrent_Type;
function Corresponding_Discriminant (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Discriminant);
return Node7 (Id);
end Corresponding_Discriminant;
function Corresponding_Record_Type (Id : E) return E is
begin
pragma Assert (Is_Concurrent_Type (Id));
return Node7 (Id);
end Corresponding_Record_Type;
function Default_Value (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_In_Parameter);
return Node10 (Id);
end Default_Value;
function Delta_Value (Id : E) return R is
begin
pragma Assert (Is_Fixed_Point_Type (Id));
return Ureal7 (Id);
end Delta_Value;
function Digits_Value (Id : E) return U is
begin
pragma Assert
(Is_Floating_Point_Type (Id)
or else Is_Decimal_Fixed_Point_Type (Id));
return Uint9 (Id);
end Digits_Value;
function Directly_Designated_Type (Id : E) return E is
begin
return Node10 (Id);
end Directly_Designated_Type;
function Discard_Names (Id : E) return B is
begin
return Flag88 (Id);
end Discard_Names;
function Discriminal (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Discriminant);
return Node9 (Id);
end Discriminal;
function Discriminant_Checking_Func (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Component);
return Node10 (Id);
end Discriminant_Checking_Func;
function Discriminant_Constraint (Id : E) return Elist_Id is
begin
pragma Assert
(Is_Composite_Type (Id) and then not Is_Array_Type (Id));
return Elist6 (Id);
end Discriminant_Constraint;
function Discriminant_Default_Value (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Discriminant);
return Node10 (Id);
end Discriminant_Default_Value;
function DTC_Entity (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
return Node16 (Id);
end DTC_Entity;
function DT_Entry_Count (Id : E) return U is
begin
pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
return Uint15 (Id);
end DT_Entry_Count;
function DT_Position (Id : E) return U is
begin
pragma Assert
((Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure)
and then Present (DTC_Entity (Id)));
return Uint15 (Id);
end DT_Position;
function Entry_Bodies_Array (Id : E) return E is
begin
return Node15 (Id);
end Entry_Bodies_Array;
function Entry_Component (Id : E) return E is
begin
return Node11 (Id);
end Entry_Component;
function Entry_Index_Type (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Entry_Family);
return Etype (Discrete_Subtype_Definition (Parent (Id)));
end Entry_Index_Type;
function Entry_Index_Constant (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Entry_Index_Parameter);
return Node7 (Id);
end Entry_Index_Constant;
function Entry_Parameters_Type (Id : E) return E is
begin
return Node7 (Id);
end Entry_Parameters_Type;
function Enumeration_Pos (Id : E) return Uint is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
return Uint11 (Id);
end Enumeration_Pos;
function Enumeration_Rep (Id : E) return U is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
return Uint12 (Id);
end Enumeration_Rep;
function Enumeration_Rep_Expr (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
return Node8 (Id);
end Enumeration_Rep_Expr;
function Enum_Pos_To_Rep (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Type);
return Node14 (Id);
end Enum_Pos_To_Rep;
function Equivalent_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Class_Wide_Subtype);
return Node7 (Id);
end Equivalent_Type;
function Esize (Id : E) return Uint is
begin
return Uint12 (Id);
end Esize;
function Finalization_Chain_Entity (Id : E) return E is
begin
return Node13 (Id);
end Finalization_Chain_Entity;
function First_Entity (Id : E) return E is
begin
return Node9 (Id);
end First_Entity;
function First_Index (Id : E) return N is
begin
return Node9 (Id);
end First_Index;
function First_Literal (Id : E) return E is
begin
return Node9 (Id);
end First_Literal;
function First_Private_Entity (Id : E) return E is
begin
return Node11 (Id);
end First_Private_Entity;
function Freeze_Node (Id : E) return N is
begin
return Node18 (Id);
end Freeze_Node;
function Full_View (Id : E) return E is
begin
return Node11 (Id);
end Full_View;
function Has_Alignment_Clause (Id : E) return B is
begin
return Flag46 (Id);
end Has_Alignment_Clause;
function Has_All_Calls_Remote (Id : E) return B is
begin
return Flag79 (Id);
end Has_All_Calls_Remote;
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Id);
end Has_Atomic_Components;
function Has_Completion (Id : E) return B is
begin
return Flag26 (Id);
end Has_Completion;
function Has_Completion_In_Body (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag71 (Id);
end Has_Completion_In_Body;
function Has_Component_Size_Clause (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Array_Type);
return Flag68 (Id);
end Has_Component_Size_Clause;
function Has_Controlled (Id : E) return B is
begin
return Flag43 (Id);
end Has_Controlled;
function Has_Controlling_Result (Id : E) return B is
begin
return Flag98 (Id);
end Has_Controlling_Result;
function Has_Delayed_Freeze (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag18 (Id);
end Has_Delayed_Freeze;
function Has_Discriminants (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag5 (Id);
end Has_Discriminants;
function Has_Enumeration_Rep_Clause (Id : E) return B is
begin
pragma Assert (Is_Enumeration_Type (Id));
return Flag66 (Id);
end Has_Enumeration_Rep_Clause;
function Has_Exit (Id : E) return B is
begin
return Flag47 (Id);
end Has_Exit;
function Has_Homonym (Id : E) return B is
begin
return Flag56 (Id);
end Has_Homonym;
function Has_Master_Entity (Id : E) return B is
begin
return Flag21 (Id);
end Has_Master_Entity;
function Has_Machine_Attribute (Id : E) return B is
begin
return Flag82 (Id);
end Has_Machine_Attribute;
function Has_Machine_Radix_Clause (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
return Flag83 (Id);
end Has_Machine_Radix_Clause;
function Has_Nested_Block_With_Handler (Id : E) return B is
begin
return Flag101 (Id);
end Has_Nested_Block_With_Handler;
function Has_Non_Standard_Rep (Id : E) return B is
begin
return Flag75 (Id);
end Has_Non_Standard_Rep;
function Has_Pragma_Controlled (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag27 (Id);
end Has_Pragma_Controlled;
function Has_Record_Rep_Clause (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
return Flag65 (Id);
end Has_Record_Rep_Clause;
function Has_Size_Clause (Id : E) return B is
begin
return Flag29 (Id);
end Has_Size_Clause;
function Has_Small_Clause (Id : E) return B is
begin
return Flag67 (Id);
end Has_Small_Clause;
function Has_Specified_Layout (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
return Flag100 (Id);
end Has_Specified_Layout;
function Has_Storage_Size_Clause (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
return Flag23 (Id);
end Has_Storage_Size_Clause;
function Has_Tasks (Id : E) return B is
begin
return Flag30 (Id);
end Has_Tasks;
function Has_U_Nominal_Subtype (Id : E) return B is
begin
return Flag80 (Id);
end Has_U_Nominal_Subtype;
function Has_Unknown_Discriminants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag72 (Id);
end Has_Unknown_Discriminants;
function Has_Volatile_Components (Id : E) return B is
begin
return Flag87 (Id);
end Has_Volatile_Components;
function In_Package_Body (Id : E) return B is
begin
return Flag48 (Id);
end In_Package_Body;
function In_Private_Part (Id : E) return B is
begin
return Flag45 (Id);
end In_Private_Part;
function In_Use (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag8 (Id);
end In_Use;
function Interface_Name (Id : E) return N is
begin
return Node6 (Id);
end Interface_Name;
function Is_Abstract (Id : E) return B is
begin
return Flag19 (Id);
end Is_Abstract;
function Is_Access_Constant (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag69 (Id);
end Is_Access_Constant;
function Is_Aliased (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag15 (Id);
end Is_Aliased;
function Is_Asynchronous (Id : E) return B is
begin
pragma Assert
(Ekind (Id) = E_Procedure or else Is_Type (Id));
return Flag81 (Id);
end Is_Asynchronous;
function Is_Atomic (Id : E) return B is
begin
return Flag85 (Id);
end Is_Atomic;
function Is_Called (Id : E) return B is
begin
pragma Assert
(Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function);
return Flag102 (Id);
end Is_Called;
function Is_Character_Type (Id : E) return B is
begin
return Flag63 (Id);
end Is_Character_Type;
function Is_Constrained (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag3 (Id);
end Is_Constrained;
function Is_Constructor (Id : E) return B is
begin
return Flag76 (Id);
end Is_Constructor;
function Is_Controlled (Id : E) return B is
begin
return Flag42 (Id);
end Is_Controlled;
function Is_Controlling_Formal (Id : E) return B is
begin
pragma Assert (Ekind (Id) in Formal_Kind);
return Flag97 (Id);
end Is_Controlling_Formal;
function Is_CPP_Class (Id : E) return B is
begin
return Flag74 (Id);
end Is_CPP_Class;
function Is_Declared_In_Package_Body (Id : E) return B is
begin
return Flag93 (Id);
end Is_Declared_In_Package_Body;
function Is_Destructor (Id : E) return B is
begin
return Flag77 (Id);
end Is_Destructor;
function Is_Dispatching_Operation (Id : E) return B is
begin
pragma Assert
(Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
return Flag6 (Id);
end Is_Dispatching_Operation;
function Is_Entry_Formal (Id : E) return B is
begin
return Flag52 (Id);
end Is_Entry_Formal;
function Is_Exported (Id : E) return B is
begin
return Flag99 (Id);
end Is_Exported;
function Is_Frozen (Id : E) return B is
begin
return Flag4 (Id);
end Is_Frozen;
function Is_First_Subtype (Id : E) return B is
begin
return Flag70 (Id);
end Is_First_Subtype;
function Is_Immediately_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag7 (Id);
end Is_Immediately_Visible;
function Is_Imported (Id : E) return B is
begin
return Flag24 (Id);
end Is_Imported;
function Is_Inlined (Id : E) return B is
begin
pragma Assert
(Is_Overloadable (Id)
or else Ekind (Id) = E_Subprogram_Type
or else Ekind (Id) = E_Package);
return Flag11 (Id);
end Is_Inlined;
function Is_Internal (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag17 (Id);
end Is_Internal;
function Is_Interrupt_Handler (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag89 (Id);
end Is_Interrupt_Handler;
function Is_Intrinsic_Subprogram (Id : E) return B is
begin
return Flag64 (Id);
end Is_Intrinsic_Subprogram;
function Is_Itype (Id : E) return B is
begin
return Flag91 (Id);
end Is_Itype;
function Is_Limited_Record (Id : E) return B is
begin
return Flag25 (Id);
end Is_Limited_Record;
function Is_Named_Number (Id : E) return B is
begin
return Ekind (Id) in Named_Kind;
end Is_Named_Number;
function Is_Overloadable (Id : E) return B is
begin
return Ekind (Id) in Overloadable_Kind;
end Is_Overloadable;
function Is_Packed (Id : E) return B is
begin
return Flag51 (Id);
end Is_Packed;
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag9 (Id);
end Is_Potentially_Use_Visible;
function Is_Preelaborated (Id : E) return B is
begin
return Flag59 (Id);
end Is_Preelaborated;
function Is_Private (Id : E) return B is
begin
return Flag57 (Id);
end Is_Private;
function Is_Private_Descendant (Id : E) return B is
begin
return Flag53 (Id);
end Is_Private_Descendant;
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag10 (Id);
end Is_Public;
function Is_Pure (Id : E) return B is
begin
return Flag44 (Id);
end Is_Pure;
function Is_Remote_Call_Interface (Id : E) return B is
begin
return Flag62 (Id);
end Is_Remote_Call_Interface;
function Is_Remote_Types (Id : E) return B is
begin
return Flag61 (Id);
end Is_Remote_Types;
function Is_Shared_Passive (Id : E) return B is
begin
return Flag60 (Id);
end Is_Shared_Passive;
function Is_Subprogram (Id : E) return B is
begin
return Ekind (Id) in Subprogram_Kind;
end Is_Subprogram;
function Is_Tag (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag78 (Id);
end Is_Tag;
function Is_Volatile (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag16 (Id);
end Is_Volatile;
function Last_Entity (Id : E) return E is
begin
return Node10 (Id);
end Last_Entity;
function Lit_Name_Table (Id : E) return E is
begin
return Node7 (Id);
end Lit_Name_Table;
function Machine_Attribute (Id : E) return N is
begin
return Node17 (Id);
end Machine_Attribute;
function Machine_Radix_10 (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
return Flag84 (Id);
end Machine_Radix_10;
function Master_Id (Id : E) return E is
begin
return Node9 (Id);
end Master_Id;
function Modulus (Id : E) return Uint is
begin
return Uint9 (Id);
end Modulus;
function Needs_Discr_Check (Id : E) return B is
begin
return Flag50 (Id);
end Needs_Discr_Check;
function Needs_No_Actuals (Id : E) return B is
begin
pragma Assert
(Is_Overloadable (Id)
or else Ekind (Id) = E_Subprogram_Type
or else Ekind (Id) = E_Entry_Family);
return Flag22 (Id);
end Needs_No_Actuals;
function Next_Inlined_Subprogram (Id : E) return E is
begin
return Node12 (Id);
end Next_Inlined_Subprogram;
function Next_Itype (Id : E) return E is
begin
return Node16 (Id);
end Next_Itype;
function Non_Binary_Modulus (Id : E) return B is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
return Flag58 (Id);
end Non_Binary_Modulus;
function Object_Ref (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
return Node9 (Id);
end Object_Ref;
function Original_Record_Component (Id : E) return E is
begin
return Node8 (Id);
end Original_Record_Component;
function Packed_Array_Type (Id : E) return E is
begin
pragma Assert (Is_Array_Type (Id));
return Node14 (Id);
end Packed_Array_Type;
function Primitive_Operations (Id : E) return Elist_Id is
begin
pragma Assert (Is_Tagged_Type (Id));
return Elist13 (Id);
end Primitive_Operations;
function Prival (Id : E) return E is
begin
pragma Assert (Is_Protected_Private (Id));
return Node9 (Id);
end Prival;
function Private_Dependents (Id : E) return L is
begin
pragma Assert (Is_Private_Type (Id));
return Elist7 (Id);
end Private_Dependents;
function Protected_Body_Subprogram (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id) or else
Ekind (Id) = E_Entry or else Ekind (Id) = E_Entry_Family);
return Node11 (Id);
end Protected_Body_Subprogram;
function Protected_Formal (Id : E) return E is
begin
pragma Assert (Ekind (Id) in Formal_Kind);
return Node8 (Id);
end Protected_Formal;
function Protected_Operation (Id : E) return N is
begin
pragma Assert (Is_Protected_Private (Id));
return Node14 (Id);
end Protected_Operation;
function Reachable (Id : E) return B is
begin
return Flag49 (Id);
end Reachable;
function Renamed_Entity (Id : E) return N is
begin
return Node7 (Id);
end Renamed_Entity;
function Renamed_Object (Id : E) return N is
begin
return Node7 (Id);
end Renamed_Object;
function Return_Present (Id : E) return B is
begin
return Flag54 (Id);
end Return_Present;
function Returns_By_Ref (Id : E) return B is
begin
return Flag90 (Id);
end Returns_By_Ref;
function Scalar_Range (Id : E) return N is
begin
return Node10 (Id);
end Scalar_Range;
function Scale_Value (Id : E) return U is
begin
return Uint15 (Id);
end Scale_Value;
function Scope_Depth (Id : E) return U is
begin
return Uint8 (Id);
end Scope_Depth;
function Size_Known_At_Compile_Time (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag92 (Id);
end Size_Known_At_Compile_Time;
function Small_Value (Id : E) return R is
begin
pragma Assert (Is_Fixed_Point_Type (Id));
return Ureal6 (Id);
end Small_Value;
function Storage_Size_Variable (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
return Node15 (Id);
end Storage_Size_Variable;
function String_Literal_Length (Id : E) return Uint is
begin
return Uint11 (Id);
end String_Literal_Length;
function Suppress_Access_Checks (Id : E) return B is
begin
return Flag31 (Id);
end Suppress_Access_Checks;
function Suppress_Accessibility_Checks (Id : E) return B is
begin
return Flag32 (Id);
end Suppress_Accessibility_Checks;
function Suppress_Discriminant_Checks (Id : E) return B is
begin
return Flag33 (Id);
end Suppress_Discriminant_Checks;
function Suppress_Division_Checks (Id : E) return B is
begin
return Flag34 (Id);
end Suppress_Division_Checks;
function Suppress_Elaboration_Checks (Id : E) return B is
begin
return Flag35 (Id);
end Suppress_Elaboration_Checks;
function Suppress_Index_Checks (Id : E) return B is
begin
return Flag36 (Id);
end Suppress_Index_Checks;
function Suppress_Length_Checks (Id : E) return B is
begin
return Flag37 (Id);
end Suppress_Length_Checks;
function Suppress_Overflow_Checks (Id : E) return B is
begin
return Flag38 (Id);
end Suppress_Overflow_Checks;
function Suppress_Range_Checks (Id : E) return B is
begin
return Flag39 (Id);
end Suppress_Range_Checks;
function Suppress_Storage_Checks (Id : E) return B is
begin
return Flag40 (Id);
end Suppress_Storage_Checks;
function Suppress_Tag_Checks (Id : E) return B is
begin
return Flag41 (Id);
end Suppress_Tag_Checks;
function Table_High_Bound (Id : E) return N is
begin
return Node11 (Id);
end Table_High_Bound;
function Task_Activation_Chain_Entity (Id : E) return E is
begin
return Node14 (Id);
end Task_Activation_Chain_Entity;
function Task_Body_Procedure (Id : E) return E is
begin
return Node19 (Id);
end Task_Body_Procedure;
function Uses_Sec_Stack (Id : E) return B is
begin
return Flag95 (Id);
end Uses_Sec_Stack;
------------------------------
-- Classification Functions --
------------------------------
function Is_Access_Type (Id : E) return B is
begin
return Ekind (Id) in Access_Kind;
end Is_Access_Type;
function Is_Array_Type (Id : E) return B is
begin
return Ekind (Id) in Array_Kind;
end Is_Array_Type;
function Is_Class_Wide_Type (Id : E) return B is
begin
return Ekind (Id) in Class_Wide_Kind;
end Is_Class_Wide_Type;
function Is_Child_Unit (Id : E) return B is
begin
return Flag73 (Id);
end Is_Child_Unit;
function Is_Composite_Type (Id : E) return B is
begin
return Ekind (Id) in Composite_Kind;
end Is_Composite_Type;
function Is_Concurrent_Body (Id : E) return B is
begin
return Ekind (Id) in Concurrent_Body_Kind;
end Is_Concurrent_Body;
function Is_Concurrent_Record_Type (Id : E) return B is
begin
return Flag20 (Id);
end Is_Concurrent_Record_Type;
function Is_Concurrent_Type (Id : E) return B is
begin
return Ekind (Id) in Concurrent_Kind;
end Is_Concurrent_Type;
function Is_Decimal_Fixed_Point_Type (Id : E) return B is
begin
return Ekind (Id) in Decimal_Fixed_Point_Kind;
end Is_Decimal_Fixed_Point_Type;
function Is_Digits_Type (Id : E) return B is
begin
return Ekind (Id) in Digits_Kind;
end Is_Digits_Type;
function Is_Discrete_Type (Id : E) return B is
begin
return Ekind (Id) in Discrete_Kind;
end Is_Discrete_Type;
function Is_Elementary_Type (Id : E) return B is
begin
return Ekind (Id) in Elementary_Kind;
end Is_Elementary_Type;
function Is_Enumeration_Type (Id : E) return B is
begin
return Ekind (Id) in Enumeration_Kind;
end Is_Enumeration_Type;
function Is_Fixed_Point_Type (Id : E) return B is
begin
return Ekind (Id) in Fixed_Point_Kind;
end Is_Fixed_Point_Type;
function Is_Floating_Point_Type (Id : E) return B is
begin
return Ekind (Id) in Float_Kind;
end Is_Floating_Point_Type;
function Is_Generic_Type (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag1 (Id);
end Is_Generic_Type;
function Is_Generic_Actual_Type (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag94 (Id);
end Is_Generic_Actual_Type;
function Is_Incomplete_Or_Private_Type (Id : E) return B is
begin
return Ekind (Id) in Incomplete_Or_Private_Kind;
end Is_Incomplete_Or_Private_Type;
function Is_Integer_Type (Id : E) return B is
begin
return Ekind (Id) in Integer_Kind;
end Is_Integer_Type;
function Is_Modular_Integer_Type (Id : E) return B is
begin
return Ekind (Id) in Modular_Integer_Kind;
end Is_Modular_Integer_Type;
function Is_Numeric_Type (Id : E) return B is
begin
return Ekind (Id) in Numeric_Kind;
end Is_Numeric_Type;
function Is_Object (Id : E) return B is
begin
return Ekind (Id) in Object_Kind;
end Is_Object;
function Is_Ordinary_Fixed_Point_Type (Id : E) return B is
begin
return Ekind (Id) in Ordinary_Fixed_Point_Kind;
end Is_Ordinary_Fixed_Point_Type;
function Depends_On_Private (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag14 (Id);
end Depends_On_Private;
function Is_Private_Type (Id : E) return B is
begin
return Ekind (Id) in Private_Kind;
end Is_Private_Type;
function Is_Protected_Type (Id : E) return B is
begin
return Ekind (Id) in Protected_Kind;
end Is_Protected_Type;
function Is_Real_Type (Id : E) return B is
begin
return Ekind (Id) in Real_Kind;
end Is_Real_Type;
function Is_Record_Type (Id : E) return B is
begin
return Ekind (Id) in Record_Kind;
end Is_Record_Type;
function Is_Scalar_Type (Id : E) return B is
begin
return Ekind (Id) in Scalar_Kind;
end Is_Scalar_Type;
function Is_Signed_Integer_Type (Id : E) return B is
begin
return Ekind (Id) in Signed_Integer_Kind;
end Is_Signed_Integer_Type;
function Is_Tagged_Type (Id : E) return B is
begin
return Flag55 (Id);
end Is_Tagged_Type;
function Is_Task_Type (Id : E) return B is
begin
return Ekind (Id) in Task_Kind;
end Is_Task_Type;
function Is_Type (Id : E) return B is
begin
return Ekind (Id) in Type_Kind;
end Is_Type;
------------------------------
-- Attribute Set Procedures --
------------------------------
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist6 (Id, V);
end Set_Accept_Address;
procedure Set_Access_Disp_Table (Id : E; V : E) is
begin
pragma Assert (Is_Tagged_Type (Id));
Set_Node15 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Actual_Subtype (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable
or else Ekind (Id) = E_Generic_In_Out_Parameter
or else Ekind (Id) in E_In_Parameter .. E_In_Out_Parameter);
Set_Node9 (Id, V);
end Set_Actual_Subtype;
procedure Set_Address_Clause (Id : E; V : N) is
begin
Set_Node20 (Id, V);
end Set_Address_Clause;
procedure Set_Alias (Id : E; V : E) is
begin
pragma Assert
(Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
Set_Node7 (Id, V);
end Set_Alias;
procedure Set_Alignment_Clause (Id : E; V : N) is
begin
pragma Assert
(Is_Type (Id)
or else Ekind (Id) = E_Constant
or else Ekind (Id) = E_Variable);
Set_Node8 (Id, V);
end Set_Alignment_Clause;
procedure Set_Associated_Formal_Package (Id : E; V : E) is
begin
Set_Node12 (Id, V);
end Set_Associated_Formal_Package;
procedure Set_Associated_Storage_Pool (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Node13 (Id, V);
end Set_Associated_Storage_Pool;
procedure Set_Associated_Final_Chain (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Node14 (Id, V);
end Set_Associated_Final_Chain;
procedure Set_Barrier_Function (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Entry or else Ekind (Id) = E_Entry_Family);
Set_Node12 (Id, V);
end Set_Barrier_Function;
procedure Set_Class_Wide_Type (Id : E; V : E) is
begin
pragma Assert (Is_Type (Id));
Set_Node17 (Id, V);
end Set_Class_Wide_Type;
procedure Set_Component_Clause (Id : E; V : N) is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
Set_Node13 (Id, V);
end Set_Component_Clause;
procedure Set_Component_First_Bit (Id : E; V : U) is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
Set_Uint11 (Id, V);
end Set_Component_First_Bit;
procedure Set_Component_Size_Clause (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Array_Type);
Set_Node13 (Id, V);
end Set_Component_Size_Clause;
procedure Set_Component_Type (Id : E; V : E) is
begin
Set_Node10 (Id, V);
end Set_Component_Type;
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Record_Type and then Is_Concurrent_Type (V));
Set_Node7 (Id, V);
end Set_Corresponding_Concurrent_Type;
procedure Set_Corresponding_Discriminant (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Discriminant);
Set_Node7 (Id, V);
end Set_Corresponding_Discriminant;
procedure Set_Corresponding_Record_Type (Id : E; V : E) is
begin
pragma Assert (Is_Concurrent_Type (Id));
Set_Node7 (Id, V);
end Set_Corresponding_Record_Type;
procedure Set_Default_Value (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_In_Parameter);
Set_Node10 (Id, V);
end Set_Default_Value;
procedure Set_Delta_Value (Id : E; V : R) is
begin
pragma Assert (Is_Fixed_Point_Type (Id));
Set_Ureal7 (Id, V);
end Set_Delta_Value;
procedure Set_Digits_Value (Id : E; V : U) is
begin
pragma Assert
(Is_Floating_Point_Type (Id)
or else Is_Decimal_Fixed_Point_Type (Id));
Set_Uint9 (Id, V);
end Set_Digits_Value;
procedure Set_Directly_Designated_Type (Id : E; V : E) is
begin
Set_Node10 (Id, V);
end Set_Directly_Designated_Type;
procedure Set_Discard_Names (Id : E; V : B := True) is
begin
Set_Flag88 (Id, V);
end Set_Discard_Names;
procedure Set_Discriminal (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Discriminant);
Set_Node9 (Id, V);
end Set_Discriminal;
procedure Set_Discriminant_Checking_Func (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Component and Ekind (Scope (Id)) in Record_Kind);
Set_Node10 (Id, V);
end Set_Discriminant_Checking_Func;
procedure Set_Discriminant_Constraint (Id : E; V : L) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Elist6 (Id, V);
end Set_Discriminant_Constraint;
procedure Set_Discriminant_Default_Value (Id : E; V : N) is
begin
Set_Node10 (Id, V);
end Set_Discriminant_Default_Value;
procedure Set_DTC_Entity (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
Set_Node16 (Id, V);
end Set_DTC_Entity;
procedure Set_DT_Entry_Count (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Component);
Set_Uint15 (Id, V);
end Set_DT_Entry_Count;
procedure Set_DT_Position (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
Set_Uint15 (Id, V);
end Set_DT_Position;
procedure Set_Entry_Bodies_Array (Id : E; V : E) is
begin
Set_Node15 (Id, V);
end Set_Entry_Bodies_Array;
procedure Set_Entry_Component (Id : E; V : E) is
begin
Set_Node11 (Id, V);
end Set_Entry_Component;
procedure Set_Entry_Index_Constant (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Entry_Index_Parameter);
Set_Node7 (Id, V);
end Set_Entry_Index_Constant;
procedure Set_Entry_Parameters_Type (Id : E; V : E) is
begin
Set_Node7 (Id, V);
end Set_Entry_Parameters_Type;
procedure Set_Enumeration_Pos (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
Set_Uint11 (Id, V);
end Set_Enumeration_Pos;
procedure Set_Enumeration_Rep (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
Set_Uint12 (Id, V);
end Set_Enumeration_Rep;
procedure Set_Enumeration_Rep_Expr (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Literal);
Set_Node8 (Id, V);
end Set_Enumeration_Rep_Expr;
procedure Set_Enum_Pos_To_Rep (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Enumeration_Type);
Set_Node14 (Id, V);
end Set_Enum_Pos_To_Rep;
procedure Set_Equivalent_Type (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Class_Wide_Subtype);
Set_Node7 (Id, V);
end Set_Equivalent_Type;
procedure Set_Esize (Id : E; V : U) is
begin
Set_Uint12 (Id, V);
end Set_Esize;
procedure Set_Finalization_Chain_Entity (Id : E; V : E) is
begin
Set_Node13 (Id, V);
end Set_Finalization_Chain_Entity;
procedure Set_First_Entity (Id : E; V : E) is
begin
Set_Node9 (Id, V);
end Set_First_Entity;
procedure Set_First_Index (Id : E; V : N) is
begin
Set_Node9 (Id, V);
end Set_First_Index;
procedure Set_First_Literal (Id : E; V : E) is
begin
Set_Node9 (Id, V);
end Set_First_Literal;
procedure Set_First_Private_Entity (Id : E; V : E) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Node11 (Id, V);
end Set_First_Private_Entity;
procedure Set_Freeze_Node (Id : E; V : N) is
begin
Set_Node18 (Id, V);
end Set_Freeze_Node;
procedure Set_Full_View (Id : E; V : E) is
begin
Set_Node11 (Id, V);
end Set_Full_View;
procedure Set_Has_Alignment_Clause (Id : E; V : B := True) is
begin
Set_Flag46 (Id, V);
end Set_Has_Alignment_Clause;
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True) is
begin
Set_Flag79 (Id, V);
end Set_Has_All_Calls_Remote;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
Set_Flag86 (Id, V);
end Set_Has_Atomic_Components;
procedure Set_Has_Completion (Id : E; V : B := True) is
begin
Set_Flag26 (Id, V);
end Set_Has_Completion;
procedure Set_Has_Completion_In_Body (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Incomplete_Type);
Set_Flag71 (Id, V);
end Set_Has_Completion_In_Body;
procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Array_Type);
Set_Flag68 (Id, V);
end Set_Has_Component_Size_Clause;
procedure Set_Has_Controlled (Id : E; V : B := True) is
begin
Set_Flag43 (Id, V);
end Set_Has_Controlled;
procedure Set_Has_Controlling_Result (Id : E; V : B := True) is
begin
Set_Flag98 (Id, V);
end Set_Has_Controlling_Result;
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag18 (Id, V);
end Set_Has_Delayed_Freeze;
procedure Set_Has_Discriminants (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag5 (Id, V);
end Set_Has_Discriminants;
procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Enumeration_Type (Id));
Set_Flag66 (Id, V);
end Set_Has_Enumeration_Rep_Clause;
procedure Set_Has_Exit (Id : E; V : B := True) is
begin
Set_Flag47 (Id, V);
end Set_Has_Exit;
procedure Set_Has_Homonym (Id : E; V : B := True) is
begin
Set_Flag56 (Id, V);
end Set_Has_Homonym;
procedure Set_Has_Master_Entity (Id : E; V : B := True) is
begin
Set_Flag21 (Id, V);
end Set_Has_Master_Entity;
procedure Set_Has_Machine_Attribute (Id : E; V : B := True) is
begin
Set_Flag82 (Id, V);
end Set_Has_Machine_Attribute;
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
Set_Flag83 (Id, V);
end Set_Has_Machine_Radix_Clause;
procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True) is
begin
Set_Flag101 (Id, V);
end Set_Has_Nested_Block_With_Handler;
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is
begin
Set_Flag75 (Id, V);
end Set_Has_Non_Standard_Rep;
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Flag27 (Id, V);
end Set_Has_Pragma_Controlled;
procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Record_Type (Id));
Set_Flag65 (Id, V);
end Set_Has_Record_Rep_Clause;
procedure Set_Has_Size_Clause (Id : E; V : B := True) is
begin
Set_Flag29 (Id, V);
end Set_Has_Size_Clause;
procedure Set_Has_Small_Clause (Id : E; V : B := True) is
begin
Set_Flag67 (Id, V);
end Set_Has_Small_Clause;
procedure Set_Has_Specified_Layout (Id : E; V : B := True) is
begin
pragma Assert (Is_Record_Type (Id));
Set_Flag100 (Id, V);
end Set_Has_Specified_Layout;
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
Set_Flag23 (Id, V);
end Set_Has_Storage_Size_Clause;
procedure Set_Has_Tasks (Id : E; V : B := True) is
begin
Set_Flag30 (Id, V);
end Set_Has_Tasks;
procedure Set_Has_U_Nominal_Subtype (Id : E; V : B := True) is
begin
Set_Flag80 (Id, V);
end Set_Has_U_Nominal_Subtype;
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag72 (Id, V);
end Set_Has_Unknown_Discriminants;
procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
begin
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
end Set_In_Package_Body;
procedure Set_In_Private_Part (Id : E; V : B := True) is
begin
Set_Flag45 (Id, V);
end Set_In_Private_Part;
procedure Set_In_Use (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag8 (Id, V);
end Set_In_Use;
procedure Set_Interface_Name (Id : E; V : N) is
begin
Set_Node6 (Id, V);
end Set_Interface_Name;
procedure Set_Is_Abstract (Id : E; V : B := True) is
begin
Set_Flag19 (Id, V);
end Set_Is_Abstract;
procedure Set_Is_Access_Constant (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Flag69 (Id, V);
end Set_Is_Access_Constant;
procedure Set_Is_Aliased (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag15 (Id, V);
end Set_Is_Aliased;
procedure Set_Is_Asynchronous (Id : E; V : B := True) is
begin
pragma Assert
(Ekind (Id) = E_Procedure or else Is_Type (Id));
Set_Flag81 (Id, V);
end Set_Is_Asynchronous;
procedure Set_Is_Atomic (Id : E; V : B := True) is
begin
Set_Flag85 (Id, V);
end Set_Is_Atomic;
procedure Set_Is_Called (Id : E; V : B := True) is
begin
pragma Assert
(Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function);
Set_Flag102 (Id, V);
end Set_Is_Called;
procedure Set_Is_Character_Type (Id : E; V : B := True) is
begin
Set_Flag63 (Id, V);
end Set_Is_Character_Type;
procedure Set_Is_Child_Unit (Id : E; V : B := True) is
begin
Set_Flag73 (Id, V);
end Set_Is_Child_Unit;
procedure Set_Is_Constrained (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag3 (Id, V);
end Set_Is_Constrained;
procedure Set_Is_Constructor (Id : E; V : B := True) is
begin
Set_Flag76 (Id, V);
end Set_Is_Constructor;
procedure Set_Is_Controlled (Id : E; V : B := True) is
begin
Set_Flag42 (Id, V);
end Set_Is_Controlled;
procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) in Formal_Kind);
Set_Flag97 (Id, V);
end Set_Is_Controlling_Formal;
procedure Set_Is_CPP_Class (Id : E; V : B := True) is
begin
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
procedure Set_Is_Declared_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag93 (Id, V);
end Set_Is_Declared_In_Package_Body;
procedure Set_Is_Destructor (Id : E; V : B := True) is
begin
Set_Flag77 (Id, V);
end Set_Is_Destructor;
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True) is
begin
pragma Assert
(Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
Set_Flag6 (Id, V);
end Set_Is_Dispatching_Operation;
procedure Set_Is_Entry_Formal (Id : E; V : B := True) is
begin
Set_Flag52 (Id, V);
end Set_Is_Entry_Formal;
procedure Set_Is_Exported (Id : E; V : B := True) is
begin
Set_Flag99 (Id, V);
end Set_Is_Exported;
procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin
Set_Flag70 (Id, V);
end Set_Is_First_Subtype;
procedure Set_Is_Frozen (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag4 (Id, V);
end Set_Is_Frozen;
procedure Set_Is_Generic_Type (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag1 (Id, V);
end Set_Is_Generic_Type;
procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag94 (Id, V);
end Set_Is_Generic_Actual_Type;
procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag7 (Id, V);
end Set_Is_Immediately_Visible;
procedure Set_Is_Imported (Id : E; V : B := True) is
begin
Set_Flag24 (Id, V);
end Set_Is_Imported;
procedure Set_Is_Inlined (Id : E; V : B := True) is
begin
pragma Assert
(Is_Overloadable (Id)
or else Ekind (Id) = E_Subprogram_Type
or else Ekind (Id) = E_Package);
Set_Flag11 (Id, V);
end Set_Is_Inlined;
procedure Set_Is_Internal (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag17 (Id, V);
end Set_Is_Internal;
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag89 (Id, V);
end Set_Is_Interrupt_Handler;
procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True) is
begin
Set_Flag64 (Id, V);
end Set_Is_Intrinsic_Subprogram;
procedure Set_Is_Itype (Id : E; V : B := True) is
begin
Set_Flag91 (Id, V);
end Set_Is_Itype;
procedure Set_Is_Limited_Record (Id : E; V : B := True) is
begin
Set_Flag25 (Id, V);
end Set_Is_Limited_Record;
procedure Set_Is_Packed (Id : E; V : B := True) is
begin
Set_Flag51 (Id, V);
end Set_Is_Packed;
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag9 (Id, V);
end Set_Is_Potentially_Use_Visible;
procedure Set_Is_Preelaborated (Id : E; V : B := True) is
begin
Set_Flag59 (Id, V);
end Set_Is_Preelaborated;
procedure Set_Is_Private (Id : E; V : B := True) is
begin
Set_Flag57 (Id, V);
end Set_Is_Private;
procedure Set_Is_Private_Descendant (Id : E; V : B := True) is
begin
Set_Flag53 (Id, V);
end Set_Is_Private_Descendant;
procedure Set_Depends_On_Private (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag14 (Id, V);
end Set_Depends_On_Private;
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag10 (Id, V);
end Set_Is_Public;
procedure Set_Is_Pure (Id : E; V : B := True) is
begin
Set_Flag44 (Id, V);
end Set_Is_Pure;
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is
begin
Set_Flag62 (Id, V);
end Set_Is_Remote_Call_Interface;
procedure Set_Is_Remote_Types (Id : E; V : B := True) is
begin
Set_Flag61 (Id, V);
end Set_Is_Remote_Types;
procedure Set_Is_Shared_Passive (Id : E; V : B := True) is
begin
Set_Flag60 (Id, V);
end Set_Is_Shared_Passive;
procedure Set_Is_Tagged_Type (Id : E; V : B := True) is
begin
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True) is
begin
Set_Flag20 (Id, V);
end Set_Is_Concurrent_Record_Type;
procedure Set_Is_Tag (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag78 (Id, V);
end Set_Is_Tag;
procedure Set_Is_Volatile (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag16 (Id, V);
end Set_Is_Volatile;
procedure Set_Last_Entity (Id : E; V : E) is
begin
Set_Node10 (Id, V);
end Set_Last_Entity;
procedure Set_Lit_Name_Table (Id : E; V : E) is
begin
Set_Node7 (Id, V);
end Set_Lit_Name_Table;
procedure Set_Machine_Attribute (Id : E; V : N) is
begin
Set_Node17 (Id, V);
end Set_Machine_Attribute;
procedure Set_Machine_Radix_10 (Id : E; V : B := True) is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
Set_Flag84 (Id, V);
end Set_Machine_Radix_10;
procedure Set_Master_Id (Id : E; V : E) is
begin
Set_Node9 (Id, V);
end Set_Master_Id;
procedure Set_Modulus (Id : E; V : U) is
begin
Set_Uint9 (Id, V);
end Set_Modulus;
procedure Set_Needs_Discr_Check (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Component);
Set_Flag50 (Id, V);
end Set_Needs_Discr_Check;
procedure Set_Needs_No_Actuals (Id : E; V : B := True) is
begin
pragma Assert
(Is_Overloadable (Id)
or else Ekind (Id) = E_Subprogram_Type
or else Ekind (Id) = E_Entry_Family);
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is
begin
Set_Node12 (Id, V);
end Set_Next_Inlined_Subprogram;
procedure Set_Next_Itype (Id : E; V : E) is
begin
Set_Node16 (Id, V);
end Set_Next_Itype;
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
procedure Set_Object_Ref (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
Set_Node9 (Id, V);
end Set_Object_Ref;
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
Set_Node8 (Id, V);
end Set_Original_Record_Component;
procedure Set_Packed_Array_Type (Id : E; V : E) is
begin
pragma Assert (Is_Array_Type (Id));
Set_Node14 (Id, V);
end Set_Packed_Array_Type;
procedure Set_Primitive_Operations (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id));
Set_Elist13 (Id, V);
end Set_Primitive_Operations;
procedure Set_Prival (Id : E; V : E) is
begin
pragma Assert (Is_Protected_Private (Id));
Set_Node9 (Id, V);
end Set_Prival;
procedure Set_Private_Dependents (Id : E; V : L) is
begin
pragma Assert (Is_Private_Type (Id));
Set_Elist7 (Id, V);
end Set_Private_Dependents;
procedure Set_Protected_Body_Subprogram (Id : E; V : E) is
begin
pragma Assert (Is_Subprogram (Id) or else
Ekind (Id) = E_Entry or else Ekind (Id) = E_Entry_Family);
Set_Node11 (Id, V);
end Set_Protected_Body_Subprogram;
procedure Set_Protected_Formal (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) in Formal_Kind);
Set_Node8 (Id, V);
end Set_Protected_Formal;
procedure Set_Protected_Operation (Id : E; V : N) is
begin
pragma Assert (Is_Protected_Private (Id));
Set_Node14 (Id, V);
end Set_Protected_Operation;
procedure Set_Reachable (Id : E; V : B := True) is
begin
Set_Flag49 (Id, V);
end Set_Reachable;
procedure Set_Renamed_Entity (Id : E; V : N) is
begin
Set_Node7 (Id, V);
end Set_Renamed_Entity;
procedure Set_Renamed_Object (Id : E; V : N) is
begin
Set_Node7 (Id, V);
end Set_Renamed_Object;
procedure Set_Return_Present (Id : E; V : B := True) is
begin
Set_Flag54 (Id, V);
end Set_Return_Present;
procedure Set_Returns_By_Ref (Id : E; V : B := True) is
begin
Set_Flag90 (Id, V);
end Set_Returns_By_Ref;
procedure Set_Scalar_Range (Id : E; V : N) is
begin
Set_Node10 (Id, V);
end Set_Scalar_Range;
procedure Set_Scale_Value (Id : E; V : U) is
begin
Set_Uint15 (Id, V);
end Set_Scale_Value;
procedure Set_Scope_Depth (Id : E; V : U) is
begin
Set_Uint8 (Id, V);
end Set_Scope_Depth;
procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag92 (Id, V);
end Set_Size_Known_At_Compile_Time;
procedure Set_Small_Value (Id : E; V : R) is
begin
pragma Assert (Is_Fixed_Point_Type (Id));
Set_Ureal6 (Id, V);
end Set_Small_Value;
procedure Set_Storage_Size_Variable (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
Set_Node15 (Id, V);
end Set_Storage_Size_Variable;
procedure Set_String_Literal_Length (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_String_Literal_Subtype);
Set_Uint11 (Id, V);
end Set_String_Literal_Length;
procedure Set_Suppress_Access_Checks (Id : E; V : B := True) is
begin
Set_Flag31 (Id, V);
end Set_Suppress_Access_Checks;
procedure Set_Suppress_Accessibility_Checks (Id : E; V : B := True) is
begin
Set_Flag32 (Id, V);
end Set_Suppress_Accessibility_Checks;
procedure Set_Suppress_Discriminant_Checks (Id : E; V : B := True) is
begin
Set_Flag33 (Id, V);
end Set_Suppress_Discriminant_Checks;
procedure Set_Suppress_Division_Checks (Id : E; V : B := True) is
begin
Set_Flag34 (Id, V);
end Set_Suppress_Division_Checks;
procedure Set_Suppress_Elaboration_Checks (Id : E; V : B := True) is
begin
Set_Flag35 (Id, V);
end Set_Suppress_Elaboration_Checks;
procedure Set_Suppress_Index_Checks (Id : E; V : B := True) is
begin
Set_Flag36 (Id, V);
end Set_Suppress_Index_Checks;
procedure Set_Suppress_Length_Checks (Id : E; V : B := True) is
begin
Set_Flag37 (Id, V);
end Set_Suppress_Length_Checks;
procedure Set_Suppress_Overflow_Checks (Id : E; V : B := True) is
begin
Set_Flag38 (Id, V);
end Set_Suppress_Overflow_Checks;
procedure Set_Suppress_Range_Checks (Id : E; V : B := True) is
begin
Set_Flag39 (Id, V);
end Set_Suppress_Range_Checks;
procedure Set_Suppress_Storage_Checks (Id : E; V : B := True) is
begin
Set_Flag40 (Id, V);
end Set_Suppress_Storage_Checks;
procedure Set_Suppress_Tag_Checks (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
end Set_Suppress_Tag_Checks;
procedure Set_Table_High_Bound (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Enum_Table_Type);
Set_Node11 (Id, V);
end Set_Table_High_Bound;
procedure Set_Task_Activation_Chain_Entity (Id : E; V : E) is
begin
Set_Node14 (Id, V);
end Set_Task_Activation_Chain_Entity;
procedure Set_Task_Body_Procedure (Id : E; V : E) is
begin
Set_Node19 (Id, V);
end Set_Task_Body_Procedure;
procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is
begin
Set_Flag95 (Id, V);
end Set_Uses_Sec_Stack;
----------------------
-- Ancestor_Subtype --
----------------------
function Ancestor_Subtype (Id : E) return E is
begin
-- If this is first subtype, or is a base type, then there is no
-- ancestor subtype, so we return Empty to indicate this fact.
if Is_First_Subtype (Id)
or else Id = Base_Type (Id)
then
return Empty;
end if;
declare
D : constant Node_Id := Declaration_Node (Id);
begin
-- If we have a subtype declaration, get the ancestor subtype
if Nkind (D) = N_Subtype_Declaration then
if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
return Entity (Subtype_Mark (Subtype_Indication (D)));
else
return Entity (Subtype_Indication (D));
end if;
-- If not, then no subtype indication is available
else
return Empty;
end if;
end;
end Ancestor_Subtype;
-------------------
-- Append_Entity --
-------------------
procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is
begin
if Last_Entity (V) = Empty then
Set_First_Entity (V, Id);
else
Set_Next_Entity (Last_Entity (V), Id);
end if;
Set_Next_Entity (Id, Empty);
Set_Scope (Id, V);
Set_Last_Entity (V, Id);
end Append_Entity;
---------------
-- Base_Type --
---------------
function Base_Type (Id : E) return E is
begin
case Ekind (Id) is
when E_Enumeration_Subtype |
E_Signed_Integer_Subtype |
E_Modular_Integer_Subtype |
E_Floating_Point_Subtype |
E_Ordinary_Fixed_Point_Subtype |
E_Decimal_Fixed_Point_Subtype |
E_Array_Subtype |
E_String_Subtype |
E_Record_Subtype |
E_Private_Subtype |
E_Record_Subtype_With_Private |
E_Limited_Private_Subtype |
E_Access_Subtype |
E_Protected_Subtype |
E_Task_Subtype |
E_String_Literal_Subtype |
E_Class_Wide_Subtype =>
return Etype (Id);
when others =>
return Id;
end case;
end Base_Type;
--------------------
-- Constant_Value --
--------------------
function Constant_Value (Id : E) return N is
begin
pragma Assert (Nkind (Id) in N_Entity);
if Nkind (Parent (Id)) = N_Object_Renaming_Declaration then
return Renamed_Object (Id);
else
if Present (Expression (Parent (Id))) then
return (Expression (Parent (Id)));
elsif Present (Full_View (Id)) then
return (Expression (Parent (Full_View (Id))));
else
return Empty;
end if;
end if;
end Constant_Value;
----------------------
-- Declaration_Node --
----------------------
function Declaration_Node (Id : E) return N is
P : Node_Id;
begin
if Ekind (Id) = E_Incomplete_Type
and then Present (Full_View (Id))
then
P := Parent (Full_View (Id));
else
P := Parent (Id);
end if;
loop
if Nkind (P) /= N_Selected_Component
and then Nkind (P) /= N_Expanded_Name
then
return P;
else
P := Parent (P);
end if;
end loop;
end Declaration_Node;
---------------------
-- Designated_Type --
---------------------
function Designated_Type (Id : E) return E is
Desig_Type : E;
begin
Desig_Type := Directly_Designated_Type (Id);
if (Ekind (Desig_Type) = E_Incomplete_Type
and then Present (Full_View (Desig_Type)))
then
return Full_View (Desig_Type);
elsif Is_Class_Wide_Type (Desig_Type)
and then Ekind (Etype (Desig_Type)) = E_Incomplete_Type
and then Present (Full_View (Etype (Desig_Type)))
then
return Class_Wide_Type (Full_View (Etype (Desig_Type)));
else
return Desig_Type;
end if;
end Designated_Type;
---------------------
-- First_Component --
---------------------
function First_Component (Id : E) return E is
Comp_Id : E;
begin
pragma Assert
(Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
Comp_Id := First_Entity (Id);
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
end loop;
return Comp_Id;
end First_Component;
------------------------
-- First_Discriminant --
------------------------
function First_Discriminant (Id : E) return E is
Ent : Entity_Id;
begin
pragma Assert (Has_Discriminants (Id));
Ent := First_Entity (Id);
if Chars (Ent) = Name_uTag then
pragma Assert (Is_Tagged_Type (Id));
return Next_Entity (Ent);
else
return Ent;
end if;
end First_Discriminant;
------------------
-- First_Formal --
------------------
function First_Formal (Id : E) return E is
Formal : E;
begin
pragma Assert
(Is_Overloadable (Id)
or else Ekind (Id) = E_Entry_Family
or else Ekind (Id) = E_Subprogram_Type);
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
else
Formal := First_Entity (Id);
if Present (Formal) and then Ekind (Formal) in Formal_Kind then
return Formal;
else
return Empty;
end if;
end if;
end First_Formal;
-------------------
-- First_Subtype --
-------------------
function First_Subtype (Id : E) return E is
B : constant Entity_Id := Base_Type (Id);
F : constant Node_Id := Freeze_Node (B);
Ent : Entity_Id;
begin
-- If the base type has no freeze node, it is a type in standard,
-- and always acts as its own first subtype
if No (F) then
return B;
-- Otherwise we check the freeze node, if it has a First_Subtype_Link
-- then we use that link, otherwise (happens with some Itypes), we use
-- the base type itself.
else
Ent := First_Subtype_Link (F);
if Present (Ent) then
return Ent;
else
return B;
end if;
end if;
end First_Subtype;
-----------------
-- Has_Entries --
-----------------
function Has_Entries (Id : E) return B is
Result : Boolean := False;
Ent : Entity_Id;
begin
pragma Assert (Is_Concurrent_Type (Id));
Ent := First_Entity (Id);
while Present (Ent) loop
if Ekind (Ent) = E_Entry or else Ekind (Ent) = E_Entry_Family then
Result := True;
exit;
end if;
Ent := Next_Entity (Ent);
end loop;
return Result;
end Has_Entries;
----------------------------
-- Has_Foreign_Convention --
----------------------------
function Has_Foreign_Convention (Id : E) return B is
begin
return Convention (Id) >= Foreign_Convention'First;
end Has_Foreign_Convention;
---------------------
-- Is_Boolean_Type --
---------------------
function Is_Boolean_Type (Id : E) return B is
begin
return Root_Type (Id) = Standard_Boolean;
end Is_Boolean_Type;
---------------------
-- Is_By_Copy_Type --
---------------------
function Is_By_Copy_Type (Id : E) return B is
begin
-- If Id is a private type whose full declaration has not been seen,
-- we assume for now that it is not a By_Copy type. Clearly this
-- attribute should not be used before the type is frozen, but it is
-- needed to build the associated record of a protected type. Another
-- place where some lookahead for a full view is needed ???
return
Is_Elementary_Type (Id)
or else (Is_Private_Type (Id)
and then Present (Underlying_Type (Id))
and then Is_Elementary_Type (Underlying_Type (Id)));
end Is_By_Copy_Type;
---------------------
-- Is_Derived_Type --
---------------------
function Is_Derived_Type (Id : E) return B is
begin
return Base_Type (Id) /= Root_Type (Id)
and not Is_Generic_Type (Id)
and not Is_Class_Wide_Type (Id);
end Is_Derived_Type;
------------------------
-- Is_Indefinite_Subtype --
------------------------
function Is_Indefinite_Subtype (Id : Entity_Id) return B is
K : constant Entity_Kind := Ekind (Id);
begin
if Is_Constrained (Id) then
return False;
elsif K in Array_Kind
or else K in Class_Wide_Kind
or else Has_Unknown_Discriminants (Id)
then
return True;
-- Known discriminants: indefinite if there are no default values
elsif K in Record_Kind
or else Is_Incomplete_Or_Private_Type (Id)
then
return (Has_Discriminants (Id)
and then No (Discriminant_Default_Value (First_Discriminant (Id))));
else
return False;
end if;
end Is_Indefinite_Subtype;
---------------------
-- Is_Limited_Type --
---------------------
function Is_Limited_Type (Id : E) return B is
Btype : constant E := Base_Type (Id);
begin
if Ekind (Btype) = E_Limited_Private_Type then
return True;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
if Is_Limited_Record (Btype) then
return True;
elsif Is_Class_Wide_Type (Btype) then
return Is_Limited_Type (Root_Type (Btype));
else
declare
C : E := First_Component (Btype);
begin
while Present (C) loop
if Is_Limited_Type (Etype (C)) then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Limited_Type (Component_Type (Btype));
else
return False;
end if;
end Is_Limited_Type;
--------------------------
-- Is_Protected_Private --
--------------------------
function Is_Protected_Private (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Component);
return Is_Protected_Type (Scope (Id));
end Is_Protected_Private;
------------------------------
-- Is_Protected_Record_Type --
------------------------------
function Is_Protected_Record_Type (Id : E) return B is
begin
return
Is_Concurrent_Record_Type (Id)
and then Is_Protected_Type (Corresponding_Concurrent_Type (Id));
end Is_Protected_Record_Type;
---------------------------------
-- Is_Return_By_Reference_Type --
---------------------------------
function Is_Return_By_Reference_Type (Id : E) return B is
Btype : constant E := Base_Type (Id);
begin
if Is_Private_Type (Btype) then
declare
Utyp : constant E := Underlying_Type (Btype);
begin
if No (Utyp) then
return False;
else
return Is_Return_By_Reference_Type (Utyp);
end if;
end;
elsif Is_Concurrent_Type (Btype) then
return True;
elsif Is_Record_Type (Btype) then
if Is_Limited_Record (Btype) then
return True;
elsif Is_Class_Wide_Type (Btype) then
return Is_Return_By_Reference_Type (Root_Type (Btype));
else
declare
C : E := First_Component (Btype);
begin
while Present (C) loop
if Is_Return_By_Reference_Type (Etype (C)) then
return True;
end if;
C := Next_Component (C);
end loop;
end;
return False;
end if;
elsif Is_Array_Type (Btype) then
return Is_Return_By_Reference_Type (Component_Type (Btype));
else
return False;
end if;
end Is_Return_By_Reference_Type;
-------------------------
-- Is_Task_Record_Type --
-------------------------
function Is_Task_Record_Type (Id : E) return B is
begin
return
Is_Concurrent_Record_Type (Id)
and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
end Is_Task_Record_Type;
--------------------
-- Is_String_Type --
--------------------
function Is_String_Type (Id : E) return B is
begin
return Ekind (Id) in String_Kind
or else (Is_Array_Type (Id)
and then Number_Dimensions (Id) = 1
and then Is_Character_Type (Component_Type (Id)));
end Is_String_Type;
--------------------
-- Next_Component --
--------------------
function Next_Component (Id : E) return E is
Comp_Id : E;
begin
Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
end loop;
return Comp_Id;
end Next_Component;
-----------------------
-- Next_Discriminant --
-----------------------
function Next_Discriminant (Id : E) return E is
D : constant E := Next_Entity (Id);
begin
pragma Assert (Ekind (Id) = E_Discriminant);
if Present (D) and then Ekind (D) = E_Discriminant then
return D;
else
return Empty;
end if;
end Next_Discriminant;
-----------------
-- Next_Formal --
-----------------
function Next_Formal (Id : E) return E is
P : E;
begin
-- Follow the chain of declared entities as long as the kind of
-- the entity corresponds to a formal parameter. Skip internal
-- entities that may have been created for implicit subtypes,
-- in the process of analyzing default expressions.
P := Id;
loop
P := Next_Entity (P);
if No (P) or else Ekind (P) in Formal_Kind then
return P;
elsif not Is_Internal (P) then
return Empty;
end if;
end loop;
end Next_Formal;
----------------
-- Next_Index --
----------------
function Next_Index (Id : Node_Id) return Node_Id is
begin
return Next (Id);
end Next_Index;
------------------
-- Next_Literal --
------------------
function Next_Literal (Id : E) return E is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Next (Id);
end Next_Literal;
--------------------
-- Next_Overloads --
--------------------
function Next_Overloads (Id : E) return E is
begin
pragma Assert
(Is_Overloadable (Id) or else Ekind (Id) = E_Subprogram_Type);
return Homonym (Id);
end Next_Overloads;
-----------------------
-- Number_Dimensions --
-----------------------
function Number_Dimensions (Id : E) return Pos is
N : Int;
T : Node_Id;
begin
N := 0;
T := First_Index (Id);
while Present (T) loop
N := N + 1;
T := Next (T);
end loop;
return N;
end Number_Dimensions;
--------------------------
-- Number_Discriminants --
--------------------------
function Number_Discriminants (Id : E) return Pos is
N : Int;
Discr : Entity_Id;
begin
N := 0;
Discr := First_Discriminant (Id);
while Present (Discr) loop
N := N + 1;
Discr := Next_Discriminant (Discr);
end loop;
return N;
end Number_Discriminants;
--------------------
-- Parameter_Mode --
--------------------
function Parameter_Mode (Id : E) return Formal_Kind is
begin
return Ekind (Id);
end Parameter_Mode;
---------------
-- Root_Type --
---------------
function Root_Type (Id : E) return E is
T : E;
begin
pragma Assert (Nkind (Id) in N_Entity);
T := Base_Type (Id);
if Ekind (T) = E_Class_Wide_Type then
return Etype (T);
else
while T /= Etype (T) loop
T := Etype (T);
end loop;
return T;
end if;
end Root_Type;
------------------
-- Subtype_Kind --
------------------
function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
Kind : Entity_Kind;
begin
case K is
when Access_Kind => Kind := E_Access_Subtype;
when E_Array_Type |
E_Array_Subtype => Kind := E_Array_Subtype;
when E_Class_Wide_Type |
E_Class_Wide_Subtype => Kind := E_Class_Wide_Subtype;
when E_Decimal_Fixed_Point_Type |
E_Decimal_Fixed_Point_Subtype
=> Kind :=
E_Decimal_Fixed_Point_Subtype;
when E_Ordinary_Fixed_Point_Type |
E_Ordinary_Fixed_Point_Subtype
=> Kind :=
E_Ordinary_Fixed_Point_Subtype;
when E_Private_Type |
E_Private_Subtype => Kind := E_Private_Subtype;
when E_Limited_Private_Type |
E_Limited_Private_Subtype => Kind := E_Limited_Private_Subtype;
when E_Record_Type_With_Private |
E_Record_Subtype_With_Private
=> Kind := E_Record_Subtype_With_Private;
when E_Record_Type |
E_Record_Subtype => Kind := E_Record_Subtype;
when E_String_Type |
E_String_Subtype => Kind := E_String_Subtype;
when Enumeration_Kind => Kind := E_Enumeration_Subtype;
when Float_Kind => Kind := E_Floating_Point_Subtype;
when Signed_Integer_Kind => Kind := E_Signed_Integer_Subtype;
when Modular_Integer_Kind => Kind := E_Modular_Integer_Subtype;
when Protected_Kind => Kind := E_Protected_Subtype;
when Task_Kind => Kind := E_Task_Subtype;
when others =>
pragma Assert (False); null;
end case;
return Kind;
end Subtype_Kind;
-------------------
-- Tag_Component --
-------------------
function Tag_Component (Id : E) return E is
Comp : Entity_Id;
Typ : Entity_Id := Id;
begin
pragma Assert (Is_Tagged_Type (Typ));
if Is_Class_Wide_Type (Typ) then
Typ := Root_Type (Typ);
end if;
if Is_Private_Type (Typ) then
Typ := Underlying_Type (Typ);
end if;
Comp := First_Entity (Typ);
while Present (Comp) loop
if Is_Tag (Comp) then
return Comp;
end if;
Comp := Next_Entity (Comp);
end loop;
-- no tag component found
return Empty;
end Tag_Component;
---------------------
-- Type_High_Bound --
---------------------
function Type_High_Bound (Id : E) return Node_Id is
begin
return High_Bound (Scalar_Range (Id));
end Type_High_Bound;
--------------------
-- Type_Low_Bound --
--------------------
function Type_Low_Bound (Id : E) return Node_Id is
begin
return Low_Bound (Scalar_Range (Id));
end Type_Low_Bound;
---------------------
-- Underlying_Type --
---------------------
function Underlying_Type (Id : E) return E is
begin
-- For record_with_private the underlying type is always the direct
-- full view. Never try to take the full view of the parent it
-- doesn't make sense.
if Ekind (Id) = E_Record_Type_With_Private then
return Full_View (Id);
elsif Ekind (Id) in Incomplete_Or_Private_Kind then
-- If we have an incomplete or private type with a full view,
-- then we return the Underlying_Type of this full view
if Present (Full_View (Id)) then
return Underlying_Type (Full_View (Id));
-- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type.
elsif Etype (Id) /= Id then
return Underlying_Type (Etype (Id));
-- Otherwise we have an incomplete or private type that has
-- no full view, which means that we have not encountered the
-- completion, so return Empty to indicate the underlying type
-- is not yet known.
else
return Empty;
end if;
-- For non-incomplete, non-private types, return the type itself
else
return Id;
end if;
end Underlying_Type;
------------------------
-- Write_Entity_Flags --
------------------------
procedure Write_Entity_Flags (Id : Entity_Id; Prefix : String) is
procedure W (Flag_Name : String; Flag : Boolean);
-- Write out given flag if it is set
procedure W (Flag_Name : String; Flag : Boolean) is
begin
if Flag then
Write_Str (Prefix);
Write_Str (Flag_Name);
Write_Str (" = True");
Write_Eol;
end if;
end W;
-- Start of processing for Write_Entity_Flags
begin
W ("Depends_On_Private", Flag14 (Id));
W ("Discard_Names", Flag88 (Id));
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Completion", Flag26 (Id));
W ("Has_Completion_In_Body", Flag71 (Id));
W ("Has_Component_Size_Clause", Flag68 (Id));
W ("Has_Controlled", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id));
W ("Has_Enumeration_Rep_Clause", Flag66 (Id));
W ("Has_Exit", Flag47 (Id));
W ("Has_Homonym", Flag56 (Id));
W ("Has_Machine_Attribute", Flag82 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
W ("Has_Nested_Block_With_Handler", Flag101 (Id));
W ("Has_Non_Standard_Rep", Flag75 (Id));
W ("Has_Pragma_Controlled", Flag27 (Id));
W ("Has_Record_Rep_Clause", Flag65 (Id));
W ("Has_Size_Clause", Flag29 (Id));
W ("Has_Small_Clause", Flag67 (Id));
W ("Has_Specified_Layout", Flag100 (Id));
W ("Has_Storage_Size_Clause", Flag23 (Id));
W ("Has_Tasks", Flag30 (Id));
W ("Has_U_Nominal_Subtype", Flag80 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_Abstract", Flag19 (Id));
W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Aliased", Flag15 (Id));
W ("Is_Asynchronous", Flag81 (Id));
W ("Is_Atomic", Flag85 (Id));
W ("Is_Called", Flag102 (Id));
W ("Is_CPP_Class", Flag74 (Id));
W ("Is_Character_Type", Flag63 (Id));
W ("Is_Child_Unit", Flag73 (Id));
W ("Is_Concurrent_Record_Type", Flag20 (Id));
W ("Is_Constrained", Flag3 (Id));
W ("Is_Constructor", Flag76 (Id));
W ("Is_Controlled", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
W ("Is_Declared_In_Package_Body", Flag93 (Id));
W ("Is_Destructor", Flag77 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exported", Flag99 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_Frozen", Flag4 (Id));
W ("Is_Generic_Actual_Type", Flag94 (Id));
W ("Is_Generic_Type", Flag1 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Imported", Flag24 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Internal", Flag17 (Id));
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
W ("Is_Itype", Flag91 (Id));
W ("Is_Limited_Record", Flag25 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Private", Flag57 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id));
W ("Is_Remote_Types", Flag61 (Id));
W ("Is_Shared_Passive", Flag60 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
W ("Is_Volatile", Flag16 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Needs_Discr_Check", Flag50 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Reachable", Flag49 (Id));
W ("Return_Present", Flag54 (Id));
W ("Returns_By_Ref", Flag90 (Id));
W ("Size_Known_At_Compile_Time", Flag92 (Id));
W ("Suppress_Access_Checks", Flag31 (Id));
W ("Suppress_Accessibility_Checks", Flag32 (Id));
W ("Suppress_Discriminant_Checks", Flag33 (Id));
W ("Suppress_Division_Checks", Flag34 (Id));
W ("Suppress_Elaboration_Checks", Flag35 (Id));
W ("Suppress_Index_Checks", Flag36 (Id));
W ("Suppress_Length_Checks", Flag37 (Id));
W ("Suppress_Overflow_Checks", Flag38 (Id));
W ("Suppress_Range_Checks", Flag39 (Id));
W ("Suppress_Storage_Checks", Flag40 (Id));
W ("Suppress_Tag_Checks", Flag41 (Id));
end Write_Entity_Flags;
-----------------------
-- Write_Entity_Info --
-----------------------
procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
procedure Write_Kind (Id : Entity_Id);
-- Write Ekind field of entity
procedure Write_Attribute (Which : String; Nam : E);
-- Write attribute value with given string name
procedure Write_Kind (Id : Entity_Id) is
K : constant String := Entity_Kind'Image (Ekind (Id));
begin
Write_Str (Prefix);
Write_Str (" Kind ");
if Is_Type (Id) and then Is_Tagged_Type (Id) then
Write_Str ("TAGGED ");
end if;
Write_Str (K (3 .. K'Length));
Write_Str (" ");
if Is_Type (Id) and then Depends_On_Private (Id) then
Write_Str ("Depends_On_Private ");
end if;
end Write_Kind;
procedure Write_Attribute (Which : String; Nam : E) is
begin
Write_Str (Prefix);
Write_Str (Which);
Write_Int (Int (Nam));
Write_Str (" ");
Write_Name (Chars (Nam));
Write_Str (" ");
end Write_Attribute;
-- Start of processing for Write_Entity_Info
begin
Write_Eol;
Write_Attribute ("Name ", Id);
Write_Int (Int (Id));
Write_Eol;
Write_Kind (Id);
Write_Eol;
Write_Attribute (" Type ", Etype (Id));
Write_Eol;
Write_Attribute (" Scope ", Scope (Id));
Write_Eol;
case Ekind (Id) is
when Discrete_Kind =>
Write_Str ("Bounds: Id = ");
if Present (Scalar_Range (Id)) then
Write_Int (Int (Type_Low_Bound (Id)));
Write_Str (" .. Id = ");
Write_Int (Int (Type_High_Bound (Id)));
else
Write_Str ("Empty");
end if;
Write_Eol;
when Array_Kind =>
declare
Index : E;
begin
Write_Attribute (" Component Type ",
Component_Type (Id));
Write_Eol;
Write_Str (Prefix);
Write_Str (" Indices ");
Index := First_Index (Id);
while Present (Index) loop
Write_Attribute (" ", Etype (Index));
Index := Next_Index (Index);
end loop;
Write_Eol;
end;
when Access_Kind =>
Write_Attribute
(" Directly Designated Type ",
Directly_Designated_Type (Id));
Write_Eol;
when Overloadable_Kind =>
if Present (Homonym (Id)) then
Write_Str (" Homonym ");
Write_Name (Chars (Homonym (Id)));
Write_Str (" ");
Write_Int (Int (Homonym (Id)));
Write_Eol;
end if;
Write_Eol;
when E_Component =>
if Ekind (Scope (Id)) in Record_Kind then
Write_Attribute (
" Original_Record_Component ",
Original_Record_Component (Id));
Write_Int (Int (Original_Record_Component (Id)));
Write_Eol;
end if;
when others => null;
end case;
end Write_Entity_Info;
-----------------------
-- Write_Field6_Name --
-----------------------
procedure Write_Field6_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Constant |
E_Function |
E_Generic_Function |
E_Procedure |
E_Generic_Procedure |
E_Variable =>
Write_Str ("Interface_Name");
when Concurrent_Kind |
Incomplete_Or_Private_Kind |
Class_Wide_Kind |
E_Record_Type |
E_Record_Subtype =>
Write_Str ("Discriminant_Constraint");
when E_Entry |
E_Entry_Family =>
Write_Str ("Accept_Address");
when Fixed_Point_Kind =>
Write_Str ("Small_Value");
when others =>
Write_Str ("Field6??");
end case;
end Write_Field6_Name;
-----------------------
-- Write_Field7_Name --
-----------------------
procedure Write_Field7_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
when E_Enumeration_Literal |
E_Function |
E_Operator |
E_Procedure =>
Write_Str ("Alias");
when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
when E_Entry |
E_Entry_Family =>
Write_Str ("Entry_Parameters_Type");
when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant");
when E_Class_Wide_Subtype =>
Write_Str ("Equivalent_Type");
when Enumeration_Kind =>
Write_Str ("Lit_Name_Table");
when Fixed_Point_Kind =>
Write_Str ("Delta_Value");
when E_Constant |
E_Variable =>
Write_Str ("Renamed_Object");
when E_Exception |
E_Package |
E_Generic_Function |
E_Generic_Procedure |
E_Generic_Package =>
Write_Str ("Renamed_Entity");
when Private_Kind =>
Write_Str ("Private_Dependents");
when Concurrent_Kind =>
Write_Str ("Corresponding_Record_Type");
when others =>
Write_Str ("Field7??");
end case;
end Write_Field7_Name;
-----------------------
-- Write_Field8_Name --
-----------------------
procedure Write_Field8_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Component |
E_Discriminant =>
Write_Str ("Original_Record_Component");
when E_Enumeration_Literal =>
Write_Str ("Enumeration_Rep_Expr");
when Formal_Kind =>
Write_Str ("Protected_Formal");
when Type_Kind |
E_Variable |
E_Constant =>
Write_Str ("Alignment_Clause");
when E_Block |
E_Function |
E_Loop |
E_Package |
E_Generic_Package |
E_Generic_Function |
E_Generic_Procedure |
E_Procedure =>
Write_Str ("Scope_Depth");
when others =>
Write_Str ("Field8??");
end case;
end Write_Field8_Name;
-----------------------
-- Write_Field9_Name --
-----------------------
procedure Write_Field9_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Digits_Kind =>
Write_Str ("Digits_Value");
when E_Component =>
Write_Str ("Prival");
when E_Discriminant =>
Write_Str ("Discriminal");
when E_Block |
Class_Wide_Kind |
Concurrent_Kind |
Private_Kind |
E_Entry |
E_Entry_Family |
E_Function |
E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure |
E_Loop |
E_Operator |
E_Package |
E_Procedure |
E_Record_Type |
E_Record_Subtype |
E_Subprogram_Type =>
Write_Str ("First_Entity");
when Array_Kind =>
Write_Str ("First_Index");
when E_Protected_Body =>
Write_Str ("Object_Ref");
when Enumeration_Kind =>
Write_Str ("First_Literal");
when Access_Kind =>
Write_Str ("Master_Id");
when Modular_Integer_Kind =>
Write_Str ("Modulus");
when Formal_Kind |
E_Constant |
E_Generic_In_Out_Parameter |
E_Variable =>
Write_Str ("Actual_Subtype");
when others =>
Write_Str ("Field9??");
end case;
end Write_Field9_Name;
------------------------
-- Write_Field10_Name --
------------------------
procedure Write_Field10_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Array_Kind =>
Write_Str ("Component_Type");
when E_In_Parameter |
E_Generic_In_Parameter =>
Write_Str ("Default_Value");
when Access_Kind =>
Write_Str ("Directly_Designated_Type");
when E_Component =>
Write_Str ("Discriminant_Checking_Func");
when E_Discriminant =>
Write_Str ("Discriminant_Default_Value");
when E_Block |
Class_Wide_Kind |
Concurrent_Kind |
Private_Kind |
E_Entry |
E_Entry_Family |
E_Function |
E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure |
E_Loop |
E_Operator |
E_Package |
E_Procedure |
E_Record_Type |
E_Record_Subtype |
E_Subprogram_Type =>
Write_Str ("Last_Entity");
when Scalar_Kind =>
Write_Str ("Scalar_Range");
when others =>
Write_Str ("Field10??");
end case;
end Write_Field10_Name;
------------------------
-- Write_Field11_Name --
------------------------
procedure Write_Field11_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Formal_Kind =>
Write_Str ("Entry_Component");
when E_Component |
E_Discriminant =>
Write_Str ("Component_First_Bit");
when E_Constant =>
Write_Str ("Full_View");
when E_Enumeration_Literal =>
Write_Str ("Enumeration_Pos");
when E_String_Literal_Subtype =>
Write_Str ("String_Literal_Length");
when E_Enum_Table_Type =>
Write_Str ("Table_High_Bound");
when E_Function |
E_Procedure |
E_Entry |
E_Entry_Family =>
Write_Str ("Protected_Body_Subprogram");
when E_Package |
E_Generic_Package |
Concurrent_Kind =>
Write_Str ("First_Private_Entity");
when Incomplete_Or_Private_Kind =>
Write_Str ("Full_View");
when Scalar_Kind =>
Write_Str ("Ancestor_Subtype");
when others =>
Write_Str ("Field11??");
end case;
end Write_Field11_Name;
------------------------
-- Write_Field12_Name --
------------------------
procedure Write_Field12_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Entry |
E_Entry_Family =>
Write_Str ("Barrier_Function");
when E_Enumeration_Literal =>
Write_Str ("Enumeration_Rep");
when Type_Kind |
E_Component |
E_Constant |
E_Discriminant |
E_Variable =>
Write_Str ("Esize");
when E_Function |
E_Procedure =>
Write_Str ("Next_Overloaded_Subprogram");
when E_Package =>
Write_Str ("Associated_Formal_Package");
when others =>
Write_Str ("Field12??");
end case;
end Write_Field12_Name;
------------------------
-- Write_Field13_Name --
------------------------
procedure Write_Field13_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Access_Kind =>
Write_Str ("Associated_Storage_Pool");
when Array_Kind =>
Write_Str ("Component_Size_Clause");
when E_Component |
E_Discriminant =>
Write_Str ("Component_Clause");
when Class_Wide_Kind |
E_Record_Type |
E_Record_Subtype |
Private_Kind =>
Write_Str ("Primitive_Operations");
when E_Block |
Concurrent_Kind |
E_Function |
E_Procedure |
E_Entry |
E_Entry_Family =>
Write_Str ("Finalization_Chain_Entity");
when others =>
Write_Str ("FIeld13??");
end case;
end Write_Field13_Name;
------------------------
-- Write_Field14_Name --
------------------------
procedure Write_Field14_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Access_Kind =>
Write_Str ("Associated_Final_Chain");
when Array_Kind =>
Write_Str ("Packed_Array_Type");
when E_Component =>
Write_Str ("Protected_Operation");
when E_Block |
Task_Kind |
E_Entry |
E_Entry_Family |
E_Function |
E_Package |
E_Procedure =>
Write_Str ("Task_Activation_Chain_Entity");
when E_Enumeration_Type =>
Write_Str ("Enum_Pos_To_Rep");
when others =>
Write_Str ("Field14??");
end case;
end Write_Field14_Name;
------------------------
-- Write_Field15_Name --
------------------------
procedure Write_Field15_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Access_Kind |
Task_Kind =>
Write_Str ("Storage_Size_Variable");
when Decimal_Fixed_Point_Kind =>
Write_Str ("Scale_Value");
when Record_Kind =>
Write_Str ("Access_Disp_Table");
when E_Function |
E_Procedure =>
Write_Str ("DT_Position");
when E_Component =>
Write_Str ("DT_Entry_Count");
when E_Protected_Type =>
Write_Str ("Entry_Bodies_Array");
when others =>
Write_Str ("Field15??");
end case;
end Write_Field15_Name;
------------------------
-- Write_Field16_Name --
------------------------
procedure Write_Field16_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Type_Kind =>
Write_Str ("Next_Itype");
when E_Function |
E_Procedure =>
Write_Str ("DTC_Entity");
when others =>
Write_Str ("Field16??");
end case;
end Write_Field16_Name;
------------------------
-- Write_Field17_Name --
------------------------
procedure Write_Field17_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Type_Kind =>
Write_Str ("Class_Wide_Type");
when E_Function |
E_Procedure |
E_Generic_Function |
E_Generic_Procedure =>
Write_Str ("Machine_Attribute");
when others =>
Write_Str ("Field17??");
end case;
end Write_Field17_Name;
-----------------------
-- Write_Field18_Name --
-----------------------
procedure Write_Field18_Name (Id : Entity_Id) is
begin
Write_Str ("Freeze_Node");
end Write_Field18_Name;
-----------------------
-- Write_Field19_Name --
-----------------------
procedure Write_Field19_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Task_Kind =>
Write_Str ("Task_Body_Procedure");
when others =>
Write_Str ("Field19??");
end case;
end Write_Field19_Name;
-----------------------
-- Write_Field20_Name --
-----------------------
procedure Write_Field20_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Constant |
E_Entry |
E_Entry_Family |
E_Function |
E_Generic_Function |
E_Generic_Procedure |
E_Procedure |
E_Variable =>
Write_Str ("Address_Clause");
when others =>
Write_Str ("Field20??");
end case;
end Write_Field20_Name;
-----------------------
-- Write_Field21_Name --
-----------------------
procedure Write_Field21_Name (Id : Entity_Id) is
begin
Write_Str ("Field21??");
end Write_Field21_Name;
-----------------------
-- Write_Field22_Name --
-----------------------
procedure Write_Field22_Name (Id : Entity_Id) is
begin
Write_Str ("Field22??");
end Write_Field22_Name;
end Einfo;
