-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- PPC_Wrapper Node25
+ -- Static_Predicate List25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrappers Elist26
-- 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
- -- (unused) Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
-- Has_Inheritable_Invariants Flag248
- -- OK_To_Reference Flag249
-- Has_Predicates Flag250
+ -- (unused) Flag39
+ -- (unused) Flag151
+ -- (unused) Flag249
-- (unused) Flag251
-- (unused) Flag252
-- (unused) Flag253
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 Flag205 (Id);
end Low_Bound_Tested;
- 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;
-
- 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;
-
- 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;
-
function Machine_Radix_10 (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
return Flag84 (Id);
end Machine_Radix_10;
- function 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;
-
function Master_Id (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
return UI_To_Int (Uint8 (Id));
end Mechanism;
- function Model_Emin_Value (Id : E) return Uint is
- begin
- return Machine_Emin_Value (Id);
- end Model_Emin_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;
-
- function Model_Mantissa_Value (Id : E) return Uint is
- begin
- return Machine_Mantissa_Value (Id);
- end Model_Mantissa_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;
-
function Modulus (Id : E) return Uint is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
return Uint10 (Id);
end Normalized_Position_Max;
- function OK_To_Reference (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag249 (Id);
- end OK_To_Reference;
-
function OK_To_Rename (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Variable);
return Uint13 (Id);
end RM_Size;
- function Safe_Emax_Value (Id : E) return Uint is
- begin
- return Machine_Emax_Value (Id);
- end Safe_Emax_Value;
-
- function Safe_First_Value (Id : E) return Ureal is
- begin
- return -Safe_Last_Value (Id);
- end Safe_First_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;
-
function Scalar_Range (Id : E) return N is
begin
return Node20 (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 Flag95 (Id);
end Uses_Sec_Stack;
- 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;
-
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;
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;
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;
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;
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
- procedure Set_OK_To_Reference (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag249 (Id, V);
- end Set_OK_To_Reference;
-
procedure Set_OK_To_Rename (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Variable);
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_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;
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));
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;
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 --
---------------------
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 --
--------------------
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 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 ("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 ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
- W ("OK_To_Reference", Flag249 (Id));
W ("OK_To_Rename", Flag247 (Id));
W ("OK_To_Reorder_Components", Flag239 (Id));
W ("Optimize_Alignment_Space", Flag241 (Id));
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;
OSDN Git Service
