-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
-with Snames; use Snames;
with Stand; use Stand;
with Output; use Output;
-- Four of these fields are defined in Sinfo, since they in are the
-- base part of the node. The access routines for these fields and
-- the corresponding set procedures are defined in Sinfo. These fields
- -- are present in all entities.
+ -- are present in all entities. Note that Homonym is also in the base
+ -- part of the node, but has access routines that are more properly
+ -- part of Einfo, which is why they are defined here.
-- Chars Name1
-- Next_Entity Node2
-- Scope Node3
-- Etype Node5
- -- The fifth field is also in the base part of the node, but it
- -- carries some additional semantic checks and its subprograms are
- -- more properly defined in Einfo.
-
- -- Homonym Node4
-
-- Remaining fields are present only in extended nodes (i.e. entities)
-- The following fields are present in all entities
+ -- Homonym Node4
-- First_Rep_Item Node6
-- Freeze_Node Node7
-- Normalized_First_Bit Uint8
-- Class_Wide_Type Node9
- -- Normalized_Position Uint9
- -- Size_Check_Code Node9
+ -- Current_Value Node9
-- Renaming_Map Uint9
-- Discriminal_Link Node10
-- Full_View Node11
-- Entry_Component Node11
-- Enumeration_Pos Uint11
+ -- Generic_Homonym Node11
-- Protected_Body_Subprogram Node11
-- Block_Node Node11
-- Alignment Uint14
-- First_Optional_Parameter Node14
+ -- Normalized_Position Uint14
-- Shadow_Entities List14
-- Discriminant_Number Uint15
-- First_Literal Node17
-- Master_Id Node17
-- Modulus Uint17
+ -- Non_Limited_View Node17
-- Object_Ref Node17
-- Prival Node17
-- Finalization_Chain_Entity Node19
-- Parent_Subtype Node19
-- Related_Array_Object Node19
+ -- Size_Check_Code Node19
-- Spec_Entity Node19
-- Underlying_Full_View Node19
-- Accept_Address Elist21
-- Default_Expr_Function Node21
-- Discriminant_Constraint Elist21
- -- Small_Value Ureal21
-- Interface_Name Node21
+ -- Original_Array_Type Node21
+ -- Small_Value Ureal21
-- Associated_Storage_Pool Node22
-- Component_Size Uint22
-- Associated_Final_Chain Node23
-- CR_Discriminant Node23
- -- Girder_Constraint Elist23
+ -- Stored_Constraint Elist23
-- Entry_Cancel_Parameter Node23
-- Extra_Constrained Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Enum_Pos_To_Rep Node23
-- Packed_Array_Type Node23
+ -- Limited_View Node23
-- Privals_Chain Elist23
-- Protected_Operation Node23
-- In_Use Flag8
-- Is_Potentially_Use_Visible Flag9
-- Is_Public Flag10
+
-- Is_Inlined Flag11
-- Is_Constrained Flag12
-- Is_Generic_Type Flag13
-- 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_Statically_Allocated Flag28
-- Has_Size_Clause Flag29
-- Has_Task 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
+
+ -- Checks_May_Be_Suppressed Flag31
+ -- Kill_Elaboration_Checks Flag32
+ -- Kill_Range_Checks Flag33
+ -- Kill_Tag_Checks Flag34
+ -- Is_Class_Wide_Equivalent_Type Flag35
+ -- Referenced_As_LHS Flag36
+ -- Is_Known_Non_Null Flag37
+ -- Can_Never_Be_Null Flag38
+ -- Is_Overriding_Operation Flag39
+ -- Body_Needed_For_SAL Flag40
+
+ -- Treat_As_Volatile Flag41
-- Is_Controlled Flag42
-- Has_Controlled_Component Flag43
-- Is_Pure Flag44
-- In_Package_Body Flag48
-- Reachable Flag49
-- Delay_Subprogram_Descriptors Flag50
+
-- Is_Packed Flag51
-- Is_Entry_Formal Flag52
-- Is_Private_Descendant Flag53
-- Non_Binary_Modulus Flag58
-- Is_Preelaborated Flag59
-- Is_Shared_Passive Flag60
+
-- Is_Remote_Types Flag61
-- Is_Remote_Call_Interface Flag62
-- Is_Character_Type Flag63
-- 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_Thread_Body Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Is_Constr_Subt_For_U_Nominal Flag80
+
-- Is_Asynchronous Flag81
-- Has_Gigi_Rep_Item Flag82
-- Has_Machine_Radix_Clause Flag83
-- Discard_Names Flag88
-- Is_Interrupt_Handler Flag89
-- Returns_By_Ref Flag90
+
-- Is_Itype Flag91
-- Size_Known_At_Compile_Time Flag92
-- Has_Subprogram_Descriptor Flag93
-- Has_Controlling_Result Flag98
-- Is_Exported Flag99
-- Has_Specified_Layout Flag100
+
-- Has_Nested_Block_With_Handler Flag101
-- Is_Called Flag102
-- Is_Completely_Hidden Flag103
-- Default_Expressions_Processed Flag108
-- Is_Non_Static_Subtype Flag109
-- Has_External_Tag_Rep_Clause Flag110
+
-- Is_Formal_Subprogram Flag111
-- Is_Renaming_Of_Object Flag112
-- No_Return Flag113
-- Delay_Cleanups Flag114
- -- Not_Source_Assigned Flag115
+ -- Never_Set_In_Source Flag115
-- Is_Visible_Child_Unit Flag116
-- Is_Unchecked_Union Flag117
-- Is_For_Access_Subtype Flag118
-- Has_Convention_Pragma Flag119
-- Has_Primitive_Operations Flag120
+
-- Has_Pragma_Pack Flag121
-- Is_Bit_Packed_Array Flag122
-- Has_Unchecked_Union Flag123
-- (used for Component_Alignment) Flag128
-- (used for Component_Alignment) Flag129
-- Is_Generic_Instance Flag130
+
-- No_Pool_Assigned Flag131
-- Is_AST_Entry Flag132
-- Is_VMS_Exception Flag133
-- Is_Optional_Parameter Flag134
-- Has_Aliased_Components Flag135
+ -- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
-- Is_Packed_Array_Type Flag138
-- Has_Biased_Representation Flag139
-- Has_Complex_Representation Flag140
+
-- Is_Constr_Subt_For_UN_Aliased Flag141
-- Has_Missing_Return Flag142
-- Has_Recursive_Call Flag143
-- Suppress_Elaboration_Warnings Flag148
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
+
-- Vax_Float Flag151
-- Entry_Accepted Flag152
-- Is_Psected Flag153
-- Finalize_Storage_Only Flag158
-- From_With_Type Flag159
-- Is_Package_Body_Entity Flag160
+
-- Has_Qualified_Name Flag161
-- Nonzero_Is_True Flag162
-- Is_True_Constant Flag163
-- Materialize_Entity Flag168
-- Function_Returns_With_DSP Flag169
-- Is_Known_Valid Flag170
+
-- Is_Hidden_Open_Scope Flag171
-- Has_Object_Size_Clause Flag172
-- Has_Fully_Qualified_Name Flag173
-- Is_Discrim_SO_Function Flag176
-- Size_Depends_On_Discriminant Flag177
-- Is_Null_Init_Proc Flag178
+ -- Has_Pragma_Pure_Function Flag179
+ -- Has_Pragma_Unreferenced Flag180
+
+ -- Has_Contiguous_Rep Flag181
+ -- Has_Xref_Entry Flag182
+ -- Must_Be_On_Byte_Boundary Flag183
- -- (unused) Flag179
- -- (unused) Flag180
- -- (unused) Flag181
- -- (unused) Flag182
- -- (unused) Flag183
+ -- Note: there are no unused flags currently!
--------------------------------
-- Attribute Access Functions --
function Access_Disp_Table (Id : E) return E is
begin
pragma Assert (Is_Tagged_Type (Id));
- return Node16 (Base_Type (Underlying_Type (Base_Type (Id))));
+ return Node16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Actual_Subtype (Id : E) return E is
function Alignment (Id : E) return U is
begin
+ pragma Assert (Is_Type (Id)
+ or else Is_Formal (Id)
+ or else Ekind (Id) = E_Loop_Parameter
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Exception
+ or else Ekind (Id) = E_Variable);
return Uint14 (Id);
end Alignment;
function Associated_Storage_Pool (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
- return Node22 (Id);
+ return Node22 (Root_Type (Id));
end Associated_Storage_Pool;
function Barrier_Function (Id : E) return N is
return Node19 (Id);
end Body_Entity;
+ function Body_Needed_For_SAL (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Package
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Unit (Id));
+ return Flag40 (Id);
+ end Body_Needed_For_SAL;
+
function C_Pass_By_Copy (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
return Flag125 (Implementation_Base_Type (Id));
end C_Pass_By_Copy;
+ function Can_Never_Be_Null (Id : E) return B is
+ begin
+ return Flag38 (Id);
+ end Can_Never_Be_Null;
+
+ function Checks_May_Be_Suppressed (Id : E) return B is
+ begin
+ return Flag31 (Id);
+ end Checks_May_Be_Suppressed;
+
function Class_Wide_Type (Id : E) return E is
begin
pragma Assert (Is_Type (Id));
return Node22 (Id);
end Corresponding_Remote_Type;
+ function Current_Value (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) in Object_Kind);
+ return Node9 (Id);
+ end Current_Value;
+
function CR_Discriminant (Id : E) return E is
begin
return Node23 (Id);
return Flag169 (Id);
end Function_Returns_With_DSP;
- function Generic_Renamings (Id : E) return L is
+ function Generic_Homonym (Id : E) return E is
begin
- return Elist23 (Id);
- end Generic_Renamings;
+ pragma Assert (Ekind (Id) = E_Generic_Package);
+ return Node11 (Id);
+ end Generic_Homonym;
- function Girder_Constraint (Id : E) return L is
+ function Generic_Renamings (Id : E) return L is
begin
- pragma Assert
- (Is_Composite_Type (Id) and then not Is_Array_Type (Id));
return Elist23 (Id);
- end Girder_Constraint;
+ end Generic_Renamings;
function Handler_Records (Id : E) return S is
begin
return Flag43 (Base_Type (Id));
end Has_Controlled_Component;
+ function Has_Contiguous_Rep (Id : E) return B is
+ begin
+ return Flag181 (Id);
+ end Has_Contiguous_Rep;
+
function Has_Controlling_Result (Id : E) return B is
begin
return Flag98 (Id);
return Flag121 (Implementation_Base_Type (Id));
end Has_Pragma_Pack;
+ function Has_Pragma_Pure_Function (Id : E) return B is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Flag179 (Id);
+ end Has_Pragma_Pure_Function;
+
+ function Has_Pragma_Unreferenced (Id : E) return B is
+ begin
+ return Flag180 (Id);
+ end Has_Pragma_Unreferenced;
+
function Has_Primitive_Operations (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
function Has_Record_Rep_Clause (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
- return Flag65 (Id);
+ return Flag65 (Implementation_Base_Type (Id));
end Has_Record_Rep_Clause;
function Has_Recursive_Call (Id : E) return B is
function Has_Specified_Layout (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
- return Flag100 (Id);
+ return Flag100 (Implementation_Base_Type (Id));
end Has_Specified_Layout;
function Has_Storage_Size_Clause (Id : E) return B is
return Flag87 (Implementation_Base_Type (Id));
end Has_Volatile_Components;
+ function Has_Xref_Entry (Id : E) return B is
+ begin
+ return Flag182 (Implementation_Base_Type (Id));
+ end Has_Xref_Entry;
+
function Hiding_Loop_Variable (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Variable);
return Flag73 (Id);
end Is_Child_Unit;
+ function Is_Class_Wide_Equivalent_Type (Id : E) return B is
+ begin
+ return Flag35 (Id);
+ end Is_Class_Wide_Equivalent_Type;
+
function Is_Compilation_Unit (Id : E) return B is
begin
return Flag149 (Id);
return Flag74 (Id);
end Is_CPP_Class;
- function Is_Destructor (Id : E) return B is
- begin
- return Flag77 (Id);
- end Is_Destructor;
-
function Is_Discrim_SO_Function (Id : E) return B is
begin
return Flag176 (Id);
return Flag91 (Id);
end Is_Itype;
+ function Is_Known_Non_Null (Id : E) return B is
+ begin
+ return Flag37 (Id);
+ end Is_Known_Non_Null;
+
function Is_Known_Valid (Id : E) return B is
begin
return Flag170 (Id);
return Flag134 (Id);
end Is_Optional_Parameter;
+ function Is_Overriding_Operation (Id : E) return B is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Flag39 (Id);
+ end Is_Overriding_Operation;
+
function Is_Package_Body_Entity (Id : E) return B is
begin
return Flag160 (Id);
return Flag55 (Id);
end Is_Tagged_Type;
+ function Is_Thread_Body (Id : E) return B is
+ begin
+ return Flag77 (Id);
+ end Is_Thread_Body;
+
function Is_True_Constant (Id : E) return B is
begin
return Flag163 (Id);
function Is_Volatile (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
- return Flag16 (Id);
+ if Is_Type (Id) then
+ return Flag16 (Base_Type (Id));
+ else
+ return Flag16 (Id);
+ end if;
end Is_Volatile;
+ function Kill_Elaboration_Checks (Id : E) return B is
+ begin
+ return Flag32 (Id);
+ end Kill_Elaboration_Checks;
+
+ function Kill_Range_Checks (Id : E) return B is
+ begin
+ return Flag33 (Id);
+ end Kill_Range_Checks;
+
+ function Kill_Tag_Checks (Id : E) return B is
+ begin
+ return Flag34 (Id);
+ end Kill_Tag_Checks;
+
function Last_Entity (Id : E) return E is
begin
return Node20 (Id);
end Last_Entity;
+ function Limited_View (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ return Node23 (Id);
+ end Limited_View;
+
function Lit_Indexes (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
return Uint17 (Base_Type (Id));
end Modulus;
+ function Must_Be_On_Byte_Boundary (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag183 (Id);
+ end Must_Be_On_Byte_Boundary;
+
function Needs_Debug_Info (Id : E) return B is
begin
return Flag147 (Id);
return Flag22 (Id);
end Needs_No_Actuals;
+ function Never_Set_In_Source (Id : E) return B is
+ begin
+ return Flag115 (Id);
+ end Never_Set_In_Source;
+
function Next_Inlined_Subprogram (Id : E) return E is
begin
return Node12 (Id);
function No_Return (Id : E) return B is
begin
pragma Assert
- (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Generic_Procedure);
+ (Id = Any_Id
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Generic_Procedure);
return Flag113 (Id);
end No_Return;
+ function No_Strict_Aliasing (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag136 (Base_Type (Id));
+ end No_Strict_Aliasing;
+
function Non_Binary_Modulus (Id : E) return B is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
return Flag58 (Base_Type (Id));
end Non_Binary_Modulus;
+ function Non_Limited_View (Id : E) return E is
+ begin
+ pragma Assert (False
+ or else Ekind (Id) = E_Incomplete_Type);
+ return Node17 (Id);
+ end Non_Limited_View;
+
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
- return Uint9 (Id);
+ return Uint14 (Id);
end Normalized_Position;
function Normalized_Position_Max (Id : E) return U is
return Uint10 (Id);
end Normalized_Position_Max;
- function Not_Source_Assigned (Id : E) return B is
- begin
- return Flag115 (Id);
- end Not_Source_Assigned;
-
function Object_Ref (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
return Node17 (Id);
end Object_Ref;
+ function Original_Access_Type (Id : E) return E is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Access_Subprogram_Type
+ or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
+ return Node21 (Id);
+ end Original_Access_Type;
+
+ function Original_Array_Type (Id : E) return E is
+ begin
+ pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
+ return Node21 (Id);
+ end Original_Array_Type;
+
function Original_Record_Component (Id : E) return E is
begin
+ pragma Assert
+ (Ekind (Id) = E_Void
+ or else Ekind (Id) = E_Component
+ or else Ekind (Id) = E_Discriminant);
return Node22 (Id);
end Original_Record_Component;
return Flag156 (Id);
end Referenced;
+ function Referenced_As_LHS (Id : E) return B is
+ begin
+ return Flag36 (Id);
+ end Referenced_As_LHS;
+
function Referenced_Object (Id : E) return N is
begin
pragma Assert (Is_Type (Id));
function Related_Instance (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Package);
+ pragma Assert
+ (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
return Node15 (Id);
end Related_Instance;
function Size_Check_Code (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
- return Node9 (Id);
+ return Node19 (Id);
end Size_Check_Code;
function Size_Depends_On_Discriminant (Id : E) return B is
return Node15 (Implementation_Base_Type (Id));
end Storage_Size_Variable;
+ function Stored_Constraint (Id : E) return L is
+ begin
+ pragma Assert
+ (Is_Composite_Type (Id) and then not Is_Array_Type (Id));
+ return Elist23 (Id);
+ end Stored_Constraint;
+
function Strict_Alignment (Id : E) return B is
begin
return Flag145 (Implementation_Base_Type (Id));
return Node15 (Id);
end String_Literal_Low_Bound;
- 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_Elaboration_Warnings (Id : E) return B is
begin
return Flag148 (Id);
end Suppress_Elaboration_Warnings;
- function Suppress_Index_Checks (Id : E) return B is
- begin
- return Flag36 (Id);
- end Suppress_Index_Checks;
-
function Suppress_Init_Proc (Id : E) return B is
begin
return Flag105 (Base_Type (Id));
end Suppress_Init_Proc;
- 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_Style_Checks (Id : E) return B is
begin
return Flag165 (Id);
end Suppress_Style_Checks;
- function Suppress_Tag_Checks (Id : E) return B is
+ function Treat_As_Volatile (Id : E) return B is
begin
return Flag41 (Id);
- end Suppress_Tag_Checks;
+ end Treat_As_Volatile;
function Underlying_Full_View (Id : E) return E is
begin
return Ekind (Id) in Formal_Kind;
end Is_Formal;
+ function Is_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Generic_Subprogram;
+
function Is_Generic_Unit (Id : E) return B is
begin
return Ekind (Id) in Generic_Unit_Kind;
procedure Set_Access_Disp_Table (Id : E; V : E) is
begin
- pragma Assert (Is_Tagged_Type (Id));
- Set_Node16 (Base_Type (Id), V);
+ pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+ Set_Node16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Final_Chain (Id : E; V : E) is
procedure Set_Associated_Storage_Pool (Id : E; V : E) is
begin
- pragma Assert (Is_Access_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
Set_Node22 (Id, V);
end Set_Associated_Storage_Pool;
procedure Set_Alignment (Id : E; V : U) is
begin
+ pragma Assert (Is_Type (Id)
+ or else Is_Formal (Id)
+ or else Ekind (Id) = E_Loop_Parameter
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Exception
+ or else Ekind (Id) = E_Variable);
Set_Uint14 (Id, V);
end Set_Alignment;
Set_Node19 (Id, V);
end Set_Body_Entity;
+ procedure Set_Body_Needed_For_SAL (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Package
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Unit (Id));
+ Set_Flag40 (Id, V);
+ end Set_Body_Needed_For_SAL;
+
procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is
begin
pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id));
Set_Flag125 (Id, V);
end Set_C_Pass_By_Copy;
+ procedure Set_Can_Never_Be_Null (Id : E; V : B := True) is
+ begin
+ Set_Flag38 (Id, V);
+ end Set_Can_Never_Be_Null;
+
+ procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True) is
+ begin
+ Set_Flag31 (Id, V);
+ end Set_Checks_May_Be_Suppressed;
+
procedure Set_Class_Wide_Type (Id : E; V : E) is
begin
pragma Assert (Is_Type (Id));
procedure Set_Component_Size (Id : E; V : U) is
begin
- pragma Assert (Is_Array_Type (Id));
- Set_Uint22 (Base_Type (Id), V);
+ pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+ Set_Uint22 (Id, V);
end Set_Component_Size;
procedure Set_Component_Type (Id : E; V : E) is
begin
+ pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
Set_Node20 (Id, V);
end Set_Component_Type;
Set_Node22 (Id, V);
end Set_Corresponding_Remote_Type;
+ procedure Set_Current_Value (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void);
+ Set_Node9 (Id, V);
+ end Set_Current_Value;
+
procedure Set_CR_Discriminant (Id : E; V : E) is
begin
Set_Node23 (Id, V);
procedure Set_Discriminant_Checking_Func (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Component and Ekind (Scope (Id)) in Record_Kind);
+ pragma Assert (Ekind (Id) = E_Component);
Set_Node20 (Id, V);
end Set_Discriminant_Checking_Func;
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id));
- Set_Flag158 (Base_Type (Id), V);
+ pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ Set_Flag158 (Id, V);
end Set_Finalize_Storage_Only;
procedure Set_First_Entity (Id : E; V : E) is
begin
pragma Assert
(Is_Type (Id)
- or else Ekind (Id) = E_Package);
+ or else Ekind (Id) = E_Package);
Set_Flag159 (Id, V);
end Set_From_With_Type;
Set_Flag169 (Id, V);
end Set_Function_Returns_With_DSP;
- procedure Set_Generic_Renamings (Id : E; V : L) is
+ procedure Set_Generic_Homonym (Id : E; V : E) is
begin
- Set_Elist23 (Id, V);
- end Set_Generic_Renamings;
+ Set_Node11 (Id, V);
+ end Set_Generic_Homonym;
- procedure Set_Girder_Constraint (Id : E; V : L) is
+ procedure Set_Generic_Renamings (Id : E; V : L) is
begin
- pragma Assert (Nkind (Id) in N_Entity);
Set_Elist23 (Id, V);
- end Set_Girder_Constraint;
+ end Set_Generic_Renamings;
procedure Set_Handler_Records (Id : E; V : S) is
begin
procedure Set_Has_Complex_Representation (Id : E; V : B := True) is
begin
- pragma Assert (Is_Record_Type (Id));
- Set_Flag140 (Implementation_Base_Type (Id), V);
+ pragma Assert (Ekind (Id) = E_Record_Type);
+ Set_Flag140 (Id, V);
end Set_Has_Complex_Representation;
procedure Set_Has_Component_Size_Clause (Id : E; V : B := True) is
begin
- pragma Assert (Is_Array_Type (Id));
- Set_Flag68 (Implementation_Base_Type (Id), V);
+ pragma Assert (Ekind (Id) = E_Array_Type);
+ Set_Flag68 (Id, V);
end Set_Has_Component_Size_Clause;
+ procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is
+ begin
+ Set_Flag181 (Id, V);
+ end Set_Has_Contiguous_Rep;
+
procedure Set_Has_Controlled_Component (Id : E; V : B := True) is
begin
pragma Assert (Base_Type (Id) = Id);
procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
- Set_Flag121 (Implementation_Base_Type (Id), V);
+ pragma Assert (Id = Base_Type (Id));
+ Set_Flag121 (Id, V);
end Set_Has_Pragma_Pack;
+ procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Flag179 (Id, V);
+ end Set_Has_Pragma_Pure_Function;
+
+ procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True) is
+ begin
+ Set_Flag180 (Id, V);
+ end Set_Has_Pragma_Unreferenced;
+
procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id));
- Set_Flag120 (Base_Type (Id), V);
+ pragma Assert (Id = Base_Type (Id));
+ Set_Flag120 (Id, V);
end Set_Has_Primitive_Operations;
procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True) is
begin
- pragma Assert (Is_Record_Type (Id));
+ pragma Assert (Id = Base_Type (Id));
Set_Flag65 (Id, V);
end Set_Has_Record_Rep_Clause;
procedure Set_Has_Specified_Layout (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id));
+ pragma Assert (Id = Base_Type (Id));
Set_Flag100 (Id, V);
end Set_Has_Specified_Layout;
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
+ procedure Set_Has_Xref_Entry (Id : E; V : B := True) is
+ begin
+ Set_Flag182 (Id, V);
+ end Set_Has_Xref_Entry;
+
procedure Set_Hiding_Loop_Variable (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
pragma Assert (Id /= V);
Set_Node4 (Id, V);
end Set_Homonym;
+
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is
begin
- Set_Flag122 (Implementation_Base_Type (Id), V);
+ pragma Assert ((not V)
+ or else (Is_Array_Type (Id) and then Id = Base_Type (Id)));
+
+ Set_Flag122 (Id, V);
end Set_Is_Bit_Packed_Array;
procedure Set_Is_Called (Id : E; V : B := True) is
Set_Flag73 (Id, V);
end Set_Is_Child_Unit;
+ procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
+ begin
+ Set_Flag35 (Id, V);
+ end Set_Is_Class_Wide_Equivalent_Type;
+
procedure Set_Is_Compilation_Unit (Id : E; V : B := True) is
begin
Set_Flag149 (Id, V);
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
- procedure Set_Is_Destructor (Id : E; V : B := True) is
- begin
- Set_Flag77 (Id, V);
- end Set_Is_Destructor;
-
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is
begin
Set_Flag176 (Id, V);
Set_Flag91 (Id, V);
end Set_Is_Itype;
+ procedure Set_Is_Known_Non_Null (Id : E; V : B := True) is
+ begin
+ Set_Flag37 (Id, V);
+ end Set_Is_Known_Non_Null;
+
procedure Set_Is_Known_Valid (Id : E; V : B := True) is
begin
Set_Flag170 (Id, V);
Set_Flag134 (Id, V);
end Set_Is_Optional_Parameter;
+ procedure Set_Is_Overriding_Operation (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Flag39 (Id, V);
+ end Set_Is_Overriding_Operation;
+
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is
begin
Set_Flag160 (Id, V);
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
+ procedure Set_Is_Thread_Body (Id : E; V : B := True) is
+ begin
+ Set_Flag77 (Id, V);
+ end Set_Is_Thread_Body;
+
procedure Set_Is_True_Constant (Id : E; V : B := True) is
begin
Set_Flag163 (Id, V);
Set_Flag16 (Id, V);
end Set_Is_Volatile;
+ procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag32 (Id, V);
+ end Set_Kill_Elaboration_Checks;
+
+ procedure Set_Kill_Range_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag33 (Id, V);
+ end Set_Kill_Range_Checks;
+
+ procedure Set_Kill_Tag_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag34 (Id, V);
+ end Set_Kill_Tag_Checks;
+
procedure Set_Last_Entity (Id : E; V : E) is
begin
Set_Node20 (Id, V);
end Set_Last_Entity;
+ procedure Set_Limited_View (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ Set_Node23 (Id, V);
+ end Set_Limited_View;
+
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
Set_Uint17 (Id, V);
end Set_Modulus;
+ procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag183 (Id, V);
+ end Set_Must_Be_On_Byte_Boundary;
+
procedure Set_Needs_Debug_Info (Id : E; V : B := True) is
begin
Set_Flag147 (Id, V);
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
+ procedure Set_Never_Set_In_Source (Id : E; V : B := True) is
+ begin
+ Set_Flag115 (Id, V);
+ end Set_Never_Set_In_Source;
+
procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is
begin
Set_Node12 (Id, V);
procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Root_Type (Id) = Id);
+ pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
Set_Flag131 (Id, V);
end Set_No_Pool_Assigned;
Set_Flag113 (Id, V);
end Set_No_Return;
+ procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Access_Type (Id) and then Base_Type (Id) = Id);
+ Set_Flag136 (Id, V);
+ end Set_No_Strict_Aliasing;
+
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
+ procedure Set_Non_Limited_View (Id : E; V : E) is
+ pragma Assert (False
+ or else Ekind (Id) = E_Incomplete_Type);
+ begin
+ Set_Node17 (Id, V);
+ end Set_Non_Limited_View;
+
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
pragma Assert
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
- Set_Uint9 (Id, V);
+ Set_Uint14 (Id, V);
end Set_Normalized_Position;
procedure Set_Normalized_Position_Max (Id : E; V : U) is
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
- procedure Set_Not_Source_Assigned (Id : E; V : B := True) is
- begin
- Set_Flag115 (Id, V);
- end Set_Not_Source_Assigned;
-
procedure Set_Object_Ref (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
Set_Node17 (Id, V);
end Set_Object_Ref;
+ procedure Set_Original_Access_Type (Id : E; V : E) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Access_Subprogram_Type
+ or else Ekind (Id) = E_Access_Protected_Subprogram_Type);
+ Set_Node21 (Id, V);
+ end Set_Original_Access_Type;
+
+ procedure Set_Original_Array_Type (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Array_Type (Id) or else Is_Modular_Integer_Type (Id));
+ Set_Node21 (Id, V);
+ end Set_Original_Array_Type;
+
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
+ pragma Assert
+ (Ekind (Id) = E_Void
+ or else Ekind (Id) = E_Component
+ or else Ekind (Id) = E_Discriminant);
Set_Node22 (Id, V);
end Set_Original_Record_Component;
Set_Flag156 (Id, V);
end Set_Referenced;
+ procedure Set_Referenced_As_LHS (Id : E; V : B := True) is
+ begin
+ Set_Flag36 (Id, V);
+ end Set_Referenced_As_LHS;
+
procedure Set_Referenced_Object (Id : E; V : N) is
begin
pragma Assert (Is_Type (Id));
procedure Set_Related_Instance (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Package);
+ pragma Assert
+ (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
Set_Node15 (Id, V);
end Set_Related_Instance;
procedure Set_Size_Check_Code (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
- Set_Node9 (Id, V);
+ Set_Node19 (Id, V);
end Set_Size_Check_Code;
procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True) is
Set_Node15 (Id, V);
end Set_Storage_Size_Variable;
+ procedure Set_Stored_Constraint (Id : E; V : L) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ Set_Elist23 (Id, V);
+ end Set_Stored_Constraint;
+
procedure Set_Strict_Alignment (Id : E; V : B := True) is
begin
pragma Assert (Base_Type (Id) = Id);
Set_Node15 (Id, V);
end Set_String_Literal_Low_Bound;
- 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_Elaboration_Warnings (Id : E; V : B := True) is
begin
Set_Flag148 (Id, V);
end Set_Suppress_Elaboration_Warnings;
- procedure Set_Suppress_Index_Checks (Id : E; V : B := True) is
- begin
- Set_Flag36 (Id, V);
- end Set_Suppress_Index_Checks;
-
procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is
begin
+ pragma Assert (Id = Base_Type (Id));
Set_Flag105 (Id, V);
end Set_Suppress_Init_Proc;
- 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_Style_Checks (Id : E; V : B := True) is
begin
Set_Flag165 (Id, V);
end Set_Suppress_Style_Checks;
- procedure Set_Suppress_Tag_Checks (Id : E; V : B := True) is
+ procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
- end Set_Suppress_Tag_Checks;
+ end Set_Treat_As_Volatile;
procedure Set_Underlying_Full_View (Id : E; V : E) is
begin
procedure Init_Normalized_Position (Id : E) is
begin
- Set_Uint9 (Id, No_Uint);
+ Set_Uint14 (Id, No_Uint);
end Init_Normalized_Position;
procedure Init_Normalized_Position (Id : E; V : Int) is
begin
- Set_Uint9 (Id, UI_From_Int (V));
+ Set_Uint14 (Id, UI_From_Int (V));
end Init_Normalized_Position;
procedure Init_Normalized_Position_Max (Id : E) is
procedure Init_Component_Location (Id : E) is
begin
Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit
- Set_Uint9 (Id, No_Uint); -- Normalized_Position
+ Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
Set_Uint11 (Id, No_Uint); -- Component_First_Bit
Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
+ Set_Uint14 (Id, No_Uint); -- Normalized_Position
end Init_Component_Location;
---------------
function Known_Alignment (E : Entity_Id) return B is
begin
- return Uint14 (E) /= Uint_0;
+ return Uint14 (E) /= Uint_0
+ and then Uint14 (E) /= No_Uint;
end Known_Alignment;
function Known_Component_Bit_Offset (E : Entity_Id) return B is
function Known_Component_Size (E : Entity_Id) return B is
begin
- return Uint22 (Base_Type (E)) /= Uint_0;
+ return Uint22 (Base_Type (E)) /= Uint_0
+ and then Uint22 (Base_Type (E)) /= No_Uint;
end Known_Component_Size;
function Known_Esize (E : Entity_Id) return B is
begin
- return Uint12 (E) /= Uint_0;
+ return Uint12 (E) /= Uint_0
+ and then Uint12 (E) /= No_Uint;
end Known_Esize;
function Known_Normalized_First_Bit (E : Entity_Id) return B is
function Known_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) /= No_Uint;
+ return Uint14 (E) /= No_Uint;
end Known_Normalized_Position;
function Known_Normalized_Position_Max (E : Entity_Id) return B is
function Known_RM_Size (E : Entity_Id) return B is
begin
- return Uint13 (E) /= Uint_0
- or else Is_Discrete_Type (E);
+ return Uint13 (E) /= No_Uint
+ and then (Uint13 (E) /= Uint_0
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E));
end Known_RM_Size;
function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is
return Uint12 (E) > Uint_0;
end Known_Static_Esize;
+ function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is
+ begin
+ return Uint8 (E) /= No_Uint
+ and then Uint8 (E) >= Uint_0;
+ end Known_Static_Normalized_First_Bit;
+
function Known_Static_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) /= No_Uint
- and then Uint9 (E) >= Uint_0;
+ return Uint14 (E) /= No_Uint
+ and then Uint14 (E) >= Uint_0;
end Known_Static_Normalized_Position;
function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is
function Known_Static_RM_Size (E : Entity_Id) return B is
begin
return Uint13 (E) > Uint_0
- or else Is_Discrete_Type (E);
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E);
end Known_Static_RM_Size;
function Unknown_Alignment (E : Entity_Id) return B is
begin
- return Uint14 (E) = Uint_0;
+ return Uint14 (E) = Uint_0
+ or else Uint14 (E) = No_Uint;
end Unknown_Alignment;
function Unknown_Component_Bit_Offset (E : Entity_Id) return B is
function Unknown_Component_Size (E : Entity_Id) return B is
begin
- return Uint22 (Base_Type (E)) = Uint_0;
+ return Uint22 (Base_Type (E)) = Uint_0
+ or else
+ Uint22 (Base_Type (E)) = No_Uint;
end Unknown_Component_Size;
function Unknown_Esize (E : Entity_Id) return B is
begin
- return Uint12 (E) = Uint_0;
+ return Uint12 (E) = No_Uint
+ or else
+ Uint12 (E) = Uint_0;
end Unknown_Esize;
function Unknown_Normalized_First_Bit (E : Entity_Id) return B is
function Unknown_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) = No_Uint;
+ return Uint14 (E) = No_Uint;
end Unknown_Normalized_Position;
function Unknown_Normalized_Position_Max (E : Entity_Id) return B is
function Unknown_RM_Size (E : Entity_Id) return B is
begin
- return Uint13 (E) = Uint_0
- and then not Is_Discrete_Type (E);
+ return (Uint13 (E) = Uint_0
+ and then not Is_Discrete_Type (E)
+ and then not Is_Fixed_Point_Type (E))
+ or else Uint13 (E) = No_Uint;
end Unknown_RM_Size;
--------------------
begin
case Ekind (Id) is
when E_Enumeration_Subtype |
+ E_Incomplete_Type |
E_Signed_Integer_Subtype |
E_Modular_Integer_Subtype |
E_Floating_Point_Subtype |
E_Class_Wide_Subtype =>
return Etype (Id);
- when E_Incomplete_Type =>
- if Present (Etype (Id)) then
- return Etype (Id);
- else
- return Id;
- end if;
-
when others =>
return Id;
end case;
-- True True Calign_Storage_Unit
function Component_Alignment (Id : E) return C is
- BT : Node_Id := Base_Type (Id);
+ BT : constant Node_Id := Base_Type (Id);
begin
pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
elsif Nkind (D) = N_Component_Declaration then
return Empty;
- else
- if Present (Expression (D)) then
- return (Expression (D));
+ -- If there is an expression, return it
- elsif Present (Full_View (Id)) then
- Full_D := Parent (Full_View (Id));
+ elsif Present (Expression (D)) then
+ return (Expression (D));
- -- The full view may have been rewritten as an object renaming.
+ -- For a constant, see if we have a full view
- if Nkind (Full_D) = N_Object_Renaming_Declaration then
- return Name (Full_D);
- else
- return Expression (Full_D);
- end if;
+ elsif Ekind (Id) = E_Constant
+ and then Present (Full_View (Id))
+ then
+ Full_D := Parent (Full_View (Id));
+
+ -- The full view may have been rewritten as an object renaming.
+
+ if Nkind (Full_D) = N_Object_Renaming_Declaration then
+ return Name (Full_D);
else
- return Empty;
+ return Expression (Full_D);
end if;
+
+ -- Otherwise we have no expression to return
+
+ else
+ return Empty;
end if;
end Constant_Value;
begin
Desig_Type := Directly_Designated_Type (Id);
- if (Ekind (Desig_Type) = E_Incomplete_Type
- and then Present (Full_View (Desig_Type)))
+ if Ekind (Desig_Type) = E_Incomplete_Type
+ and then Present (Full_View (Desig_Type))
then
return Full_View (Desig_Type);
S : Entity_Id;
begin
+ -- The following test is an error defense against some syntax
+ -- errors that can leave scopes very messed up.
+
+ if Id = Standard_Standard then
+ return Id;
+ end if;
+
+ -- Normal case, search enclosing scopes
+
S := Scope (Id);
while S /= Standard_Standard
and then not Is_Dynamic_Scope (S)
end Entry_Index_Type;
---------------------
- -- First_Component --
+ -- 1 --
---------------------
function First_Component (Id : E) return E is
(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);
Ent := Next_Entity (Ent);
end if;
- -- Skip all hidden girder discriminants if any.
+ -- Skip all hidden stored discriminants if any.
while Present (Ent) loop
exit when Ekind (Ent) = E_Discriminant
end First_Formal;
-------------------------------
- -- First_Girder_Discriminant --
+ -- First_Stored_Discriminant --
-------------------------------
- function First_Girder_Discriminant (Id : E) return E is
+ function First_Stored_Discriminant (Id : E) return E is
Ent : Entity_Id;
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean;
-- Scans the Discriminants to see whether any are Completely_Hidden
- -- (the mechanism for describing non-specified girder discriminants)
+ -- (the mechanism for describing non-specified stored discriminants)
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
Ent : Entity_Id := Id;
return False;
end Has_Completely_Hidden_Discriminant;
- -- Start of processing for First_Girder_Discriminant
+ -- Start of processing for First_Stored_Discriminant
begin
pragma Assert
pragma Assert (Ekind (Ent) = E_Discriminant);
return Ent;
- end First_Girder_Discriminant;
+ end First_Stored_Discriminant;
-------------------
-- First_Subtype --
end if;
end First_Subtype;
+ -------------------------------------
+ -- Get_Attribute_Definition_Clause --
+ -------------------------------------
+
+ function Get_Attribute_Definition_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id)
+ return Node_Id
+ is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) = Id
+ then
+ return N;
+ else
+ Next_Rep_Item (N);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Attribute_Definition_Clause;
+
+ --------------------
+ -- Get_Rep_Pragma --
+ --------------------
+
+ function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
+ N : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ N := First_Rep_Item (E);
+
+ while Present (N) loop
+ if Nkind (N) = N_Pragma and then Chars (N) = Nam then
+
+ if Nam = Name_Stream_Convert then
+
+ -- For tagged types this pragma is not inherited, so we
+ -- must verify that it is defined for the given type and
+ -- not an ancestor.
+
+ Typ := Entity (Expression
+ (First (Pragma_Argument_Associations (N))));
+
+ if not Is_Tagged_Type (E)
+ or else E = Typ
+ or else (Is_Private_Type (Typ)
+ and then E = Full_View (Typ))
+ then
+ return N;
+ else
+ Next_Rep_Item (N);
+ end if;
+
+ else
+ return N;
+ end if;
+ else
+ Next_Rep_Item (N);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Rep_Pragma;
+
------------------------
-- Has_Attach_Handler --
------------------------
-- happen in error situations and should avoid some error bombs.
if Present (Imptyp) then
- return Imptyp;
+ return Base_Type (Imptyp);
else
return Bastyp;
end if;
return True;
elsif Is_Record_Type (Btype) then
-
if Is_Limited_Record (Btype)
or else Is_Tagged_Type (Btype)
or else Is_Volatile (Btype)
--------------------------
function Is_Protected_Private (Id : E) return B is
-
begin
pragma Assert (Ekind (Id) = E_Component);
return Is_Protected_Type (Scope (Id));
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)));
+ and then Number_Dimensions (Id) = 1
+ and then Is_Character_Type (Component_Type (Id)));
end Is_String_Type;
-------------------------
-----------------------
-- This function actually implements both Next_Discriminant and
- -- Next_Girder_Discriminant by making sure that the Discriminant
+ -- Next_Stored_Discriminant by making sure that the Discriminant
-- returned is of the same variety as Id.
function Next_Discriminant (Id : E) return E is
-- Derived Tagged types with private extensions look like this...
- --
+
-- E_Discriminant d1
-- E_Discriminant d2
-- E_Component _tag
-- E_Discriminant d1
-- E_Discriminant d2
-- ...
+
-- so it is critical not to go past the leading discriminants.
D : E := Id;
begin
if Present (Extra_Formal (Id)) then
return Extra_Formal (Id);
-
else
return Next_Formal (Id);
end if;
end Next_Formal_With_Extras;
- ------------------------------
- -- Next_Girder_Discriminant --
- ------------------------------
-
- function Next_Girder_Discriminant (Id : E) return E is
- begin
- -- See comment in Next_Discriminant
-
- return Next_Discriminant (Id);
- end Next_Girder_Discriminant;
-
----------------
-- Next_Index --
----------------
return Next (Id);
end Next_Literal;
+ ------------------------------
+ -- Next_Stored_Discriminant --
+ ------------------------------
+
+ function Next_Stored_Discriminant (Id : E) return E is
+ begin
+ -- See comment in Next_Discriminant
+
+ return Next_Discriminant (Id);
+ end Next_Stored_Discriminant;
+
-----------------------
-- Number_Dimensions --
-----------------------
if T = Etyp then
return T;
+ -- Following test catches some error cases resulting from
+ -- previous errors.
+
+ elsif No (Etyp) then
+ return T;
+
elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
return T;
end if;
T := Etyp;
+
+ -- Return if there is a circularity in the inheritance chain.
+ -- This happens in some error situations and we do not want
+ -- to get stuck in this loop.
+
+ if T = Base_Type (Id) then
+ return T;
+ end if;
end loop;
end if;
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.
-- then we return the Underlying_Type of this full view
if Present (Full_View (Id)) then
- return Underlying_Type (Full_View (Id));
+ if Id = Full_View (Id) then
+
+ -- Previous error in declaration
+
+ return Empty;
+
+ else
+ return Underlying_Type (Full_View (Id));
+ end if;
-- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type.
end if;
W ("Address_Taken", Flag104 (Id));
+ W ("Body_Needed_For_SAL", Flag40 (Id));
W ("C_Pass_By_Copy", Flag125 (Id));
+ W ("Can_Never_Be_Null", Flag38 (Id));
+ W ("Checks_May_Be_Suppressed", Flag31 (Id));
W ("Debug_Info_Off", Flag166 (Id));
W ("Default_Expressions_Processed", Flag108 (Id));
W ("Delay_Cleanups", Flag114 (Id));
W ("Depends_On_Private", Flag14 (Id));
W ("Discard_Names", Flag88 (Id));
W ("Elaborate_All_Desirable", Flag146 (Id));
- W ("Elaboration_Entity_Required", Flag175 (Id));
+ W ("Elaboration_Entity_Required", Flag174 (Id));
W ("Entry_Accepted", Flag152 (Id));
W ("Finalize_Storage_Only", Flag158 (Id));
W ("From_With_Type", Flag159 (Id));
W ("Has_Completion_In_Body", Flag71 (Id));
W ("Has_Complex_Representation", Flag140 (Id));
W ("Has_Component_Size_Clause", Flag68 (Id));
+ W ("Has_Contiguous_Rep", Flag181 (Id));
W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Has_Pragma_Pack", Flag121 (Id));
+ W ("Has_Pragma_Pure_Function", Flag179 (Id));
+ W ("Has_Pragma_Unreferenced", Flag180 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
+ W ("Has_Xref_Entry", Flag182 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_Called", Flag102 (Id));
W ("Is_Character_Type", Flag63 (Id));
W ("Is_Child_Unit", Flag73 (Id));
+ W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id));
W ("Is_Compilation_Unit", Flag149 (Id));
W ("Is_Completely_Hidden", Flag103 (Id));
W ("Is_Concurrent_Record_Type", Flag20 (Id));
W ("Is_Constructor", Flag76 (Id));
W ("Is_Controlled", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
- W ("Is_Destructor", Flag77 (Id));
W ("Is_Discrim_SO_Function", Flag176 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
W ("Is_Itype", Flag91 (Id));
+ W ("Is_Known_Valid", Flag37 (Id));
W ("Is_Known_Valid", Flag170 (Id));
W ("Is_Limited_Composite", Flag106 (Id));
W ("Is_Limited_Record", Flag25 (Id));
+ W ("Is_Machine_Code_Subprogram", Flag137 (Id));
W ("Is_Non_Static_Subtype", Flag109 (Id));
W ("Is_Null_Init_Proc", Flag178 (Id));
W ("Is_Optional_Parameter", Flag134 (Id));
+ W ("Is_Overriding_Operation", Flag39 (Id));
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
+ W ("Is_Thread_Body", Flag77 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
W ("Is_Valued_Procedure", Flag127 (Id));
W ("Is_Visible_Child_Unit", Flag116 (Id));
W ("Is_Volatile", Flag16 (Id));
+ W ("Kill_Elaboration_Checks", Flag32 (Id));
+ W ("Kill_Range_Checks", Flag33 (Id));
+ W ("Kill_Tag_Checks", Flag34 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id));
+ W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
+ W ("Never_Set_In_Source", Flag115 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
W ("No_Return", Flag113 (Id));
+ W ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
- W ("Not_Source_Assigned", Flag115 (Id));
W ("Reachable", Flag49 (Id));
W ("Referenced", Flag156 (Id));
+ W ("Referenced_As_LHS", Flag36 (Id));
W ("Return_Present", Flag54 (Id));
W ("Returns_By_Ref", Flag90 (Id));
W ("Reverse_Bit_Order", Flag164 (Id));
W ("Size_Depends_On_Discriminant", Flag177 (Id));
W ("Size_Known_At_Compile_Time", Flag92 (Id));
W ("Strict_Alignment", Flag145 (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_Elaboration_Warnings", Flag148 (Id));
- W ("Suppress_Index_Checks", Flag36 (Id));
W ("Suppress_Init_Proc", Flag105 (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_Style_Checks", Flag165 (Id));
- W ("Suppress_Tag_Checks", Flag41 (Id));
+ W ("Treat_As_Volatile", Flag41 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
-
end Write_Entity_Flags;
-----------------------
-----------------------
procedure Write_Field6_Name (Id : Entity_Id) is
+ pragma Warnings (Off, Id);
+
begin
Write_Str ("First_Rep_Item");
end Write_Field6_Name;
-----------------------
procedure Write_Field7_Name (Id : Entity_Id) is
+ pragma Warnings (Off, Id);
+
begin
Write_Str ("Freeze_Node");
end Write_Field7_Name;
Write_Str ("Normalized_First_Bit");
when Formal_Kind |
- E_Function =>
+ E_Function |
+ E_Subprogram_Body =>
Write_Str ("Mechanism");
when Type_Kind =>
when Type_Kind =>
Write_Str ("Class_Wide_Type");
- when E_Constant | E_Variable =>
- Write_Str ("Size_Check_Code");
-
when E_Function |
E_Generic_Function |
E_Generic_Package |
E_Procedure =>
Write_Str ("Renaming_Map");
- when E_Component |
- E_Discriminant =>
- Write_Str ("Normalized_Position");
+ when Object_Kind =>
+ Write_Str ("Current_Value");
when others =>
Write_Str ("Field9??");
E_Entry_Family =>
Write_Str ("Protected_Body_Subprogram");
+ when E_Generic_Package =>
+ Write_Str ("Generic_Homonym");
+
when Type_Kind =>
Write_Str ("Full_View");
begin
case Ekind (Id) is
when Type_Kind |
- Object_Kind =>
+ Formal_Kind |
+ E_Constant |
+ E_Variable |
+ E_Loop_Parameter =>
Write_Str ("Alignment");
+ when E_Component |
+ E_Discriminant =>
+ Write_Str ("Normalized_Position");
+
when E_Function |
E_Procedure =>
Write_Str ("First_Optional_Parameter");
when Enumeration_Kind =>
Write_Str ("Lit_Indexes");
- when E_Package =>
+ when E_Package |
+ E_Package_Body =>
Write_Str ("Related_Instance");
when E_Protected_Type =>
E_Variable =>
Write_Str ("Actual_Subtype");
+ when E_Incomplete_Type =>
+ Write_Str ("Non-limited view");
+
when others =>
Write_Str ("Field17??");
end case;
Entry_Kind =>
Write_Str ("Finalization_Chain_Entity");
+ when E_Constant | E_Variable =>
+ Write_Str ("Size_Check_Code");
+
when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
when E_In_Parameter =>
Write_Str ("Default_Expr_Function");
+ when Array_Kind |
+ Modular_Integer_Kind =>
+ Write_Str ("Original_Array_Type");
+
+ when E_Access_Subprogram_Type |
+ E_Access_Protected_Subprogram_Type =>
+ Write_Str ("Original_Access_Type");
+
when others =>
Write_Str ("Field21??");
end case;
Class_Wide_Kind |
E_Record_Type |
E_Record_Subtype =>
- Write_Str ("Girder_Constraint");
+ Write_Str ("Stored_Constraint");
when E_Function |
- E_Package |
E_Procedure =>
Write_Str ("Generic_Renamings");
+ when E_Package =>
+ if Is_Generic_Instance (Id) then
+ Write_Str ("Generic_Renamings");
+ else
+ Write_Str ("Limited Views");
+ end if;
+
-- What about Privals_Chain for protected operations ???
when Entry_Kind =>
N := Next_Formal_With_Extras (N);
end Proc_Next_Formal_With_Extras;
- procedure Proc_Next_Girder_Discriminant (N : in out Node_Id) is
- begin
- N := Next_Girder_Discriminant (N);
- end Proc_Next_Girder_Discriminant;
-
procedure Proc_Next_Index (N : in out Node_Id) is
begin
N := Next_Index (N);
N := Next_Literal (N);
end Proc_Next_Literal;
+ procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is
+ begin
+ N := Next_Stored_Discriminant (N);
+ end Proc_Next_Stored_Discriminant;
+
end Einfo;
OSDN Git Service
