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
-- 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
-- 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
-- Extra_Formals Node28
-- Underlying_Record_View Node28
- -- (unused) Node29
+ -- 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-Flag2 are absent from this list, for historical reasons
+ -- 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
-- 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
+ -- 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) Flag3
- -- (unused) Flag200
- -- (unused) Flag232
-
- -- (unused) Flag248
+ -- (unused) Flag39
+ -- (unused) Flag151
-- (unused) Flag249
- -- (unused) Flag250
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
-- 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;
return Flag104 (Id);
end Address_Taken;
- 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;
-
function Alias (Id : E) return E is
begin
pragma Assert
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 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));
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));
return Node4 (Id);
end Homonym;
- function Interfaces (Id : E) return L is
- begin
- pragma Assert (Is_Record_Type (Id));
- 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 Interfaces (Id : E) return L is
+ begin
+ pragma Assert (Is_Record_Type (Id));
+ return Elist25 (Id);
+ end Interfaces;
+
function In_Package_Body (Id : E) return B is
begin
return Flag48 (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 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
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 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);
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);
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_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_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;
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_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_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);
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_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));
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_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_Interfaces (Id : E; V : L) is
- begin
- pragma Assert (Is_Record_Type (Id));
- Set_Elist25 (Id, V);
- end Set_Interfaces;
-
procedure Set_Interface_Alias (Id : E; V : E) is
begin
pragma Assert
Set_Node25 (Id, V);
end Set_Interface_Alias;
+ procedure Set_Interfaces (Id : E; V : L) is
+ begin
+ pragma Assert (Is_Record_Type (Id));
+ Set_Elist25 (Id, V);
+ end Set_Interfaces;
+
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
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;
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);
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_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_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;
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
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_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_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_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);
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 --
----------------------
return Empty;
end Get_Record_Representation_Clause;
+ -----------------------------
+ -- Get_Rep_Item_For_Entity --
+ -----------------------------
+
+ function Get_Rep_Item_For_Entity
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id
+ is
+ N : Node_Id;
+ Arg : Node_Id;
+
+ begin
+ 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 --
--------------------
then
return True;
else
- Ritem := Next_Rep_Item (Ritem);
+ Next_Rep_Item (Ritem);
end if;
end loop;
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 --
---------------------
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 --
---------------
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 --
--------------------
-- 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_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 ("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 ("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
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 |
- Incomplete_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Private_Kind =>
- Write_Str ("Primitive_Operations");
-
when E_Component =>
Write_Str ("DT_Entry_Count");
E_Return_Statement |
E_Subprogram_Body |
E_Subprogram_Type =>
-
Write_Str ("Last_Entity");
when Scalar_Kind =>
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;
when E_Procedure |
E_Function =>
-
if Is_Dispatching_Operation (Id) then
Write_Str ("Overridden_Operation");
else
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 --
-------------------------
OSDN Git Service
