-- Extra_Formal Node15
-- Lit_Indexes Node15
-- Related_Instance Node15
- -- Return_Flag Node15
+ -- Return_Flag_Or_Transient_Decl Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- String_Literal_Low_Bound Node15
-- Body_Entity Node19
-- Corresponding_Discriminant Node19
+ -- Extra_Accessibility_Of_Result Node19
-- Parent_Subtype Node19
-- Related_Array_Object Node19
-- Size_Check_Code Node19
-- Scope_Depth_Value Uint22
-- Shared_Var_Procs_Instance Node22
- -- Associated_Collection Node23
-- CR_Discriminant Node23
-- Entry_Cancel_Parameter Node23
-- Enum_Pos_To_Rep Node23
-- Extra_Constrained Node23
+ -- Finalization_Master Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Limited_View Node23
-- Finalizer Node24
-- Related_Expression Node24
- -- Spec_PPC_List Node24
+ -- Contract Node24
-- Interface_Alias Node25
-- Interfaces Elist25
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
- -- Is_In_ALFA Flag151
+ -- Has_Private_Ancestor Flag151
-- Entry_Accepted Flag152
-- Is_Obsolescent Flag153
-- Has_Per_Object_Constraint Flag154
-- Is_Safe_To_Reevaluate Flag249
-- Has_Predicates Flag250
- -- Body_Is_In_ALFA Flag251
+ -- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
- -- Is_Postcondition_Proc Flag253
- -- (unused) Flag254
+ -- Has_Anonymous_Master Flag253
+ -- Is_Implementation_Defined Flag254
-----------------------
-- Local subprograms --
return Uint14 (Id);
end Alignment;
- function Associated_Collection (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node23 (Id);
- end Associated_Collection;
-
function Associated_Formal_Package (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
return Node19 (Id);
end Body_Entity;
- function Body_Is_In_ALFA (Id : E) return B is
- begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
- return Flag251 (Id);
- end Body_Is_In_ALFA;
-
function Body_Needed_For_SAL (Id : E) return B is
begin
pragma Assert
return Node18 (Id);
end Entry_Index_Constant;
+ function Contract (Id : E) return N is
+ begin
+ 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 Contract;
+
function Entry_Parameters_Type (Id : E) return E is
begin
return Node15 (Id);
function Extra_Accessibility (Id : E) return E is
begin
- pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
+ pragma Assert
+ (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
return Node13 (Id);
end Extra_Accessibility;
+ function Extra_Accessibility_Of_Result (Id : E) return E is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+ return Node19 (Id);
+ end Extra_Accessibility_Of_Result;
+
function Extra_Constrained (Id : E) return E is
begin
pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
return Flag229 (Base_Type (Id));
end Can_Use_Internal_Rep;
+ function Finalization_Master (Id : E) return E is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Node23 (Root_Type (Id));
+ end Finalization_Master;
+
function Finalize_Storage_Only (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag201 (Id);
end Has_Anon_Block_Suffix;
+ function Has_Anonymous_Master (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
+ return Flag253 (Id);
+ end Has_Anonymous_Master;
+
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Implementation_Base_Type (Id));
return Flag56 (Id);
end Has_Homonym;
+ function Has_Implicit_Dereference (Id : E) return B is
+ begin
+ return Flag251 (Id);
+ end Has_Implicit_Dereference;
+
function Has_Inheritable_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
function Has_Invariants (Id : E) return B is
begin
- pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+ pragma Assert (Is_Type (Id)
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Generic_Procedure);
return Flag232 (Id);
end Has_Invariants;
return Flag120 (Base_Type (Id));
end Has_Primitive_Operations;
+ function Has_Private_Ancestor (Id : E) return B is
+ begin
+ return Flag151 (Id);
+ end Has_Private_Ancestor;
+
function Has_Private_Declaration (Id : E) return B is
begin
return Flag155 (Id);
function Has_Xref_Entry (Id : E) return B is
begin
- return Flag182 (Implementation_Base_Type (Id));
+ return Flag182 (Id);
end Has_Xref_Entry;
function Hiding_Loop_Variable (Id : E) return E is
return Flag7 (Id);
end Is_Immediately_Visible;
+ function Is_Implementation_Defined (Id : E) return B is
+ begin
+ return Flag254 (Id);
+ end Is_Implementation_Defined;
+
function Is_Imported (Id : E) return B is
begin
return Flag24 (Id);
end Is_Imported;
- function Is_In_ALFA (Id : E) return B is
- begin
- return Flag151 (Id);
- end Is_In_ALFA;
-
function Is_Inlined (Id : E) return B is
begin
return Flag11 (Id);
return Flag138 (Id);
end Is_Packed_Array_Type;
- function Is_Postcondition_Proc (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- return Flag253 (Id);
- end Is_Postcondition_Proc;
-
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag213 (Id);
end Requires_Overriding;
- function Return_Flag (Id : E) return N is
+ function Return_Flag_Or_Transient_Decl (Id : E) return N is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
return Node15 (Id);
- end Return_Flag;
+ end Return_Flag_Or_Transient_Decl;
function Return_Present (Id : E) return B is
begin
return Node19 (Id);
end Spec_Entity;
- function Spec_PPC_List (Id : E) return N is
- begin
- 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));
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
- procedure Set_Associated_Collection (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Node23 (Id, V);
- end Set_Associated_Collection;
-
procedure Set_Associated_Formal_Package (Id : E; V : E) is
begin
Set_Node12 (Id, V);
Set_Node19 (Id, V);
end Set_Body_Entity;
- procedure Set_Body_Is_In_ALFA (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
- Set_Flag251 (Id, V);
- end Set_Body_Is_In_ALFA;
-
procedure Set_Body_Needed_For_SAL (Id : E; V : B := True) is
begin
pragma Assert
Set_Node18 (Id, V);
end Set_Entry_Index_Constant;
+ procedure Set_Contract (Id : E; V : N) is
+ begin
+ 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_Contract;
+
procedure Set_Entry_Parameters_Type (Id : E; V : E) is
begin
Set_Node15 (Id, V);
procedure Set_Extra_Accessibility (Id : E; V : E) is
begin
- pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
+ pragma Assert
+ (Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
Set_Node13 (Id, V);
end Set_Extra_Accessibility;
+ procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+ Set_Node19 (Id, V);
+ end Set_Extra_Accessibility_Of_Result;
+
procedure Set_Extra_Constrained (Id : E; V : E) is
begin
pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
+ procedure Set_Finalization_Master (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
+ Set_Node23 (Id, V);
+ end Set_Finalization_Master;
+
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
Set_Flag201 (Id, V);
end Set_Has_Anon_Block_Suffix;
+ procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
+ Set_Flag253 (Id, V);
+ end Set_Has_Anonymous_Master;
+
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag56 (Id, V);
end Set_Has_Homonym;
+ procedure Set_Has_Implicit_Dereference (Id : E; V : B := True) is
+ begin
+ Set_Flag251 (Id, V);
+ end Set_Has_Implicit_Dereference;
+
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag120 (Id, V);
end Set_Has_Primitive_Operations;
+ procedure Set_Has_Private_Ancestor (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag151 (Id, V);
+ end Set_Has_Private_Ancestor;
+
procedure Set_Has_Private_Declaration (Id : E; V : B := True) is
begin
Set_Flag155 (Id, V);
Set_Flag7 (Id, V);
end Set_Is_Immediately_Visible;
+ procedure Set_Is_Implementation_Defined (Id : E; V : B := True) is
+ begin
+ Set_Flag254 (Id, V);
+ end Set_Is_Implementation_Defined;
+
procedure Set_Is_Imported (Id : E; V : B := True) is
begin
Set_Flag24 (Id, V);
end Set_Is_Imported;
- procedure Set_Is_In_ALFA (Id : E; V : B := True) is
- begin
- Set_Flag151 (Id, V);
- end Set_Is_In_ALFA;
-
procedure Set_Is_Inlined (Id : E; V : B := True) is
begin
Set_Flag11 (Id, V);
Set_Flag138 (Id, V);
end Set_Is_Packed_Array_Type;
- procedure Set_Is_Postcondition_Proc (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Procedure);
- Set_Flag253 (Id, V);
- end Set_Is_Postcondition_Proc;
-
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag213 (Id, V);
end Set_Requires_Overriding;
- procedure Set_Return_Flag (Id : E; V : E) is
+ procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
Set_Node15 (Id, V);
- end Set_Return_Flag;
+ end Set_Return_Flag_Or_Transient_Decl;
procedure Set_Return_Present (Id : E; V : B := True) is
begin
Set_Node19 (Id, V);
end Set_Spec_Entity;
- procedure Set_Spec_PPC_List (Id : E; V : N) is
- begin
- 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
Set_Uint14 (Id, No_Uint); -- Normalized_Position
end Init_Component_Location;
+ ----------------------------
+ -- Init_Object_Size_Align --
+ ----------------------------
+
+ procedure Init_Object_Size_Align (Id : E) is
+ begin
+ Set_Uint12 (Id, Uint_0); -- Esize
+ Set_Uint14 (Id, Uint_0); -- Alignment
+ end Init_Object_Size_Align;
+
---------------
-- Init_Size --
---------------
procedure Init_Size (Id : E; V : Int) is
begin
+ pragma Assert (not Is_Object (Id));
Set_Uint12 (Id, UI_From_Int (V)); -- Esize
Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size
end Init_Size;
procedure Init_Size_Align (Id : E) is
begin
+ pragma Assert (not Is_Object (Id));
Set_Uint12 (Id, Uint_0); -- Esize
Set_Uint13 (Id, Uint_0); -- RM_Size
Set_Uint14 (Id, Uint_0); -- Alignment
return False;
end Has_Interrupt_Handler;
- --------------------------
- -- Has_Private_Ancestor --
- --------------------------
-
- function Has_Private_Ancestor (Id : E) return B is
- R : constant Entity_Id := Root_Type (Id);
- T1 : Entity_Id := Id;
- begin
- loop
- if Is_Private_Type (T1) then
- return True;
- elsif T1 = R then
- return False;
- else
- T1 := Etype (T1);
- end if;
- end loop;
- end Has_Private_Ancestor;
-
--------------------
-- Has_Rep_Pragma --
--------------------
if Is_Concurrent_Type (Id) then
if Present (Corresponding_Record_Type (Id)) then
return Direct_Primitive_Operations
- (Corresponding_Record_Type (Id));
+ (Corresponding_Record_Type (Id));
+
+ -- If expansion is disabled the corresponding record type is absent,
+ -- but if the type has ancestors it may have primitive operations.
+
+ elsif Is_Tagged_Type (Id) then
+ return Direct_Primitive_Operations (Id);
+
else
return No_Elist;
end if;
if Ekind (T) = E_Class_Wide_Type then
return Etype (T);
- elsif Ekind (T) = E_Class_Wide_Subtype then
- return Etype (Base_Type (T));
-
- -- ??? T comes from Base_Type, how can it be a subtype?
- -- Also Base_Type is supposed to be idempotent, so either way
- -- this is equivalent to "return Etype (T)" and should be merged
- -- with the E_Class_Wide_Type case.
-
- -- All other cases
+ -- Other cases
else
loop
end if;
W ("Address_Taken", Flag104 (Id));
- W ("Body_Is_In_ALFA", Flag251 (Id));
W ("Body_Needed_For_SAL", Flag40 (Id));
W ("C_Pass_By_Copy", Flag125 (Id));
W ("Can_Never_Be_Null", Flag38 (Id));
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
W ("Has_Anon_Block_Suffix", Flag201 (Id));
+ W ("Has_Anonymous_Master", Flag253 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Biased_Representation", Flag139 (Id));
W ("Has_Completion", Flag26 (Id));
W ("Has_Fully_Qualified_Name", Flag173 (Id));
W ("Has_Gigi_Rep_Item", Flag82 (Id));
W ("Has_Homonym", Flag56 (Id));
+ W ("Has_Implicit_Dereference", Flag251 (Id));
W ("Has_Inheritable_Invariants", Flag248 (Id));
W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Invariants", Flag232 (Id));
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
+ W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
W ("Is_Hidden", Flag57 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
+ W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
- W ("Is_In_ALFA", Flag151 (Id));
W ("Is_Inlined", Flag11 (Id));
W ("Is_Instantiated", Flag126 (Id));
W ("Is_Interface", Flag186 (Id));
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
- W ("Is_Postcondition_Proc", Flag253 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
when E_Constant |
E_Variable =>
- Write_Str ("Return_Flag");
+ Write_Str ("Return_Flag_Or_Transient_Decl");
when Decimal_Fixed_Point_Kind =>
Write_Str ("Scale_Value");
when Private_Kind =>
Write_Str ("Underlying_Full_View");
+ when E_Function | E_Operator | E_Subprogram_Type =>
+ Write_Str ("Extra_Accessibility_Of_Result");
+
when others =>
Write_Str ("Field19??");
end case;
procedure Write_Field23_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Access_Kind =>
- Write_Str ("Associated_Collection");
-
when E_Discriminant =>
Write_Str ("CR_Discriminant");
E_Variable =>
Write_Str ("Extra_Constrained");
+ when Access_Kind =>
+ Write_Str ("Finalization_Master");
+
when E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure =>
Type_Kind =>
Write_Str ("Related_Expression");
- when Subprogram_Kind =>
- Write_Str ("Spec_PPC_List");
+ when E_Entry |
+ E_Entry_Family |
+ Subprogram_Kind |
+ Generic_Subprogram_Kind =>
+ Write_Str ("Contract");
when others =>
Write_Str ("Field24???");
procedure Write_Field28_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Procedure |
+ when E_Entry |
+ E_Entry_Family |
E_Function |
- E_Entry =>
+ E_Procedure |
+ E_Subprogram_Body |
+ E_Subprogram_Type =>
Write_Str ("Extra_Formals");
when E_Record_Type =>
OSDN Git Service
