-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
pragma Style_Checks (All_Checks);
-- Turn off subprogram ordering, not used for this unit
-with Atree; use Atree;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
+with Atree; use Atree;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
package body Einfo is
-- Usage of Fields in Defining Entity Nodes --
----------------------------------------------
- -- 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
+ -- Four of these fields are defined in Sinfo, since they in are the base
+ -- part of the node. The access routines for these four fields and the
-- corresponding set procedures are defined in Sinfo. These fields 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,
-- Normalized_First_Bit Uint8
-- Postcondition_Proc Node8
-- Return_Applies_To Node8
+ -- First_Exit_Statement Node8
-- Class_Wide_Type Node9
-- Current_Value Node9
-- Renaming_Map Uint9
+ -- Direct_Primitive_Operations Elist10
-- Discriminal_Link Node10
+ -- Float_Rep Uint10 (but returns Float_Rep_Kind)
-- Handler_Records List10
-- Normalized_Position_Max Uint10
- -- Referenced_Object Node10
-- Component_Bit_Offset Uint11
-- Full_View Node11
-- Entry_Parameters_Type Node15
-- Extra_Formal Node15
-- Lit_Indexes Node15
- -- Primitive_Operations Elist15
-- Related_Instance Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- Alias Node18
-- Corresponding_Concurrent_Type Node18
+ -- Corresponding_Protected_Entry Node18
-- Corresponding_Record_Type Node18
-- Delta_Value Ureal18
-- Enclosing_Scope Node18
-- Related_Expression Node24
-- Spec_PPC_List Node24
- -- Underlying_Record_View Node24
-- Interface_Alias Node25
-- Interfaces Elist25
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
+ -- PPC_Wrapper Node25
+ -- Static_Predicate List25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrappers Elist26
-- Last_Assignment Node26
-- Overridden_Operation Node26
-- Package_Instantiation Node26
- -- Related_Type Node26
-- Relative_Deadline_Variable Node26
-- Static_Initialization Node26
-- Current_Use_Clause Node27
+ -- Related_Type Node27
-- Wrapped_Entity Node27
-- Extra_Formals Node28
+ -- Underlying_Record_View Node28
+
+ -- Subprograms_For_Type Node29
---------------------------------------------
-- Usage of Flags in Defining Entity Nodes --
-- sense for them to be set true for certain subsets of entity kinds. See
-- the spec of Einfo for further details.
- -- Note: Flag1-Flag3 are absent from this list, since these flag positions
- -- are used for the flags Analyzed, Comes_From_Source, and Error_Posted,
- -- which are common to all nodes, including entity nodes.
+ -- Note: Flag1-Flag3 are absent from this list, for historical reasons
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- 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_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
- -- Vax_Float Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- Is_Limited_Interface Flag197
- -- Is_Protected_Interface Flag198
- -- Is_Synchronized_Interface Flag199
- -- Is_Task_Interface Flag200
+ -- Has_Pragma_Ordered Flag198
+ -- Is_Ada_2012_Only Flag199
+ -- Has_Delayed_Aspects Flag200
-- Has_Anon_Block_Suffix Flag201
-- Itype_Printed Flag202
-- Has_Pragma_Pure Flag203
-- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
- -- Implemented_By_Entry Flag232
+ -- Has_Invariants Flag232
-- Has_Pragma_Unmodified Flag233
-- Is_Dispatch_Table_Entity Flag234
-- Is_Trivial_Subprogram Flag235
-- Is_Private_Primitive Flag245
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
+ -- Has_Inheritable_Invariants Flag248
+ -- Has_Predicates Flag250
+
+ -- (unused) Flag39
+ -- (unused) Flag151
+ -- (unused) Flag249
+ -- (unused) Flag251
+ -- (unused) Flag252
+ -- (unused) Flag253
+ -- (unused) Flag254
-----------------------
-- Local subprograms --
-- Returns the attribute definition clause for Id whose name is Rep_Name.
-- Returns Empty if no matching attribute definition clause found for Id.
+ ---------------
+ -- Float_Rep --
+ ---------------
+
+ function Float_Rep (Id : E) return F is
+ pragma Assert (Is_Floating_Point_Type (Id));
+ begin
+ return F'Val (UI_To_Int (Uint10 (Base_Type (Id))));
+ end Float_Rep;
+
----------------
-- Rep_Clause --
----------------
then
return Ritem;
else
- Ritem := Next_Rep_Item (Ritem);
+ Next_Rep_Item (Ritem);
end if;
end loop;
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
+ (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter)
or else Is_Formal (Id));
return Node17 (Id);
end Actual_Subtype;
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);
+ or else Ekind_In (Id, E_Loop_Parameter,
+ E_Constant,
+ E_Exception,
+ E_Variable));
return Uint14 (Id);
end Alignment;
function Body_Entity (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
return Node19 (Id);
end Body_Entity;
function Cloned_Subtype (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Class_Wide_Subtype);
+ pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype));
return Node16 (Id);
end Cloned_Subtype;
function Component_Bit_Offset (Id : E) return U is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
return Uint11 (Id);
end Component_Bit_Offset;
function Component_Clause (Id : E) return N is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
return Node13 (Id);
end Component_Clause;
function Component_Type (Id : E) return E is
begin
+ pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
return Node20 (Implementation_Base_Type (Id));
end Component_Type;
return Node13 (Id);
end Corresponding_Equality;
+ function Corresponding_Protected_Entry (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Subprogram_Body);
+ return Node18 (Id);
+ end Corresponding_Protected_Entry;
+
function Corresponding_Record_Type (Id : E) return E is
begin
pragma Assert (Is_Concurrent_Type (Id));
return Uint17 (Id);
end Digits_Value;
+ function Direct_Primitive_Operations (Id : E) return L is
+ begin
+ pragma Assert (Is_Tagged_Type (Id));
+ return Elist10 (Id);
+ end Direct_Primitive_Operations;
+
function Directly_Designated_Type (Id : E) return E is
begin
+ pragma Assert (Is_Access_Type (Id));
return Node20 (Id);
end Directly_Designated_Type;
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)));
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ and then Present (DTC_Entity (Id)));
return Uint15 (Id);
end DT_Position;
function DTC_Entity (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Node16 (Id);
end DTC_Entity;
function Equivalent_Type (Id : E) return E is
begin
pragma Assert
- (Ekind (Id) = E_Class_Wide_Subtype or else
- Ekind (Id) = E_Access_Protected_Subprogram_Type or else
- Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else
- Ekind (Id) = E_Access_Subprogram_Type or else
- Ekind (Id) = E_Exception_Type);
+ (Ekind_In (Id, E_Class_Wide_Type,
+ E_Class_Wide_Subtype,
+ E_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Access_Subprogram_Type,
+ E_Exception_Type));
return Node18 (Id);
end Equivalent_Type;
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Subprogram_Body
- or else Ekind (Id) = E_Subprogram_Type);
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
return Node28 (Id);
end Extra_Formals;
return Node17 (Id);
end First_Entity;
+ function First_Exit_Statement (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ return Node8 (Id);
+ end First_Exit_Statement;
+
function First_Index (Id : E) return N is
begin
pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
function First_Optional_Parameter (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Node14 (Id);
end First_Optional_Parameter;
function First_Private_Entity (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Package
- or else Ekind (Id) = E_Generic_Package
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
or else Ekind (Id) in Concurrent_Kind);
return Node16 (Id);
end First_Private_Entity;
return Flag119 (Id);
end Has_Convention_Pragma;
+ function Has_Delayed_Aspects (Id : E) return B is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ return Flag200 (Id);
+ end Has_Delayed_Aspects;
+
function Has_Delayed_Freeze (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag56 (Id);
end Has_Homonym;
+ function Has_Inheritable_Invariants (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag248 (Id);
+ end Has_Inheritable_Invariants;
+
function Has_Initial_Value (Id : E) return B is
begin
- pragma Assert
- (Ekind (Id) = E_Variable or else Is_Formal (Id));
+ pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id));
return Flag219 (Id);
end Has_Initial_Value;
+ function Has_Invariants (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+ return Flag232 (Id);
+ end Has_Invariants;
+
function Has_Machine_Radix_Clause (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
function Has_Missing_Return (Id : E) return B is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function);
+ pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
return Flag142 (Id);
end Has_Missing_Return;
return Flag230 (Id);
end Has_Pragma_Inline_Always;
+ function Has_Pragma_Ordered (Id : E) return B is
+ begin
+ pragma Assert (Is_Enumeration_Type (Id));
+ return Flag198 (Implementation_Base_Type (Id));
+ end Has_Pragma_Ordered;
+
function Has_Pragma_Pack (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
return Flag212 (Id);
end Has_Pragma_Unreferenced_Objects;
+ function Has_Predicates (Id : E) return B is
+ begin
+ return Flag250 (Id);
+ end Has_Predicates;
+
function Has_Primitive_Operations (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
function Has_Thunks (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Constant);
return Flag228 (Id);
end Has_Thunks;
function Has_Up_Level_Access (Id : E) return B is
begin
pragma Assert
- (Ekind (Id) = E_Variable
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Loop_Parameter);
+ (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter));
return Flag215 (Id);
end Has_Up_Level_Access;
return Node4 (Id);
end Homonym;
- function Implemented_By_Entry (Id : E) return B is
+ function Interface_Alias (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
- return Flag232 (Id);
- end Implemented_By_Entry;
+ pragma Assert (Is_Subprogram (Id));
+ return Node25 (Id);
+ end Interface_Alias;
function Interfaces (Id : E) return L is
begin
return Elist25 (Id);
end Interfaces;
- function Interface_Alias (Id : E) return E is
- begin
- pragma Assert (Is_Subprogram (Id));
- return Node25 (Id);
- end Interface_Alias;
-
function In_Package_Body (Id : E) return B is
begin
return Flag48 (Id);
return Flag185 (Id);
end Is_Ada_2005_Only;
+ function Is_Ada_2012_Only (Id : E) return B is
+ begin
+ return Flag199 (Id);
+ end Is_Ada_2012_Only;
+
function Is_Aliased (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
function Is_Asynchronous (Id : E) return B is
begin
- pragma Assert
- (Ekind (Id) = E_Procedure or else Is_Type (Id));
+ pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id));
return Flag81 (Id);
end Is_Asynchronous;
function Is_Called (Id : E) return B is
begin
- pragma Assert
- (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function);
+ pragma Assert (Ekind_In (Id, E_Procedure, E_Function));
return Flag102 (Id);
end Is_Called;
function Is_For_Access_Subtype (Id : E) return B is
begin
- pragma Assert
- (Ekind (Id) = E_Record_Subtype
- or else
- Ekind (Id) = E_Private_Subtype);
+ pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype));
return Flag118 (Id);
end Is_For_Access_Subtype;
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);
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Generic_Function
- or else Ekind (Id) = E_Generic_Procedure);
+ or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure));
return Flag218 (Id);
end Is_Primitive;
function Is_Primitive_Wrapper (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag195 (Id);
end Is_Primitive_Wrapper;
function Is_Private_Primitive (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag245 (Id);
end Is_Private_Primitive;
- function Is_Protected_Interface (Id : E) return B is
- begin
- pragma Assert (Is_Interface (Id));
- return Flag198 (Id);
- end Is_Protected_Interface;
-
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag28 (Id);
end Is_Statically_Allocated;
- function Is_Synchronized_Interface (Id : E) return B is
- begin
- pragma Assert (Is_Interface (Id));
- return Flag199 (Id);
- end Is_Synchronized_Interface;
-
function Is_Tag (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag55 (Id);
end Is_Tagged_Type;
- function Is_Task_Interface (Id : E) return B is
- begin
- pragma Assert (Is_Interface (Id));
- return Flag200 (Id);
- end Is_Task_Interface;
-
function Is_Thunk (Id : E) return B is
begin
pragma Assert (Is_Subprogram (Id));
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Subprogram_Type
- or else Ekind (Id) = E_Entry_Family);
+ or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family));
return Flag22 (Id);
end Needs_No_Actuals;
function Normalized_First_Bit (Id : E) return U is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
return Uint8 (Id);
end Normalized_First_Bit;
function Normalized_Position (Id : E) return U is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
return Uint14 (Id);
end Normalized_Position;
function Normalized_Position_Max (Id : E) return U is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
return Uint10 (Id);
end Normalized_Position_Max;
function Optimize_Alignment_Space (Id : E) return B is
begin
pragma Assert
- (Is_Type (Id)
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
return Flag241 (Id);
end Optimize_Alignment_Space;
function Optimize_Alignment_Time (Id : E) return B is
begin
pragma Assert
- (Is_Type (Id)
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
return Flag242 (Id);
end Optimize_Alignment_Time;
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);
+ pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
return Node22 (Id);
end Original_Record_Component;
function Package_Instantiation (Id : E) return N is
begin
- pragma Assert
- (False
- or else Ekind (Id) = E_Generic_Package
- or else Ekind (Id) = E_Package);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
return Node26 (Id);
end Package_Instantiation;
function Parent_Subtype (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- return Node19 (Id);
+ pragma Assert (Is_Record_Type (Id));
+ return Node19 (Base_Type (Id));
end Parent_Subtype;
function Postcondition_Proc (Id : E) return E is
return Node8 (Id);
end Postcondition_Proc;
- function Primitive_Operations (Id : E) return L is
+ function PPC_Wrapper (Id : E) return E is
begin
- pragma Assert (Is_Tagged_Type (Id));
- return Elist15 (Id);
- end Primitive_Operations;
+ pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family));
+ return Node25 (Id);
+ end PPC_Wrapper;
function Prival (Id : E) return E is
begin
function Prival_Link (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
return Node20 (Id);
end Prival_Link;
function Protection_Object (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Entry
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure));
return Node23 (Id);
end Protection_Object;
return Flag227 (Id);
end Referenced_As_Out_Parameter;
- function Referenced_Object (Id : E) return N is
- begin
- pragma Assert (Is_Type (Id));
- return Node10 (Id);
- end Referenced_Object;
-
function Register_Exception_Call (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Exception);
function Related_Expression (Id : E) return N is
begin
- pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
+ pragma Assert (Ekind (Id) in Type_Kind
+ or else Ekind_In (Id, E_Constant, E_Variable));
return Node24 (Id);
end Related_Expression;
function Related_Instance (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
+ pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
return Node15 (Id);
end Related_Instance;
function Related_Type (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant);
- return Node26 (Id);
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ return Node27 (Id);
end Related_Type;
function Relative_Deadline_Variable (Id : E) return E is
function Shadow_Entities (Id : E) return S is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
return List14 (Id);
end Shadow_Entities;
function Size_Check_Code (Id : E) return N is
begin
- pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
return Node19 (Id);
end Size_Check_Code;
function Spec_Entity (Id : E) return E is
begin
- pragma Assert
- (Ekind (Id) = E_Package_Body or else Is_Formal (Id));
+ pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id));
return Node19 (Id);
end Spec_Entity;
function Spec_PPC_List (Id : E) return N is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Entry_Family)
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Subprogram (Id));
return Node24 (Id);
end Spec_PPC_List;
+ function Static_Predicate (Id : E) return S is
+ begin
+ pragma Assert (Is_Discrete_Type (Id));
+ return List25 (Id);
+ end Static_Predicate;
+
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 String_Literal_Low_Bound;
+ function Subprograms_For_Type (Id : E) return E is
+ begin
+ pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+ return Node29 (Id);
+ end Subprograms_For_Type;
+
function Suppress_Elaboration_Warnings (Id : E) return B is
begin
return Flag148 (Id);
function Underlying_Record_View (Id : E) return E is
begin
- return Node24 (Id);
+ return Node28 (Id);
end Underlying_Record_View;
function Universal_Aliasing (Id : E) return B is
return Flag95 (Id);
end Uses_Sec_Stack;
- function Vax_Float (Id : E) return B is
- begin
- return Flag151 (Base_Type (Id));
- end Vax_Float;
-
function Warnings_Off (Id : E) return B is
begin
return Flag96 (Id);
function Wrapped_Entity (Id : E) return E is
begin
- pragma Assert ((Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure)
- and then Is_Primitive_Wrapper (Id));
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Id));
return Node27 (Id);
end Wrapped_Entity;
return Ekind (Id) in Access_Subprogram_Kind;
end Is_Access_Subprogram_Type;
+ function Is_Aggregate_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Aggregate_Kind;
+ end Is_Aggregate_Type;
+
function Is_Array_Type (Id : E) return B is
begin
return Ekind (Id) in Array_Kind;
function Is_Signed_Integer_Type (Id : E) return B is
begin
- return Ekind (Id) in
- Signed_Integer_Kind;
+ return Ekind (Id) in Signed_Integer_Kind;
end Is_Signed_Integer_Type;
function Is_Subprogram (Id : E) return B is
-- Attribute Set Procedures --
------------------------------
+ -- Note: in many of these set procedures an "obvious" assertion is missing.
+ -- The reason for this is that in many cases, a field is set before the
+ -- Ekind field is set, so that the field is set when Ekind = E_Void. It
+ -- it is possible to add assertions that specifically include the E_Void
+ -- possibility, but in some cases, we just omit the assertions.
+
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
procedure Set_Access_Disp_Table (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
procedure Set_Associated_Storage_Pool (Id : E; V : E) is
begin
- pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Node22 (Id, V);
end Set_Associated_Storage_Pool;
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
+ (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter)
or else Is_Formal (Id));
Set_Node17 (Id, V);
end Set_Actual_Subtype;
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);
+ or else Is_Formal (Id)
+ or else Ekind_In (Id, E_Loop_Parameter,
+ E_Constant,
+ E_Exception,
+ E_Variable));
Set_Uint14 (Id, V);
end Set_Alignment;
procedure Set_Body_Entity (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
Set_Node19 (Id, V);
end Set_Body_Entity;
begin
pragma Assert
(Ekind (Id) = E_Package
- or else Is_Subprogram (Id)
- or else Is_Generic_Unit (Id));
+ 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));
+ pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag125 (Id, V);
end Set_C_Pass_By_Copy;
procedure Set_Cloned_Subtype (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Class_Wide_Subtype);
+ pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype));
Set_Node16 (Id, V);
end Set_Cloned_Subtype;
procedure Set_Component_Bit_Offset (Id : E; V : U) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
Set_Uint11 (Id, V);
end Set_Component_Bit_Offset;
procedure Set_Component_Clause (Id : E; V : N) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
Set_Node13 (Id, V);
end Set_Component_Clause;
procedure Set_Component_Size (Id : E; V : U) is
begin
- pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Array_Type (Id) and then Is_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));
+ pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
Set_Node20 (Id, V);
end Set_Component_Type;
Set_Node13 (Id, V);
end Set_Corresponding_Equality;
+ procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body));
+ Set_Node18 (Id, V);
+ end Set_Corresponding_Protected_Entry;
+
procedure Set_Corresponding_Record_Type (Id : E; V : E) is
begin
pragma Assert (Is_Concurrent_Type (Id));
procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Subprogram (Id)
- or else Ekind (Id) = E_Package
- or else Ekind (Id) = E_Package_Body);
+ (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body));
Set_Flag50 (Id, V);
end Set_Delay_Subprogram_Descriptors;
procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
begin
- pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Tagged_Type (Id)
+ and then Is_Base_Type (Id)
+ and then Ekind_In (Id, E_Record_Type,
+ E_Record_Subtype,
+ E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private));
Set_Elist26 (Id, V);
end Set_Dispatch_Table_Wrappers;
procedure Set_DT_Position (Id : E; V : U) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Uint15 (Id, V);
end Set_DT_Position;
procedure Set_DTC_Entity (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Node16 (Id, V);
end Set_DTC_Entity;
procedure Set_Equivalent_Type (Id : E; V : E) is
begin
pragma Assert
- (Ekind (Id) = E_Class_Wide_Type or else
- Ekind (Id) = E_Class_Wide_Subtype or else
- Ekind (Id) = E_Access_Protected_Subprogram_Type or else
- Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else
- Ekind (Id) = E_Access_Subprogram_Type or else
- Ekind (Id) = E_Exception_Type);
+ (Ekind_In (Id, E_Class_Wide_Type,
+ E_Class_Wide_Subtype,
+ E_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Access_Subprogram_Type,
+ E_Exception_Type));
Set_Node18 (Id, V);
end Set_Equivalent_Type;
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Subprogram_Body
- or else Ekind (Id) = E_Subprogram_Type);
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
Set_Node28 (Id, V);
end Set_Extra_Formals;
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Access_Subprogram_Type (Id)
- and then Id = Base_Type (Id));
+ (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id));
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag158 (Id, V);
end Set_Finalize_Storage_Only;
Set_Node17 (Id, V);
end Set_First_Entity;
+ procedure Set_First_Exit_Statement (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ Set_Node8 (Id, V);
+ end Set_First_Exit_Statement;
+
procedure Set_First_Index (Id : E; V : N) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
procedure Set_First_Optional_Parameter (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Node14 (Id, V);
end Set_First_Optional_Parameter;
procedure Set_First_Private_Entity (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Package
- or else Ekind (Id) = E_Generic_Package
- or else Ekind (Id) in Concurrent_Kind);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)
+ or else Ekind (Id) in Concurrent_Kind);
Set_Node16 (Id, V);
end Set_First_Private_Entity;
Set_Node6 (Id, V);
end Set_First_Rep_Item;
+ procedure Set_Float_Rep (Id : E; V : F) is
+ pragma Assert (Ekind (Id) = E_Floating_Point_Type);
+ begin
+ Set_Uint10 (Id, UI_From_Int (F'Pos (V)));
+ end Set_Float_Rep;
+
procedure Set_Freeze_Node (Id : E; V : N) is
begin
Set_Node7 (Id, V);
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;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+ pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag86 (Id, V);
end Set_Has_Atomic_Components;
Set_Flag119 (Id, V);
end Set_Has_Convention_Pragma;
+ procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ Set_Flag200 (Id, V);
+ end Set_Has_Delayed_Aspects;
+
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag56 (Id, V);
end Set_Has_Homonym;
+ procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag248 (Id, V);
+ end Set_Has_Inheritable_Invariants;
+
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Variable or else Ekind (Id) = E_Out_Parameter);
+ pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter));
Set_Flag219 (Id, V);
end Set_Has_Initial_Value;
+ procedure Set_Has_Invariants (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Void);
+ Set_Flag232 (Id, V);
+ end Set_Has_Invariants;
+
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
procedure Set_Has_Missing_Return (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function);
+ pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function));
Set_Flag142 (Id, V);
end Set_Has_Missing_Return;
procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Variable
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Loop_Parameter);
+ pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter));
Set_Flag215 (Id, V);
end Set_Has_Up_Level_Access;
Set_Flag230 (Id, V);
end Set_Has_Pragma_Inline_Always;
+ procedure Set_Has_Pragma_Ordered (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Enumeration_Type (Id));
+ pragma Assert (Id = Base_Type (Id));
+ Set_Flag198 (Id, V);
+ end Set_Has_Pragma_Ordered;
+
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_Flag212 (Id, V);
end Set_Has_Pragma_Unreferenced_Objects;
+ procedure Set_Has_Predicates (Id : E; V : B := True) is
+ begin
+ Set_Flag250 (Id, V);
+ end Set_Has_Predicates;
+
procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
procedure Set_Has_Thunks (Id : E; V : B := True) is
begin
- pragma Assert (Is_Tag (Id)
- and then Ekind (Id) = E_Constant);
+ pragma Assert (Is_Tag (Id));
Set_Flag228 (Id, V);
end Set_Has_Thunks;
procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
begin
- pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+ pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
Set_Node4 (Id, V);
end Set_Homonym;
- procedure Set_Implemented_By_Entry (Id : E; V : B := True) is
+ procedure Set_Interface_Alias (Id : E; V : E) is
begin
pragma Assert
- (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
- Set_Flag232 (Id, V);
- end Set_Implemented_By_Entry;
+ (Is_Internal (Id)
+ and then Is_Hidden (Id)
+ and then (Ekind_In (Id, E_Procedure, E_Function)));
+ Set_Node25 (Id, V);
+ end Set_Interface_Alias;
procedure Set_Interfaces (Id : E; V : L) is
begin
Set_Elist25 (Id, V);
end Set_Interfaces;
- procedure Set_Interface_Alias (Id : E; V : E) is
- begin
- pragma Assert
- (Is_Internal (Id)
- and then Is_Hidden (Id)
- and then (Ekind (Id) = E_Procedure
- or else Ekind (Id) = E_Function));
- Set_Node25 (Id, V);
- end Set_Interface_Alias;
-
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
Set_Flag185 (Id, V);
end Set_Is_Ada_2005_Only;
+ procedure Set_Is_Ada_2012_Only (Id : E; V : B := True) is
+ begin
+ Set_Flag199 (Id, V);
+ end Set_Is_Ada_2012_Only;
+
procedure Set_Is_Aliased (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is
begin
pragma Assert ((not V)
- or else (Is_Array_Type (Id) and then Id = Base_Type (Id)));
+ or else (Is_Array_Type (Id) and then Is_Base_Type (Id)));
Set_Flag122 (Id, V);
end Set_Is_Bit_Packed_Array;
procedure Set_Is_Called (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function);
+ pragma Assert (Ekind_In (Id, E_Procedure, E_Function));
Set_Flag102 (Id, V);
end Set_Is_Called;
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Record_Subtype
- or else
- Ekind (Id) = E_Private_Subtype);
+ pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype));
Set_Flag118 (Id, V);
end Set_Is_For_Access_Subtype;
procedure Set_Is_Interface (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind (Id) = E_Record_Type
- or else Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Record_Type_With_Private
- or else Ekind (Id) = E_Record_Subtype_With_Private
- or else Ekind (Id) = E_Class_Wide_Type
- or else Ekind (Id) = E_Class_Wide_Subtype);
+ (Ekind_In (Id, E_Record_Type,
+ E_Record_Subtype,
+ E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private,
+ E_Class_Wide_Type,
+ E_Class_Wide_Subtype));
Set_Flag186 (Id, V);
end Set_Is_Interface;
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);
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Generic_Function
- or else Ekind (Id) = E_Generic_Procedure);
+ or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure));
Set_Flag218 (Id, V);
end Set_Is_Primitive;
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag195 (Id, V);
end Set_Is_Primitive_Wrapper;
procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
- procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Interface (Id));
- Set_Flag198 (Id, V);
- end Set_Is_Protected_Interface;
-
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is
begin
pragma Assert
- (Ekind (Id) = E_Exception
- or else Ekind (Id) = E_Variable
- or else Ekind (Id) = E_Constant
- or else Is_Type (Id)
- or else Ekind (Id) = E_Void);
+ (Is_Type (Id)
+ or else Ekind_In (Id, E_Exception,
+ E_Variable,
+ E_Constant,
+ E_Void));
Set_Flag28 (Id, V);
end Set_Is_Statically_Allocated;
- procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Interface (Id));
- Set_Flag199 (Id, V);
- end Set_Is_Synchronized_Interface;
-
procedure Set_Is_Tag (Id : E; V : B := True) is
begin
- pragma Assert
- (Ekind (Id) = E_Component
- or else Ekind (Id) = E_Constant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
Set_Flag78 (Id, V);
end Set_Is_Tag;
Set_Flag55 (Id, V);
end Set_Is_Tagged_Type;
- procedure Set_Is_Task_Interface (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Interface (Id));
- Set_Flag200 (Id, V);
- end Set_Is_Task_Interface;
-
procedure Set_Is_Thunk (Id : E; V : B := True) is
begin
Set_Flag225 (Id, V);
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Subprogram_Type
- or else Ekind (Id) = E_Entry_Family);
+ or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family));
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
begin
- pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Flag131 (Id, V);
end Set_No_Pool_Assigned;
procedure Set_No_Return (Id : E; V : B := True) is
begin
pragma Assert
- (V = False
- or else Ekind (Id) = E_Procedure
- or else Ekind (Id) = E_Generic_Procedure);
+ (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure));
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 Id = Base_Type (Id));
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
Set_Flag136 (Id, V);
end Set_No_Strict_Aliasing;
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
procedure Set_Normalized_First_Bit (Id : E; V : U) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
Set_Uint8 (Id, V);
end Set_Normalized_First_Bit;
procedure Set_Normalized_Position (Id : E; V : U) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
Set_Uint14 (Id, V);
end Set_Normalized_Position;
procedure Set_Normalized_Position_Max (Id : E; V : U) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
+ pragma Assert (Ekind_In (Id, E_Component, E_Discriminant));
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Record_Type (Id) and then Id = Base_Type (Id));
+ (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag239 (Id, V);
end Set_OK_To_Reorder_Components;
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Type (Id)
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
Set_Flag241 (Id, V);
end Set_Optimize_Alignment_Space;
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Type (Id)
- or else Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable));
Set_Flag242 (Id, V);
end Set_Optimize_Alignment_Time;
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);
+ pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
Set_Node22 (Id, V);
end Set_Original_Record_Component;
procedure Set_Package_Instantiation (Id : E; V : N) is
begin
- pragma Assert
- (Ekind (Id) = E_Void
- or else Ekind (Id) = E_Generic_Package
- or else Ekind (Id) = E_Package);
+ pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package));
Set_Node26 (Id, V);
end Set_Package_Instantiation;
Set_Node8 (Id, V);
end Set_Postcondition_Proc;
- procedure Set_Primitive_Operations (Id : E; V : L) is
+ procedure Set_PPC_Wrapper (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family));
+ Set_Node25 (Id, V);
+ end Set_PPC_Wrapper;
+
+ procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id));
- Set_Elist15 (Id, V);
- end Set_Primitive_Operations;
+ Set_Elist10 (Id, V);
+ end Set_Direct_Primitive_Operations;
procedure Set_Prival (Id : E; V : E) is
begin
procedure Set_Prival_Link (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable);
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
Set_Node20 (Id, V);
end Set_Prival_Link;
procedure Set_Protection_Object (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Entry
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Procedure));
Set_Node23 (Id, V);
end Set_Protection_Object;
Set_Flag227 (Id, V);
end Set_Referenced_As_Out_Parameter;
- procedure Set_Referenced_Object (Id : E; V : N) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Node10 (Id, V);
- end Set_Referenced_Object;
-
procedure Set_Register_Exception_Call (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Exception);
procedure Set_Related_Expression (Id : E; V : N) is
begin
+ pragma Assert (Ekind (Id) in Type_Kind
+ or else Ekind_In (Id, E_Constant, E_Variable, E_Void));
Set_Node24 (Id, V);
end Set_Related_Expression;
procedure Set_Related_Instance (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
+ pragma Assert (Ekind_In (Id, E_Package, E_Package_Body));
Set_Node15 (Id, V);
end Set_Related_Instance;
procedure Set_Related_Type (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant);
- Set_Node26 (Id, V);
+ pragma Assert (Ekind_In (Id, E_Component, E_Constant, E_Variable));
+ Set_Node27 (Id, V);
end Set_Related_Type;
procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
begin
- pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id));
Set_Node26 (Id, V);
end Set_Relative_Deadline_Variable;
procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is
begin
pragma Assert
- (Is_Record_Type (Id) and then Id = Base_Type (Id));
+ (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag164 (Id, V);
end Set_Reverse_Bit_Order;
procedure Set_Shadow_Entities (Id : E; V : S) is
begin
- pragma Assert
- (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package);
+ pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package));
Set_List14 (Id, V);
end Set_Shadow_Entities;
procedure Set_Size_Check_Code (Id : E; V : N) is
begin
- pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
+ pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
Set_Node19 (Id, V);
end Set_Size_Check_Code;
procedure Set_Spec_PPC_List (Id : E; V : N) is
begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
+ pragma Assert
+ (Ekind_In (Id, E_Entry, E_Entry_Family, E_Void)
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Subprogram (Id));
Set_Node24 (Id, V);
end Set_Spec_PPC_List;
+ procedure Set_Static_Predicate (Id : E; V : S) is
+ begin
+ pragma Assert
+ (Ekind_In (Id, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ and then Has_Predicates (Id));
+ Set_List25 (Id, V);
+ end Set_Static_Predicate;
+
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_String_Literal_Low_Bound;
+ procedure Set_Subprograms_For_Type (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+ Set_Node29 (Id, V);
+ end Set_Subprograms_For_Type;
+
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
begin
Set_Flag148 (Id, V);
procedure Set_Underlying_Record_View (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
- Set_Node24 (Id, V);
+ Set_Node28 (Id, V);
end Set_Underlying_Record_View;
procedure Set_Universal_Aliasing (Id : E; V : B := True) is
begin
- pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+ pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag216 (Id, V);
end Set_Universal_Aliasing;
Set_Flag222 (Id, V);
end Set_Used_As_Generic_Actual;
- procedure Set_Vax_Float (Id : E; V : B := True) is
- begin
- pragma Assert (Id = Base_Type (Id));
- Set_Flag151 (Id, V);
- end Set_Vax_Float;
-
procedure Set_Warnings_Off (Id : E; V : B := True) is
begin
Set_Flag96 (Id, V);
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
- pragma Assert ((Ekind (Id) = E_Function
- or else Ekind (Id) = E_Procedure)
- and then Is_Primitive_Wrapper (Id));
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Id));
Set_Node27 (Id, V);
end Set_Wrapped_Entity;
function Known_Static_Esize (E : Entity_Id) return B is
begin
- return Uint12 (E) > Uint_0;
+ return Uint12 (E) > Uint_0
+ and then not Is_Generic_Type (E);
end Known_Static_Esize;
function Known_Static_Normalized_First_Bit (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_Fixed_Point_Type (E);
+ return (Uint13 (E) > Uint_0
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E))
+ and then not Is_Generic_Type (E);
end Known_Static_RM_Size;
function Unknown_Alignment (E : Entity_Id) return B is
return Rep_Clause (Id, Name_Address);
end Address_Clause;
+ ---------------
+ -- Aft_Value --
+ ---------------
+
+ function Aft_Value (Id : E) return U is
+ Result : Nat := 1;
+ Delta_Val : Ureal := Delta_Value (Id);
+ begin
+ while Delta_Val < Ureal_Tenth loop
+ Delta_Val := Delta_Val * Ureal_10;
+ Result := Result + 1;
+ end loop;
+
+ return UI_From_Int (Result);
+ end Aft_Value;
+
----------------------
-- Alignment_Clause --
----------------------
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Subprogram_Body
- or else Ekind (Id) = E_Subprogram_Type);
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
begin
pragma Assert
(Is_Overloadable (Id)
- or else Ekind (Id) = E_Entry_Family
- or else Ekind (Id) = E_Subprogram_Body
- or else Ekind (Id) = E_Subprogram_Type);
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
if Ekind (Id) = E_Enumeration_Literal then
return Empty;
function Get_Full_View (T : Entity_Id) return Entity_Id is
begin
- if Ekind (T) = E_Incomplete_Type
- and then Present (Full_View (T))
- then
+ if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then
return Full_View (T);
elsif Is_Class_Wide_Type (T)
end if;
end Get_Full_View;
- --------------------
- -- Get_Rep_Pragma --
- --------------------
+ --------------------------------------
+ -- Get_Record_Representation_Clause --
+ --------------------------------------
- function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
+ function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
N : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
- if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
+ if Nkind (N) = N_Record_Representation_Clause then
return N;
end if;
end loop;
return Empty;
- end Get_Rep_Pragma;
+ end Get_Record_Representation_Clause;
- ------------------------
- -- Has_Attach_Handler --
- ------------------------
+ -----------------------------
+ -- Get_Rep_Item_For_Entity --
+ -----------------------------
- function Has_Attach_Handler (Id : E) return B is
- Ritem : Node_Id;
+ function Get_Rep_Item_For_Entity
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id
+ is
+ N : Node_Id;
+ Arg : Node_Id;
begin
- pragma Assert (Is_Protected_Type (Id));
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
+ Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
+
+ if Is_Entity_Name (Arg) and then Entity (Arg) = E then
+ return N;
+ end if;
+
+ elsif Nkind (N) = N_Attribute_Definition_Clause
+ and then Chars (N) = Nam
+ and then Entity (N) = E
+ then
+ return N;
+
+ elsif Nkind (N) = N_Aspect_Specification
+ and then Chars (Identifier (N)) = Nam
+ and then Entity (N) = E
+ then
+ return N;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Rep_Item_For_Entity;
+
+ --------------------
+ -- Get_Rep_Pragma --
+ --------------------
+
+ function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
+ return N;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Rep_Pragma;
+
+ ------------------------
+ -- Has_Attach_Handler --
+ ------------------------
+
+ function Has_Attach_Handler (Id : E) return B is
+ Ritem : Node_Id;
+
+ begin
+ pragma Assert (Is_Protected_Type (Id));
Ritem := First_Rep_Item (Id);
while Present (Ritem) loop
then
return True;
else
- Ritem := Next_Rep_Item (Ritem);
+ Next_Rep_Item (Ritem);
end if;
end loop;
function Has_Foreign_Convention (Id : E) return B is
begin
- return Convention (Id) in Foreign_Convention;
+ -- While regular Intrinsics such as the Standard operators fit in the
+ -- "Ada" convention, those with an Interface_Name materialize GCC
+ -- builtin imports for which Ada special treatments shouldn't apply.
+
+ return Convention (Id) in Foreign_Convention
+ or else (Convention (Id) = Convention_Intrinsic
+ and then Present (Interface_Name (Id)));
end Has_Foreign_Convention;
---------------------------
then
return True;
else
- Ritem := Next_Rep_Item (Ritem);
+ Next_Rep_Item (Ritem);
end if;
end loop;
end if;
end Implementation_Base_Type;
+ -------------------------
+ -- Invariant_Procedure --
+ -------------------------
+
+ function Invariant_Procedure (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+ if No (Subprograms_For_Type (Id)) then
+ return Empty;
+
+ else
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Has_Invariants (S) then
+ return S;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Invariant_Procedure;
+
+ ------------------
+ -- Is_Base_Type --
+ ------------------
+
+ function Is_Base_Type (Id : E) return Boolean is
+ begin
+ return Id = Base_Type (Id);
+ end Is_Base_Type;
+
---------------------
-- Is_Boolean_Type --
---------------------
function Is_Discriminal (Id : E) return B is
begin
- return
- (Ekind (Id) = E_Constant
- or else Ekind (Id) = E_In_Parameter)
- and then Present (Discriminal_Link (Id));
+ return (Ekind_In (Id, E_Constant, E_In_Parameter)
+ and then Present (Discriminal_Link (Id)));
end Is_Discriminal;
----------------------
or else
Ekind (Id) = E_Task_Type
or else
+ (Ekind (Id) = E_Limited_Private_Type
+ and then Present (Full_View (Id))
+ and then Ekind (Full_View (Id)) = E_Task_Type)
+ or else
Ekind (Id) = E_Entry
or else
Ekind (Id) = E_Entry_Family
Ekind (Id) = E_Generic_Package;
end Is_Package_Or_Generic_Package;
+ ------------------------
+ -- Predicate_Function --
+ ------------------------
+
+ function Predicate_Function (Id : E) return E is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ if No (Subprograms_For_Type (Id)) then
+ return Empty;
+
+ else
+ S := Subprograms_For_Type (Id);
+ while Present (S) loop
+ if Has_Predicates (S) then
+ return S;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ return Empty;
+ end if;
+ end Predicate_Function;
+
---------------
-- Is_Prival --
---------------
function Is_Prival (Id : E) return B is
begin
- return
- (Ekind (Id) = E_Constant
- or else Ekind (Id) = E_Variable)
- and then Present (Prival_Link (Id));
+ return (Ekind_In (Id, E_Constant, E_Variable)
+ and then Present (Prival_Link (Id)));
end Is_Prival;
----------------------------
and then Is_Protected_Type (Scope (Id));
end Is_Protected_Component;
+ ----------------------------
+ -- Is_Protected_Interface --
+ ----------------------------
+
+ function Is_Protected_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Protected_Interface (Etype (Typ));
+ else
+ return Protected_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Protected_Interface;
+
------------------------------
-- Is_Protected_Record_Type --
------------------------------
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 Id /= Any_Composite
+ and then Number_Dimensions (Id) = 1
+ and then Is_Character_Type (Component_Type (Id)));
end Is_String_Type;
+ -------------------------------
+ -- Is_Synchronized_Interface --
+ -------------------------------
+
+ function Is_Synchronized_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Synchronized_Interface (Etype (Typ));
+
+ else
+ return Protected_Present (Type_Definition (Parent (Typ)))
+ or else Synchronized_Present (Type_Definition (Parent (Typ)))
+ or else Task_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Synchronized_Interface;
+
+ -----------------------
+ -- Is_Task_Interface --
+ -----------------------
+
+ function Is_Task_Interface (Id : E) return B is
+ Typ : constant Entity_Id := Base_Type (Id);
+ begin
+ if not Is_Interface (Typ) then
+ return False;
+ elsif Is_Class_Wide_Type (Typ) then
+ return Is_Task_Interface (Etype (Typ));
+ else
+ return Task_Present (Type_Definition (Parent (Typ)));
+ end if;
+ end Is_Task_Interface;
+
-------------------------
-- Is_Task_Record_Type --
-------------------------
function Is_Wrapper_Package (Id : E) return B is
begin
return (Ekind (Id) = E_Package
- and then Present (Related_Instance (Id)));
+ and then Present (Related_Instance (Id)));
end Is_Wrapper_Package;
+ -----------------
+ -- Last_Formal --
+ -----------------
+
+ function Last_Formal (Id : E) return E is
+ Formal : E;
+
+ begin
+ pragma Assert
+ (Is_Overloadable (Id)
+ or else Ekind_In (Id, E_Entry_Family,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
+
+ if Ekind (Id) = E_Enumeration_Literal then
+ return Empty;
+
+ else
+ Formal := First_Formal (Id);
+
+ if Present (Formal) then
+ while Present (Next_Formal (Formal)) loop
+ Formal := Next_Formal (Formal);
+ end loop;
+ end if;
+
+ return Formal;
+ end if;
+ end Last_Formal;
+
+ function Model_Emin_Value (Id : E) return Uint is
+ begin
+ return Machine_Emin_Value (Id);
+ end Model_Emin_Value;
+
+ -------------------------
+ -- Model_Epsilon_Value --
+ -------------------------
+
+ function Model_Epsilon_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (1 - Model_Mantissa_Value (Id));
+ end Model_Epsilon_Value;
+
+ --------------------------
+ -- Model_Mantissa_Value --
+ --------------------------
+
+ function Model_Mantissa_Value (Id : E) return Uint is
+ begin
+ return Machine_Mantissa_Value (Id);
+ end Model_Mantissa_Value;
+
+ -----------------------
+ -- Model_Small_Value --
+ -----------------------
+
+ function Model_Small_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (Model_Emin_Value (Id) - 1);
+ end Model_Small_Value;
+
+ ------------------------
+ -- Machine_Emax_Value --
+ ------------------------
+
+ function Machine_Emax_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_128;
+ when 7 .. 15 => return 2**10;
+ when 16 .. 18 => return 2**14;
+ when others => return No_Uint;
+ end case;
+
+ when VAX_Native =>
+ case Digs is
+ when 1 .. 9 => return 2**7 - 1;
+ when 10 .. 15 => return 2**10 - 1;
+ when others => return No_Uint;
+ end case;
+
+ when AAMP =>
+ return Uint_2 ** Uint_7 - Uint_1;
+ end case;
+ end Machine_Emax_Value;
+
+ ------------------------
+ -- Machine_Emin_Value --
+ ------------------------
+
+ function Machine_Emin_Value (Id : E) return Uint is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
+ when VAX_Native => return -Machine_Emax_Value (Id);
+ when AAMP => return -Machine_Emax_Value (Id);
+ end case;
+ end Machine_Emin_Value;
+
+ ----------------------------
+ -- Machine_Mantissa_Value --
+ ----------------------------
+
+ function Machine_Mantissa_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 15 => return UI_From_Int (53);
+ when 16 .. 18 => return Uint_64;
+ when others => return No_Uint;
+ end case;
+
+ when VAX_Native =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 9 => return UI_From_Int (56);
+ when 10 .. 15 => return UI_From_Int (53);
+ when others => return No_Uint;
+ end case;
+
+ when AAMP =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 9 => return UI_From_Int (40);
+ when others => return No_Uint;
+ end case;
+ end case;
+ end Machine_Mantissa_Value;
+
+ -------------------------
+ -- Machine_Radix_Value --
+ -------------------------
+
+ function Machine_Radix_Value (Id : E) return U is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary | VAX_Native | AAMP =>
+ return Uint_2;
+ end case;
+ end Machine_Radix_Value;
+
--------------------
-- Next_Component --
--------------------
begin
Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop
- exit when Ekind (Comp_Id) = E_Component
- or else
- Ekind (Comp_Id) = E_Discriminant;
+ exit when Ekind_In (Comp_Id, E_Component, E_Discriminant);
Comp_Id := Next_Entity (Comp_Id);
end loop;
D := Next_Entity (D);
if No (D)
or else (Ekind (D) /= E_Discriminant
- and then not Is_Itype (D))
+ and then not Is_Itype (D))
then
return Empty;
end if;
-- of analyzing default expressions.
P := Id;
-
loop
P := Next_Entity (P);
return Ekind (Id);
end Parameter_Mode;
+ --------------------------
+ -- Primitive_Operations --
+ --------------------------
+
+ function Primitive_Operations (Id : E) return L is
+ begin
+ if Is_Concurrent_Type (Id) then
+ if Present (Corresponding_Record_Type (Id)) then
+ return Direct_Primitive_Operations
+ (Corresponding_Record_Type (Id));
+ else
+ return No_Elist;
+ end if;
+ else
+ return Direct_Primitive_Operations (Id);
+ end if;
+ end Primitive_Operations;
+
---------------------
-- Record_Rep_Item --
---------------------
end if;
end Root_Type;
+ ---------------------
+ -- Safe_Emax_Value --
+ ---------------------
+
+ function Safe_Emax_Value (Id : E) return Uint is
+ begin
+ return Machine_Emax_Value (Id);
+ end Safe_Emax_Value;
+
+ ----------------------
+ -- Safe_First_Value --
+ ----------------------
+
+ function Safe_First_Value (Id : E) return Ureal is
+ begin
+ return -Safe_Last_Value (Id);
+ end Safe_First_Value;
+
+ ---------------------
+ -- Safe_Last_Value --
+ ---------------------
+
+ function Safe_Last_Value (Id : E) return Ureal is
+ Radix : constant Uint := Machine_Radix_Value (Id);
+ Mantissa : constant Uint := Machine_Mantissa_Value (Id);
+ Emax : constant Uint := Safe_Emax_Value (Id);
+ Significand : constant Uint := Radix ** Mantissa - 1;
+ Exponent : constant Uint := Emax - Mantissa;
+
+ begin
+ if Radix = 2 then
+ return
+ UR_From_Components
+ (Num => Significand * 2 ** (Exponent mod 4),
+ Den => -Exponent / 4,
+ Rbase => 16);
+
+ else
+ return
+ UR_From_Components
+ (Num => Significand,
+ Den => -Exponent,
+ Rbase => 16);
+ end if;
+ end Safe_Last_Value;
+
-----------------
-- Scope_Depth --
-----------------
procedure Set_Component_Alignment (Id : E; V : C) is
begin
pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Id = Base_Type (Id));
+ and then Is_Base_Type (Id));
case V is
when Calign_Default =>
end case;
end Set_Component_Alignment;
+ -----------------------------
+ -- Set_Invariant_Procedure --
+ -----------------------------
+
+ procedure Set_Invariant_Procedure (Id : E; V : E) is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+ S := Subprograms_For_Type (Id);
+ Set_Subprograms_For_Type (Id, V);
+
+ while Present (S) loop
+ if Has_Invariants (S) then
+ raise Program_Error;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ Set_Subprograms_For_Type (Id, V);
+ end Set_Invariant_Procedure;
+
+ ----------------------------
+ -- Set_Predicate_Function --
+ ----------------------------
+
+ procedure Set_Predicate_Function (Id : E; V : E) is
+ S : Entity_Id;
+
+ begin
+ pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+ S := Subprograms_For_Type (Id);
+ Set_Subprograms_For_Type (Id, V);
+
+ while Present (S) loop
+ if Has_Predicates (S) then
+ raise Program_Error;
+ else
+ S := Subprograms_For_Type (S);
+ end if;
+ end loop;
+
+ Set_Subprograms_For_Type (Id, V);
+ end Set_Predicate_Function;
+
-----------------
-- Size_Clause --
-----------------
end if;
end Underlying_Type;
+ ---------------
+ -- Vax_Float --
+ ---------------
+
+ function Vax_Float (Id : E) return B is
+ begin
+ return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native;
+ end Vax_Float;
+
------------------------
-- Write_Entity_Flags --
------------------------
begin
if (Is_Array_Type (Id) or else Is_Record_Type (Id))
- and then Id = Base_Type (Id)
+ and then Is_Base_Type (Id)
then
Write_Str (Prefix);
Write_Str ("Component_Alignment = ");
W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
+ W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Discriminants", Flag5 (Id));
W ("Has_Enumeration_Rep_Clause", Flag66 (Id));
W ("Has_Fully_Qualified_Name", Flag173 (Id));
W ("Has_Gigi_Rep_Item", Flag82 (Id));
W ("Has_Homonym", Flag56 (Id));
+ W ("Has_Inheritable_Invariants", Flag248 (Id));
W ("Has_Initial_Value", Flag219 (Id));
+ W ("Has_Invariants", Flag232 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
W ("Has_Missing_Return", Flag142 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Has_Pragma_Inline_Always", Flag230 (Id));
+ W ("Has_Pragma_Ordered", Flag198 (Id));
W ("Has_Pragma_Pack", Flag121 (Id));
W ("Has_Pragma_Preelab_Init", Flag221 (Id));
W ("Has_Pragma_Pure", Flag203 (Id));
W ("Has_Pragma_Unmodified", Flag233 (Id));
W ("Has_Pragma_Unreferenced", Flag180 (Id));
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
+ W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_Up_Level_Access", Flag215 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
W ("Has_Xref_Entry", Flag182 (Id));
- W ("Implemented_By_Entry", Flag232 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_Local_Anonymous_Access", Flag194 (Id));
W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id));
+ W ("Is_Ada_2012_Only", Flag199 (Id));
W ("Is_Aliased", Flag15 (Id));
W ("Is_Asynchronous", Flag81 (Id));
W ("Is_Atomic", Flag85 (Id));
W ("Is_Obsolescent", Flag153 (Id));
W ("Is_Only_Out_Parameter", Flag226 (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_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
- W ("Is_Protected_Interface", Flag198 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
W ("Is_Renaming_Of_Object", Flag112 (Id));
W ("Is_Return_Object", Flag209 (Id));
W ("Is_Shared_Passive", Flag60 (Id));
- W ("Is_Synchronized_Interface", Flag199 (Id));
W ("Is_Statically_Allocated", Flag28 (Id));
W ("Is_Tag", Flag78 (Id));
W ("Is_Tagged_Type", Flag55 (Id));
- W ("Is_Task_Interface", Flag200 (Id));
W ("Is_Thunk", Flag225 (Id));
W ("Is_Trivial_Subprogram", Flag235 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Universal_Aliasing", Flag216 (Id));
W ("Used_As_Generic_Actual", Flag222 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
- W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
W ("Warnings_Off_Used", Flag236 (Id));
W ("Warnings_Off_Used_Unmodified", Flag237 (Id));
(" Component Type ", Component_Type (Id));
Write_Eol;
Write_Str (Prefix);
- Write_Str (" Indices ");
+ Write_Str (" Indexes ");
Index := First_Index (Id);
while Present (Index) loop
when Type_Kind =>
Write_Str ("Associated_Node_For_Itype");
+ when E_Loop =>
+ Write_Str ("First_Exit_Statement");
+
when E_Package =>
Write_Str ("Dependent_Instances");
procedure Write_Field10_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Type_Kind =>
- Write_Str ("Referenced_Object");
+ when Class_Wide_Kind |
+ Incomplete_Kind |
+ E_Record_Type |
+ E_Record_Subtype |
+ Private_Kind |
+ Concurrent_Kind =>
+ Write_Str ("Direct_Primitive_Operations");
+
+ when Float_Kind =>
+ Write_Str ("Float_Rep");
when E_In_Parameter |
E_Constant =>
Task_Kind =>
Write_Str ("Storage_Size_Variable");
- when Class_Wide_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Private_Kind =>
- Write_Str ("Primitive_Operations");
-
when E_Component =>
Write_Str ("DT_Entry_Count");
when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
+ when E_Subprogram_Body =>
+ Write_Str ("Corresponding_Protected_Entry");
+
when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant");
E_Generic_Package =>
Write_Str ("Renamed_Entity");
- when Incomplete_Or_Private_Kind =>
+ when Incomplete_Or_Private_Kind |
+ E_Record_Subtype =>
Write_Str ("Private_Dependents");
when Concurrent_Kind =>
E_Return_Statement |
E_Subprogram_Body |
E_Subprogram_Type =>
-
Write_Str ("Last_Entity");
when Scalar_Kind =>
when Subprogram_Kind =>
Write_Str ("Spec_PPC_List");
- when E_Record_Type =>
- Write_Str ("Underlying record view");
-
- when E_Variable | E_Constant =>
- Write_Str ("Related expression");
+ when E_Variable | E_Constant | Type_Kind =>
+ Write_Str ("Related_Expression");
when others =>
- Write_Str ("???");
+ Write_Str ("Field24???");
end case;
end Write_Field24_Name;
when E_Variable =>
Write_Str ("Debug_Renaming_Link");
+ when E_Entry |
+ E_Entry_Family =>
+ Write_Str ("PPC_Wrapper");
+
+ when E_Enumeration_Subtype |
+ E_Modular_Integer_Subtype |
+ E_Signed_Integer_Subtype =>
+ Write_Str ("Static_Predicate");
+
when others =>
Write_Str ("Field25??");
end case;
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Component |
- E_Constant =>
- Write_Str ("Related_Type");
-
when E_Generic_Package |
E_Package =>
Write_Str ("Package_Instantiation");
when E_Procedure |
E_Function =>
-
if Is_Dispatching_Operation (Id) then
Write_Str ("Overridden_Operation");
else
procedure Write_Field27_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Component |
+ E_Constant |
+ E_Variable =>
+ Write_Str ("Related_Type");
+
when E_Procedure =>
Write_Str ("Wrapped_Entity");
when E_Procedure | E_Function | E_Entry =>
Write_Str ("Extra_Formals");
+ when E_Record_Type =>
+ Write_Str ("Underlying_Record_View");
+
when others =>
Write_Str ("Field28??");
end case;
end Write_Field28_Name;
+ procedure Write_Field29_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when Type_Kind =>
+ Write_Str ("Subprograms_For_Type");
+
+ when others =>
+ Write_Str ("Field29??");
+ end case;
+ end Write_Field29_Name;
+
-------------------------
-- Iterator Procedures --
-------------------------
begin
N := Next_Entity (N);
while Present (N) loop
- exit when Ekind (N) = E_Component
- or else
- Ekind (N) = E_Discriminant;
+ exit when Ekind_In (N, E_Component, E_Discriminant);
N := Next_Entity (N);
end loop;
end Proc_Next_Component_Or_Discriminant;
OSDN Git Service
