This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Quadratic compile time with tagged types
- From: Pierre-Marie de Rodat <derodat at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Justin Squirek <squirek at adacore dot com>
- Date: Thu, 24 May 2018 09:08:39 -0400
- Subject: [Ada] Quadratic compile time with tagged types
This patch is an incremental commit which focuses on the optimization of entity
chain navigation by adding an additional field (Prev_Entity) to all nodes in
order to greaty speed up compilation of sources making heavy use of tagged
derivations by effectly making the entity chain from a singly-linked list into
a doubly-linked one.
This is only a performance improvement: no compilation result change
expected.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-24 Justin Squirek <squirek@adacore.com>
gcc/ada/
* einfo.ads, einfo.adb (Append_Entity): Modified to use Link_Entities
and manage doubly-linked entity chain.
(Nested_Scenarios): Removed entity field used for optimization during
elaboration to make room for the new field Prev_Entity.
(Link_Entities): Added to replace redundant calls to Set_Next_Entity
and Set_Prev_Entity as well as centralize changes to the entity chain.
(Predicated_Parent): Modified to use Node38.
(Prev_Entity): Added to fetch new node field Prev_Entity in all entity
types.
(Remove_Entity): Moved from sem_util.
(Set_Nested_Scenarios): Deleted.
(Set_Predicated_Parent): Modified to use Node38.
(Set_Prev_Entity): Added to set Prev_Entity field.
(Set_Validated_Object): Modified to use Node38.
(Unlink_Next_Entity): Added to process Prev_Entity when an unlinking
action is required.
(Validated_Object): Modified to use Node38.
(Write_Field36_Name): Remove Nested_Scenarios, Validated_Object, and
predicated parent cases.
(Write_Field38_Name): Add predicated parent and Validated_Object cases.
* sem_ch3.adb (Process_Subtype): Add guard to protect against
inappropriate marking of Predicated_Parent to non-itype subtypes.
(Make_Class_Wide_Type): Preserve Prev_Entity field and set in new type.
(Copy_And_Swap): Add setting of Prev_Entity.
(Build_derived_Record_Type): Replace Set_Next_Entity w/ Link_Entities.
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Replace Set_Next_Entity
w/ Link_Entities.
(New_Overloaded_Entity): Remove block created to search for previous
entities in the entity chain with relevant calls to Prev_Entity as well
as replace duplicated code from Remove_Entity_And_Homonym with a call
to that subprogram.
* sem_ch7.adb (Exchange_Declarations): Replace Set_Next_Entity w/
Link_Entities.
* sem_elab.adb (Find_And_Process_Nested_Scenarios): Remove global and
initial subprogram declarations related to Nested_Scenarios.
(Process_Nested_Scenarios): Deleted.
(Save_Scenario): Deleted.
(Traverse_Body): Remove optimization for Nested_Scenarios so as to free
node space in the entity tree.
* sem_util.adb, sem_util.ads (Remove_Entity): Moved to einfo.
(Remove_Entity_And_Homonym): Added to separate functionality of
Remove_Entity from the homonym chain directly.
* exp_attr.adb (Expand_N_Attribute_Reference): Replace Set_Next_Entity
w/ Link_Entities and Unlink_Next_Entity.
* exp_ch3.adb (Expand_N_Object_Declaration): Replace Set_Next_Entity w/
Link_Entities.
* exp_ch6.adb (Replace_Renaming_Declaration_Id): Replace
Set_Next_Entity w/ Link_Entities.
* exp_disp.adb (Expand_Dispatching_Call): Replace Set_Next_Entity w/
Link_Entities and Unlink_Next_Entity.
* exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Replace
call to Remove_Entity with its new incarnation.
* exp_util.adb (New_Class_Wide_Subtype): Add setting of Prev_Entity.
* freeze.adb (Freeze_Record_Type): Replace Set_Next_Entity w/
Link_Entities.
--- gcc/ada/einfo.adb
+++ gcc/ada/einfo.adb
@@ -70,6 +70,7 @@ package body Einfo is
-- Homonym Node4
-- First_Rep_Item Node6
-- Freeze_Node Node7
+ -- Prev_Entity Node36
-- Associated_Entity Node37
-- The usage of other fields (and the entity kinds to which it applies)
@@ -274,10 +275,10 @@ package body Einfo is
-- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
- -- Nested_Scenarios Elist36
- -- Validated_Object Node36
- -- Predicated_Parent Node36
+ -- Prev_Entity Node36
+ -- Validated_Object Node38
+ -- Predicated_Parent Node38
-- Class_Wide_Clone Node38
-- Protected_Subprogram Node39
@@ -2878,14 +2879,6 @@ package body Einfo is
return Flag22 (Id);
end Needs_No_Actuals;
- function Nested_Scenarios (Id : E) return L is
- begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Procedure,
- E_Subprogram_Body));
- return Elist36 (Id);
- end Nested_Scenarios;
-
function Never_Set_In_Source (Id : E) return B is
begin
return Flag115 (Id);
@@ -3085,8 +3078,10 @@ package body Einfo is
function Predicated_Parent (Id : E) return E is
begin
- pragma Assert (Is_Type (Id));
- return Node36 (Id);
+ pragma Assert (Ekind_In (Id, E_Array_Subtype,
+ E_Record_Subtype,
+ E_Record_Subtype_With_Private));
+ return Node38 (Id);
end Predicated_Parent;
function Predicates_Ignored (Id : E) return B is
@@ -3095,6 +3090,11 @@ package body Einfo is
return Flag288 (Id);
end Predicates_Ignored;
+ function Prev_Entity (Id : E) return E is
+ begin
+ return Node36 (Id);
+ end Prev_Entity;
+
function Prival (Id : E) return E is
begin
pragma Assert (Is_Protected_Component (Id));
@@ -3593,7 +3593,7 @@ package body Einfo is
function Validated_Object (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Variable);
- return Node36 (Id);
+ return Node38 (Id);
end Validated_Object;
function Warnings_Off (Id : E) return B is
@@ -6111,14 +6111,6 @@ package body Einfo is
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
- procedure Set_Nested_Scenarios (Id : E; V : L) is
- begin
- pragma Assert (Ekind_In (Id, E_Function,
- E_Procedure,
- E_Subprogram_Body));
- Set_Elist36 (Id, V);
- end Set_Nested_Scenarios;
-
procedure Set_Never_Set_In_Source (Id : E; V : B := True) is
begin
Set_Flag115 (Id, V);
@@ -6320,8 +6312,10 @@ package body Einfo is
procedure Set_Predicated_Parent (Id : E; V : E) is
begin
- pragma Assert (Is_Type (Id));
- Set_Node36 (Id, V);
+ pragma Assert (Ekind_In (Id, E_Array_Subtype,
+ E_Record_Subtype,
+ E_Record_Subtype_With_Private));
+ Set_Node38 (Id, V);
end Set_Predicated_Parent;
procedure Set_Predicates_Ignored (Id : E; V : B) is
@@ -6360,6 +6354,11 @@ package body Einfo is
Set_Node22 (Id, V);
end Set_Private_View;
+ procedure Set_Prev_Entity (Id : E; V : E) is
+ begin
+ Set_Node36 (Id, V);
+ end Set_Prev_Entity;
+
procedure Set_Protected_Body_Subprogram (Id : E; V : E) is
begin
pragma Assert (Is_Subprogram (Id) or else Is_Entry (Id));
@@ -6848,7 +6847,7 @@ package body Einfo is
procedure Set_Validated_Object (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Variable);
- Set_Node36 (Id, V);
+ Set_Node38 (Id, V);
end Set_Validated_Object;
procedure Set_Warnings_Off (Id : E; V : B := True) is
@@ -7202,17 +7201,31 @@ package body Einfo is
-- Append_Entity --
-------------------
- procedure Append_Entity (Id : Entity_Id; V : Entity_Id) is
+ procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is
+ Last : constant Entity_Id := Last_Entity (Scop);
+
begin
- if Last_Entity (V) = Empty then
- Set_First_Entity (Id => V, V => Id);
+ Set_Scope (Id, Scop);
+ Set_Prev_Entity (Id, Empty); -- Empty <-- Id
+
+ -- The entity chain is empty
+
+ if No (Last) then
+ Set_First_Entity (Scop, Id);
+
+ -- Otherwise the entity chain has at least one element
+
else
- Set_Next_Entity (Last_Entity (V), Id);
+ Link_Entities (Last, Id); -- Last <-- Id, Last --> Id
end if;
- Set_Next_Entity (Id, Empty);
- Set_Scope (Id, V);
- Set_Last_Entity (Id => V, V => Id);
+ -- NOTE: The setting of the Next_Entity attribute of Id must happen
+ -- here as opposed to at the beginning of the routine because doing
+ -- so causes the binder to hang. It is not clear why ???
+
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+
+ Set_Last_Entity (Scop, Id);
end Append_Entity;
---------------
@@ -8377,6 +8390,23 @@ package body Einfo is
end if;
end Last_Formal;
+ -------------------
+ -- Link_Entities --
+ -------------------
+
+ procedure Link_Entities (First : Entity_Id; Second : Node_Id) is
+ begin
+ if Present (Second) then
+ Set_Prev_Entity (Second, First); -- First <-- Second
+ end if;
+
+ Set_Next_Entity (First, Second); -- First --> Second
+ end Link_Entities;
+
+ ----------------------
+ -- Model_Emin_Value --
+ ----------------------
+
function Model_Emin_Value (Id : E) return Uint is
begin
return Machine_Emin_Value (Id);
@@ -8842,7 +8872,11 @@ package body Einfo is
then
Typ := Full_View (Id);
- elsif Is_Itype (Id) and then Present (Predicated_Parent (Id)) then
+ elsif Ekind_In (Id, E_Array_Subtype,
+ E_Record_Subtype,
+ E_Record_Subtype_With_Private)
+ and then Present (Predicated_Parent (Id))
+ then
Typ := Predicated_Parent (Id);
else
@@ -8972,6 +9006,47 @@ package body Einfo is
Set_First_Rep_Item (E, N);
end Record_Rep_Item;
+ -------------------
+ -- Remove_Entity --
+ -------------------
+
+ procedure Remove_Entity (Id : Entity_Id) is
+ Next : constant Entity_Id := Next_Entity (Id);
+ Prev : constant Entity_Id := Prev_Entity (Id);
+ Scop : constant Entity_Id := Scope (Id);
+ First : constant Entity_Id := First_Entity (Scop);
+ Last : constant Entity_Id := Last_Entity (Scop);
+
+ begin
+ -- Eliminate any existing linkages from the entity
+
+ Set_Prev_Entity (Id, Empty); -- Empty <-- Id
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+
+ -- The eliminated entity was the only element in the entity chain
+
+ if Id = First and then Id = Last then
+ Set_First_Entity (Scop, Empty);
+ Set_Last_Entity (Scop, Empty);
+
+ -- The eliminated entity was the head of the entity chain
+
+ elsif Id = First then
+ Set_First_Entity (Scop, Next);
+
+ -- The eliminated entity was the tail of the entity chain
+
+ elsif Id = Last then
+ Set_Last_Entity (Scop, Prev);
+
+ -- Otherwise the eliminated entity comes from the middle of the entity
+ -- chain.
+
+ else
+ Link_Entities (Prev, Next); -- Prev <-- Next, Prev --> Next
+ end if;
+ end Remove_Entity;
+
---------------
-- Root_Type --
---------------
@@ -9523,6 +9598,21 @@ package body Einfo is
end Underlying_Type;
------------------------
+ -- Unlink_Next_Entity --
+ ------------------------
+
+ procedure Unlink_Next_Entity (Id : Entity_Id) is
+ Next : constant Entity_Id := Next_Entity (Id);
+
+ begin
+ if Present (Next) then
+ Set_Prev_Entity (Next, Empty); -- Empty <-- Next
+ end if;
+
+ Set_Next_Entity (Id, Empty); -- Id --> Empty
+ end Unlink_Next_Entity;
+
+ ------------------------
-- Write_Entity_Flags --
------------------------
@@ -10825,6 +10915,9 @@ package body Einfo is
procedure Write_Field24_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Package =>
+ Write_Str ("Incomplete_Actuals");
+
when Type_Kind
| E_Constant
| E_Variable
@@ -10837,9 +10930,6 @@ package body Einfo is
=>
Write_Str ("Subps_Index");
- when E_Package =>
- Write_Str ("Incomplete_Actuals");
-
when others =>
Write_Str ("Field24???");
end case;
@@ -11205,25 +11295,9 @@ package body Einfo is
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
+ pragma Unreferenced (Id);
begin
- case Ekind (Id) is
- when E_Function
- | E_Procedure
- | E_Subprogram_Body
- =>
- Write_Str ("Nested_Scenarios");
-
- when E_Variable =>
- Write_Str ("Validated_Object");
-
- when E_Array_Subtype
- | E_Record_Subtype
- =>
- Write_Str ("predicated parent");
-
- when others =>
- Write_Str ("Field36??");
- end case;
+ Write_Str ("Prev_Entity");
end Write_Field36_Name;
------------------------
@@ -11246,7 +11320,16 @@ package body Einfo is
when E_Function
| E_Procedure
=>
- Write_Str ("class-wide clone");
+ Write_Str ("Class_Wide_Clone");
+
+ when E_Array_Subtype
+ | E_Record_Subtype
+ | E_Record_Subtype_With_Private
+ =>
+ Write_Str ("Predicated_Parent");
+
+ when E_Variable =>
+ Write_Str ("Validated_Object");
when others =>
Write_Str ("Field38??");
--- gcc/ada/einfo.ads
+++ gcc/ada/einfo.ads
@@ -3549,14 +3549,6 @@ package Einfo is
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
--- Nested_Scenarios (Elist36)
--- Present in [stand alone] subprogram bodies. The list contains all
--- nested scenarios (see the terminology in Sem_Elab) which appear within
--- the declarations, statements, and exception handlers of the subprogram
--- body. The list improves the performance of the ABE Processing phase by
--- avoiding a full tree traversal when the same subprogram body is part
--- of several distinct paths in the elaboration graph.
-
-- Never_Set_In_Source (Flag115)
-- Defined in all entities, but can be set only for variables and
-- parameters. This flag is set if the object is never assigned a value
@@ -3932,7 +3924,7 @@ package Einfo is
-- is the special version created for membership tests, where if one of
-- these raise expressions is executed, the result is to return False.
--- Predicated_Parent (Node36)
+-- Predicated_Parent (Node38)
-- Defined on itypes created by subtype indications, when the parent
-- subtype has predicates. The itype shares the Predicate_Function
-- of the predicated parent, but this function may not have been built
@@ -3945,6 +3937,11 @@ package Einfo is
-- a context where Assertion_Policy is Ignore, in which case no checks
-- (static or dynamic) must be generated for objects of the type.
+-- Prev_Entity (Node36)
+-- Defined in all entities. The entities of a scope are chained, and this
+-- field is used as a backward pointer for this entity list - effectivly
+-- making the entity chain doubly-linked.
+
-- Primitive_Operations (synthesized)
-- Defined in concurrent types, tagged record types and subtypes, tagged
-- private types and tagged incomplete types. For concurrent types whose
@@ -4625,7 +4622,7 @@ package Einfo is
-- in this scope and must be released on exit unless flag
-- Sec_Stack_Needed_For_Return is set.
--- Validated_Object (Node36)
+-- Validated_Object (Node38)
-- Defined in variables. Contains the object whose value is captured by
-- the variable for validity check purposes.
@@ -5554,6 +5551,7 @@ package Einfo is
-- Etype (Node5)
-- First_Rep_Item (Node6)
-- Freeze_Node (Node7)
+ -- Prev_Entity (Node36)
-- Associated_Entity (Node37)
-- Address_Taken (Flag104)
@@ -5860,6 +5858,7 @@ package Einfo is
-- Component_Size (Uint22) (base type only)
-- Packed_Array_Impl_Type (Node23)
-- Related_Array_Object (Node25)
+ -- Predicated_Parent (Node38) (subtype only)
-- Component_Alignment (special) (base type only)
-- Has_Component_Size_Clause (Flag68) (base type only)
-- Has_Pragma_Pack (Flag121) (impl base type only)
@@ -6157,7 +6156,6 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Nested_Scenarios (Elist36)
-- Class_Wide_Clone (Node38)
-- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
@@ -6486,7 +6484,6 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Nested_Scenarios (Elist36)
-- Class_Wide_Clone (Node38)
-- Protected_Subprogram (Node39) (non-generic case only)
-- SPARK_Pragma (Node40)
@@ -6597,6 +6594,7 @@ package Einfo is
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Underlying_Record_View (Node28) (base type only)
-- Access_Disp_Table_Elab_Flag (Node30) (base type only)
+ -- Predicated_Parent (Node38) (subtype only)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
@@ -6631,6 +6629,7 @@ package Einfo is
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Interfaces (Elist25)
+ -- Predicated_Parent (Node38) (subtype only)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
-- Has_Private_Extension (Flag300)
@@ -6681,7 +6680,6 @@ package Einfo is
-- Extra_Formals (Node28)
-- Anonymous_Masters (Elist29)
-- Contract (Node34)
- -- Nested_Scenarios (Elist36)
-- SPARK_Pragma (Node40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- SPARK_Pragma_Inherited (Flag265)
@@ -6764,7 +6762,7 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Anonymous_Designated_Type (Node35)
- -- Validated_Object (Node36)
+ -- Validated_Object (Node38)
-- SPARK_Pragma (Node40)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
@@ -7402,7 +7400,6 @@ package Einfo is
function Must_Have_Preelab_Init (Id : E) return B;
function Needs_Debug_Info (Id : E) return B;
function Needs_No_Actuals (Id : E) return B;
- function Nested_Scenarios (Id : E) return L;
function Never_Set_In_Source (Id : E) return B;
function Next_Inlined_Subprogram (Id : E) return E;
function No_Dynamic_Predicate_On_Actual (Id : E) return B;
@@ -7437,6 +7434,7 @@ package Einfo is
function Postconditions_Proc (Id : E) return E;
function Predicated_Parent (Id : E) return E;
function Predicates_Ignored (Id : E) return B;
+ function Prev_Entity (Id : E) return E;
function Prival (Id : E) return E;
function Prival_Link (Id : E) return E;
function Private_Dependents (Id : E) return L;
@@ -8106,7 +8104,6 @@ package Einfo is
procedure Set_Must_Have_Preelab_Init (Id : E; V : B := True);
procedure Set_Needs_Debug_Info (Id : E; V : B := True);
procedure Set_Needs_No_Actuals (Id : E; V : B := True);
- procedure Set_Nested_Scenarios (Id : E; V : L);
procedure Set_Never_Set_In_Source (Id : E; V : B := True);
procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True);
@@ -8139,6 +8136,7 @@ package Einfo is
procedure Set_Partial_View_Has_Unknown_Discr (Id : E; V : B := True);
procedure Set_Pending_Access_Types (Id : E; V : L);
procedure Set_Postconditions_Proc (Id : E; V : E);
+ procedure Set_Prev_Entity (Id : E; V : E);
procedure Set_Prival (Id : E; V : E);
procedure Set_Prival_Link (Id : E; V : E);
procedure Set_Private_Dependents (Id : E; V : L);
@@ -8468,8 +8466,8 @@ package Einfo is
-- Miscellaneous Subprograms --
-------------------------------
- procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
- -- Add an entity to the list of entities declared in the scope V
+ procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id);
+ -- Add an entity to the list of entities declared in the scope Scop
function Get_Full_View (T : Entity_Id) return Entity_Id;
-- If T is an incomplete type and the full declaration has been seen, or
@@ -8480,11 +8478,20 @@ package Einfo is
-- Test if the node N is the name of an entity (i.e. is an identifier,
-- expanded name, or an attribute reference that returns an entity).
+ procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
+ -- Link entities First and Second in one entity chain.
+ --
+ -- NOTE: No updates are done to the First_Entity and Last_Entity fields
+ -- of the scope.
+
function Next_Index (Id : Node_Id) return Node_Id;
-- Given an index from a previous call to First_Index or Next_Index,
-- returns a node representing the occurrence of the next index subtype,
-- or Empty if there are no more index subtypes.
+ procedure Remove_Entity (Id : Entity_Id);
+ -- Remove entity Id from the entity chain of its scope
+
function Scope_Depth (Id : Entity_Id) return Uint;
-- Returns the scope depth value of the Id, unless the Id is a record
-- type, in which case it returns the scope depth of the record scope.
@@ -8496,6 +8503,9 @@ package Einfo is
-- is returned. If K is already a subtype kind it itself is returned. An
-- internal error is generated if no such correspondence exists for K.
+ procedure Unlink_Next_Entity (Id : Entity_Id);
+ -- Unchain entity Id's forward link within the entity chain of its scope
+
----------------------------------
-- Debugging Output Subprograms --
----------------------------------
@@ -8948,6 +8958,7 @@ package Einfo is
pragma Inline (Last_Assignment);
pragma Inline (Last_Entity);
pragma Inline (Limited_View);
+ pragma Inline (Link_Entities);
pragma Inline (Linker_Section_Pragma);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
@@ -8962,7 +8973,6 @@ package Einfo is
pragma Inline (Must_Have_Preelab_Init);
pragma Inline (Needs_Debug_Info);
pragma Inline (Needs_No_Actuals);
- pragma Inline (Nested_Scenarios);
pragma Inline (Never_Set_In_Source);
pragma Inline (Next_Index);
pragma Inline (Next_Inlined_Subprogram);
@@ -9000,6 +9010,7 @@ package Einfo is
pragma Inline (Postconditions_Proc);
pragma Inline (Predicated_Parent);
pragma Inline (Predicates_Ignored);
+ pragma Inline (Prev_Entity);
pragma Inline (Prival);
pragma Inline (Prival_Link);
pragma Inline (Private_Dependents);
@@ -9020,6 +9031,7 @@ package Einfo is
pragma Inline (Related_Instance);
pragma Inline (Related_Type);
pragma Inline (Relative_Deadline_Variable);
+ pragma Inline (Remove_Entity);
pragma Inline (Renamed_Entity);
pragma Inline (Renamed_In_Spec);
pragma Inline (Renamed_Object);
@@ -9072,6 +9084,7 @@ package Einfo is
pragma Inline (Underlying_Full_View);
pragma Inline (Underlying_Record_View);
pragma Inline (Universal_Aliasing);
+ pragma Inline (Unlink_Next_Entity);
pragma Inline (Unset_Reference);
pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Lock_Free);
@@ -9453,7 +9466,6 @@ package Einfo is
pragma Inline (Set_Must_Have_Preelab_Init);
pragma Inline (Set_Needs_Debug_Info);
pragma Inline (Set_Needs_No_Actuals);
- pragma Inline (Set_Nested_Scenarios);
pragma Inline (Set_Never_Set_In_Source);
pragma Inline (Set_Next_Inlined_Subprogram);
pragma Inline (Set_No_Dynamic_Predicate_On_Actual);
@@ -9488,6 +9500,7 @@ package Einfo is
pragma Inline (Set_Postconditions_Proc);
pragma Inline (Set_Predicated_Parent);
pragma Inline (Set_Predicates_Ignored);
+ pragma Inline (Set_Prev_Entity);
pragma Inline (Set_Prival);
pragma Inline (Set_Prival_Link);
pragma Inline (Set_Private_Dependents);
--- gcc/ada/exp_attr.adb
+++ gcc/ada/exp_attr.adb
@@ -2110,12 +2110,11 @@ package body Exp_Attr is
Next_Formal (Old_Formal);
exit when No (Old_Formal);
- Set_Next_Entity (New_Formal,
- New_Copy (Old_Formal));
- Next_Entity (New_Formal);
+ Link_Entities (New_Formal, New_Copy (Old_Formal));
+ Next_Entity (New_Formal);
end loop;
- Set_Next_Entity (New_Formal, Empty);
+ Unlink_Next_Entity (New_Formal);
Set_Last_Entity (Subp_Typ, Extra);
end if;
--- gcc/ada/exp_ch3.adb
+++ gcc/ada/exp_ch3.adb
@@ -6785,8 +6785,8 @@ package body Exp_Ch3 is
SPARK_Pragma_Inherited (Def_Id);
begin
- Set_Next_Entity (New_Id, Next_Entity (Def_Id));
- Set_Next_Entity (Def_Id, Next_Temp);
+ Link_Entities (New_Id, Next_Entity (Def_Id));
+ Link_Entities (Def_Id, Next_Temp);
Set_Chars (Defining_Identifier (N), Chars (Def_Id));
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -9201,8 +9201,8 @@ package body Exp_Ch6 is
declare
Next_Id : constant Entity_Id := Next_Entity (New_Id);
begin
- Set_Next_Entity (New_Id, Next_Entity (Orig_Id));
- Set_Next_Entity (Orig_Id, Next_Id);
+ Link_Entities (New_Id, Next_Entity (Orig_Id));
+ Link_Entities (Orig_Id, Next_Id);
end;
Set_Homonym (New_Id, Homonym (Orig_Id));
--- gcc/ada/exp_disp.adb
+++ gcc/ada/exp_disp.adb
@@ -1030,12 +1030,12 @@ package body Exp_Disp is
Next_Formal (Old_Formal);
exit when No (Old_Formal);
- Set_Next_Entity (New_Formal, New_Copy (Old_Formal));
- Next_Entity (New_Formal);
- Next_Actual (Param);
+ Link_Entities (New_Formal, New_Copy (Old_Formal));
+ Next_Entity (New_Formal);
+ Next_Actual (Param);
end loop;
- Set_Next_Entity (New_Formal, Empty);
+ Unlink_Next_Entity (New_Formal);
Set_Last_Entity (Subp_Typ, Extra);
end if;
--- gcc/ada/exp_spark.adb
+++ gcc/ada/exp_spark.adb
@@ -386,7 +386,7 @@ package body Exp_SPARK is
-- Remove the entity of the renaming declaration from visibility as
-- the analysis of the object declaration will reintroduce it again.
- Remove_Entity (Obj_Id);
+ Remove_Entity_And_Homonym (Obj_Id);
Analyze (N);
-- Otherwise unconditionally remove all side effects from the name
--- gcc/ada/exp_util.adb
+++ gcc/ada/exp_util.adb
@@ -10613,6 +10613,7 @@ package body Exp_Util is
Set_Is_Itype (Res);
Set_Is_Public (Res, False);
Set_Next_Entity (Res, Empty);
+ Set_Prev_Entity (Res, Empty);
Set_Sloc (Res, Sloc (N));
Set_Public_Status (Res);
--- gcc/ada/freeze.adb
+++ gcc/ada/freeze.adb
@@ -4321,7 +4321,7 @@ package body Freeze is
else
if Present (Prev) then
- Set_Next_Entity (Prev, Next_Entity (Comp));
+ Link_Entities (Prev, Next_Entity (Comp));
else
Set_First_Entity (Rec, Next_Entity (Comp));
end if;
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -6609,6 +6609,7 @@ package body Sem_Ch3 is
Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
Svg_Chars : constant Name_Id := Chars (Ibase);
Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
+ Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase);
begin
Copy_Node (Pbase, Ibase);
@@ -6619,6 +6620,7 @@ package body Sem_Ch3 is
Set_Associated_Node_For_Itype (Ibase, N);
Set_Chars (Ibase, Svg_Chars);
+ Set_Prev_Entity (Ibase, Svg_Prev_E);
Set_Next_Entity (Ibase, Svg_Next_E);
Set_Sloc (Ibase, Sloc (Derived_Type));
Set_Scope (Ibase, Scope (Derived_Type));
@@ -7042,7 +7044,7 @@ package body Sem_Ch3 is
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
- Set_Next_Entity
+ Link_Entities
(Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit;
end if;
@@ -9431,8 +9433,8 @@ package body Sem_Ch3 is
-- Restore the fields saved prior to the New_Copy_Tree call
-- and compute the stored constraint.
- Set_Etype (Derived_Type, Save_Etype);
- Set_Next_Entity (Derived_Type, Save_Next_Entity);
+ Set_Etype (Derived_Type, Save_Etype);
+ Link_Entities (Derived_Type, Save_Next_Entity);
if Has_Discriminants (Derived_Type) then
Set_Discriminant_Constraint
@@ -12324,7 +12326,7 @@ package body Sem_Ch3 is
Set_Sloc (Full, Sloc (Priv));
end case;
- Set_Next_Entity (Full, Save_Next_Entity);
+ Link_Entities (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod);
@@ -14424,6 +14426,7 @@ package body Sem_Ch3 is
Set_Is_Volatile (Full, Is_Volatile (Priv));
Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
Set_Scope (Full, Scope (Priv));
+ Set_Prev_Entity (Full, Prev_Entity (Priv));
Set_Next_Entity (Full, Next_Entity (Priv));
Set_First_Entity (Full, First_Entity (Priv));
Set_Last_Entity (Full, Last_Entity (Priv));
@@ -18942,6 +18945,7 @@ package body Sem_Ch3 is
CW_Type : Entity_Id;
CW_Name : Name_Id;
Next_E : Entity_Id;
+ Prev_E : Entity_Id;
begin
if Present (Class_Wide_Type (T)) then
@@ -18974,10 +18978,12 @@ package body Sem_Ch3 is
CW_Name := Chars (CW_Type);
Next_E := Next_Entity (CW_Type);
+ Prev_E := Prev_Entity (CW_Type);
Copy_Node (T, CW_Type);
Set_Comes_From_Source (CW_Type, False);
Set_Chars (CW_Type, CW_Name);
Set_Parent (CW_Type, Parent (T));
+ Set_Prev_Entity (CW_Type, Prev_E);
Set_Next_Entity (CW_Type, Next_E);
-- Ensure we have a new freeze node for the class-wide type. The partial
@@ -21761,7 +21767,7 @@ package body Sem_Ch3 is
-- Indicate where the predicate function may be found
- if No (Predicate_Function (Def_Id)) then
+ if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then
Set_Predicated_Parent (Def_Id, Subtype_Mark_Id);
end if;
end if;
--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -4516,7 +4516,7 @@ package body Sem_Ch6 is
-- Body entities present (formals), so chain stuff past them
else
- Set_Next_Entity
+ Link_Entities
(Last_Entity (Body_Id), Next_Entity (Last_Real_Spec_Entity));
end if;
@@ -10059,9 +10059,6 @@ package body Sem_Ch6 is
E : Entity_Id;
-- Entity that S overrides
- Prev_Vis : Entity_Id := Empty;
- -- Predecessor of E in Homonym chain
-
procedure Check_For_Primitive_Subprogram
(Is_Primitive : out Boolean;
Is_Overriding : Boolean := False);
@@ -11022,198 +11019,161 @@ package body Sem_Ch6 is
Overridden_Subp := E;
- declare
- Prev : Entity_Id;
-
- begin
- Prev := First_Entity (Current_Scope);
- while Present (Prev) and then Next_Entity (Prev) /= E loop
- Next_Entity (Prev);
- end loop;
-
- -- It is possible for E to be in the current scope and
- -- yet not in the entity chain. This can only occur in a
- -- generic context where E is an implicit concatenation
- -- in the formal part, because in a generic body the
- -- entity chain starts with the formals.
+ -- It is possible for E to be in the current scope and
+ -- yet not in the entity chain. This can only occur in a
+ -- generic context where E is an implicit concatenation
+ -- in the formal part, because in a generic body the
+ -- entity chain starts with the formals.
- -- In GNATprove mode, a wrapper for an operation with
- -- axiomatization may be a homonym of another declaration
- -- for an actual subprogram (needs refinement ???).
+ -- In GNATprove mode, a wrapper for an operation with
+ -- axiomatization may be a homonym of another declaration
+ -- for an actual subprogram (needs refinement ???).
- if No (Prev) then
- if In_Instance
- and then GNATprove_Mode
- and then
- Nkind (Original_Node (Unit_Declaration_Node (S))) =
- N_Subprogram_Renaming_Declaration
- then
- return;
- else
- pragma Assert (Chars (E) = Name_Op_Concat);
- null;
- end if;
+ if No (Prev_Entity (E)) then
+ if In_Instance
+ and then GNATprove_Mode
+ and then
+ Nkind (Original_Node (Unit_Declaration_Node (S))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ return;
+ else
+ pragma Assert (Chars (E) = Name_Op_Concat);
+ null;
end if;
+ end if;
- -- E must be removed both from the entity_list of the
- -- current scope, and from the visibility chain.
-
- if Debug_Flag_E then
- Write_Str ("Override implicit operation ");
- Write_Int (Int (E));
- Write_Eol;
- end if;
+ -- E must be removed both from the entity_list of the
+ -- current scope, and from the visibility chain.
- -- If E is a predefined concatenation, it stands for four
- -- different operations. As a result, a single explicit
- -- declaration does not hide it. In a possible ambiguous
- -- situation, Disambiguate chooses the user-defined op,
- -- so it is correct to retain the previous internal one.
+ if Debug_Flag_E then
+ Write_Str ("Override implicit operation ");
+ Write_Int (Int (E));
+ Write_Eol;
+ end if;
- if Chars (E) /= Name_Op_Concat
- or else Ekind (E) /= E_Operator
- then
- -- For nondispatching derived operations that are
- -- overridden by a subprogram declared in the private
- -- part of a package, we retain the derived subprogram
- -- but mark it as not immediately visible. If the
- -- derived operation was declared in the visible part
- -- then this ensures that it will still be visible
- -- outside the package with the proper signature
- -- (calls from outside must also be directed to this
- -- version rather than the overriding one, unlike the
- -- dispatching case). Calls from inside the package
- -- will still resolve to the overriding subprogram
- -- since the derived one is marked as not visible
- -- within the package.
-
- -- If the private operation is dispatching, we achieve
- -- the overriding by keeping the implicit operation
- -- but setting its alias to be the overriding one. In
- -- this fashion the proper body is executed in all
- -- cases, but the original signature is used outside
- -- of the package.
-
- -- If the overriding is not in the private part, we
- -- remove the implicit operation altogether.
-
- if Is_Private_Declaration (S) then
- if not Is_Dispatching_Operation (E) then
- Set_Is_Immediately_Visible (E, False);
- else
- -- Work done in Override_Dispatching_Operation,
- -- so nothing else needs to be done here.
-
- null;
- end if;
+ -- If E is a predefined concatenation, it stands for four
+ -- different operations. As a result, a single explicit
+ -- declaration does not hide it. In a possible ambiguous
+ -- situation, Disambiguate chooses the user-defined op,
+ -- so it is correct to retain the previous internal one.
+ if Chars (E) /= Name_Op_Concat
+ or else Ekind (E) /= E_Operator
+ then
+ -- For nondispatching derived operations that are
+ -- overridden by a subprogram declared in the private
+ -- part of a package, we retain the derived subprogram
+ -- but mark it as not immediately visible. If the
+ -- derived operation was declared in the visible part
+ -- then this ensures that it will still be visible
+ -- outside the package with the proper signature
+ -- (calls from outside must also be directed to this
+ -- version rather than the overriding one, unlike the
+ -- dispatching case). Calls from inside the package
+ -- will still resolve to the overriding subprogram
+ -- since the derived one is marked as not visible
+ -- within the package.
+
+ -- If the private operation is dispatching, we achieve
+ -- the overriding by keeping the implicit operation
+ -- but setting its alias to be the overriding one. In
+ -- this fashion the proper body is executed in all
+ -- cases, but the original signature is used outside
+ -- of the package.
+
+ -- If the overriding is not in the private part, we
+ -- remove the implicit operation altogether.
+
+ if Is_Private_Declaration (S) then
+ if not Is_Dispatching_Operation (E) then
+ Set_Is_Immediately_Visible (E, False);
else
- -- Find predecessor of E in Homonym chain
-
- if E = Current_Entity (E) then
- Prev_Vis := Empty;
- else
- Prev_Vis := Current_Entity (E);
- while Homonym (Prev_Vis) /= E loop
- Prev_Vis := Homonym (Prev_Vis);
- end loop;
- end if;
-
- if Prev_Vis /= Empty then
-
- -- Skip E in the visibility chain
-
- Set_Homonym (Prev_Vis, Homonym (E));
+ -- Work done in Override_Dispatching_Operation, so
+ -- nothing else needs to be done here.
- else
- Set_Name_Entity_Id (Chars (E), Homonym (E));
- end if;
-
- Set_Next_Entity (Prev, Next_Entity (E));
-
- if No (Next_Entity (Prev)) then
- Set_Last_Entity (Current_Scope, Prev);
- end if;
+ null;
end if;
+
+ else
+ Remove_Entity_And_Homonym (E);
end if;
+ end if;
- Enter_Overloaded_Entity (S);
+ Enter_Overloaded_Entity (S);
- -- For entities generated by Derive_Subprograms the
- -- overridden operation is the inherited primitive
- -- (which is available through the attribute alias).
+ -- For entities generated by Derive_Subprograms the
+ -- overridden operation is the inherited primitive
+ -- (which is available through the attribute alias).
- if not (Comes_From_Source (E))
- and then Is_Dispatching_Operation (E)
- and then Find_Dispatching_Type (E) =
- Find_Dispatching_Type (S)
- and then Present (Alias (E))
- and then Comes_From_Source (Alias (E))
- then
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
+ if not (Comes_From_Source (E))
+ and then Is_Dispatching_Operation (E)
+ and then Find_Dispatching_Type (E) =
+ Find_Dispatching_Type (S)
+ and then Present (Alias (E))
+ and then Comes_From_Source (Alias (E))
+ then
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
- -- Normal case of setting entity as overridden
+ -- Normal case of setting entity as overridden
- -- Note: Static_Initialization and Overridden_Operation
- -- attributes use the same field in subprogram entities.
- -- Static_Initialization is only defined for internal
- -- initialization procedures, where Overridden_Operation
- -- is irrelevant. Therefore the setting of this attribute
- -- must check whether the target is an init_proc.
+ -- Note: Static_Initialization and Overridden_Operation
+ -- attributes use the same field in subprogram entities.
+ -- Static_Initialization is only defined for internal
+ -- initialization procedures, where Overridden_Operation
+ -- is irrelevant. Therefore the setting of this attribute
+ -- must check whether the target is an init_proc.
- elsif not Is_Init_Proc (S) then
- Set_Overridden_Operation (S, E);
- Inherit_Subprogram_Contract (S, E);
- end if;
+ elsif not Is_Init_Proc (S) then
+ Set_Overridden_Operation (S, E);
+ Inherit_Subprogram_Contract (S, E);
+ end if;
- Check_Overriding_Indicator (S, E, Is_Primitive => True);
+ Check_Overriding_Indicator (S, E, Is_Primitive => True);
- -- The Ghost policy in effect at the point of declaration
- -- of a parent subprogram and an overriding subprogram
- -- must match (SPARK RM 6.9(17)).
+ -- The Ghost policy in effect at the point of declaration
+ -- of a parent subprogram and an overriding subprogram
+ -- must match (SPARK RM 6.9(17)).
- Check_Ghost_Overriding (S, E);
+ Check_Ghost_Overriding (S, E);
- -- If S is a user-defined subprogram or a null procedure
- -- expanded to override an inherited null procedure, or a
- -- predefined dispatching primitive then indicate that E
- -- overrides the operation from which S is inherited.
+ -- If S is a user-defined subprogram or a null procedure
+ -- expanded to override an inherited null procedure, or a
+ -- predefined dispatching primitive then indicate that E
+ -- overrides the operation from which S is inherited.
- if Comes_From_Source (S)
- or else
- (Present (Parent (S))
- and then
- Nkind (Parent (S)) = N_Procedure_Specification
- and then
- Null_Present (Parent (S)))
- or else
- (Present (Alias (E))
- and then
- Is_Predefined_Dispatching_Operation (Alias (E)))
- then
- if Present (Alias (E)) then
- Set_Overridden_Operation (S, Alias (E));
- Inherit_Subprogram_Contract (S, Alias (E));
- end if;
+ if Comes_From_Source (S)
+ or else
+ (Present (Parent (S))
+ and then Nkind (Parent (S)) = N_Procedure_Specification
+ and then Null_Present (Parent (S)))
+ or else
+ (Present (Alias (E))
+ and then
+ Is_Predefined_Dispatching_Operation (Alias (E)))
+ then
+ if Present (Alias (E)) then
+ Set_Overridden_Operation (S, Alias (E));
+ Inherit_Subprogram_Contract (S, Alias (E));
end if;
+ end if;
- if Is_Dispatching_Operation (E) then
+ if Is_Dispatching_Operation (E) then
- -- An overriding dispatching subprogram inherits the
- -- convention of the overridden subprogram (AI-117).
+ -- An overriding dispatching subprogram inherits the
+ -- convention of the overridden subprogram (AI-117).
- Set_Convention (S, Convention (E));
- Check_Dispatching_Operation (S, E);
+ Set_Convention (S, Convention (E));
+ Check_Dispatching_Operation (S, E);
- else
- Check_Dispatching_Operation (S, Empty);
- end if;
+ else
+ Check_Dispatching_Operation (S, Empty);
+ end if;
- Check_For_Primitive_Subprogram
- (Is_Primitive_Subp, Is_Overriding => True);
- goto Check_Inequality;
- end;
+ Check_For_Primitive_Subprogram
+ (Is_Primitive_Subp, Is_Overriding => True);
+ goto Check_Inequality;
-- Apparent redeclarations in instances can occur when two
-- formal types get the same actual type. The subprograms in
--- gcc/ada/sem_ch7.adb
+++ gcc/ada/sem_ch7.adb
@@ -2159,12 +2159,12 @@ package body Sem_Ch7 is
Exchange_Entities (Id, Full_Id);
- Set_Next_Entity (Id, Next1);
- Set_Homonym (Id, H1);
+ Link_Entities (Id, Next1);
+ Set_Homonym (Id, H1);
- Set_Full_View (Full_Id, Id);
- Set_Next_Entity (Full_Id, Next2);
- Set_Homonym (Full_Id, H2);
+ Set_Full_View (Full_Id, Id);
+ Link_Entities (Full_Id, Next2);
+ Set_Homonym (Full_Id, H2);
end Exchange_Declarations;
----------------------------
--- gcc/ada/sem_elab.adb
+++ gcc/ada/sem_elab.adb
@@ -11185,32 +11185,19 @@ package body Sem_Elab is
procedure Find_And_Process_Nested_Scenarios;
pragma Inline (Find_And_Process_Nested_Scenarios);
-- Examine the declarations and statements of subprogram body N for
- -- suitable scenarios. Save each discovered scenario and process it
- -- accordingly.
-
- procedure Process_Nested_Scenarios (Nested : Elist_Id);
- pragma Inline (Process_Nested_Scenarios);
- -- Invoke Process_Conditional_ABE on each individual scenario found in
- -- list Nested.
+ -- suitable scenarios.
---------------------------------------
-- Find_And_Process_Nested_Scenarios --
---------------------------------------
procedure Find_And_Process_Nested_Scenarios is
- Body_Id : constant Entity_Id := Defining_Entity (N);
-
function Is_Potential_Scenario
(Nod : Node_Id) return Traverse_Result;
-- Determine whether arbitrary node Nod denotes a suitable scenario.
-- If it does, save it in the Nested_Scenarios list of the subprogram
-- body, and process it.
- procedure Save_Scenario (Nod : Node_Id);
- pragma Inline (Save_Scenario);
- -- Save scenario Nod in the Nested_Scenarios list of the subprogram
- -- body.
-
procedure Traverse_List (List : List_Id);
pragma Inline (Traverse_List);
-- Invoke Traverse_Potential_Scenarios on each node in list List
@@ -11303,14 +11290,7 @@ package body Sem_Elab is
-- General case
- -- Save a suitable scenario in the Nested_Scenarios list of the
- -- subprogram body. As a result any subsequent traversals of the
- -- subprogram body started from a different top-level scenario no
- -- longer need to reexamine the tree.
-
elsif Is_Suitable_Scenario (Nod) then
- Save_Scenario (Nod);
-
Process_Conditional_ABE
(N => Nod,
State => State);
@@ -11320,24 +11300,6 @@ package body Sem_Elab is
end Is_Potential_Scenario;
-------------------
- -- Save_Scenario --
- -------------------
-
- procedure Save_Scenario (Nod : Node_Id) is
- Nested : Elist_Id;
-
- begin
- Nested := Nested_Scenarios (Body_Id);
-
- if No (Nested) then
- Nested := New_Elmt_List;
- Set_Nested_Scenarios (Body_Id, Nested);
- end if;
-
- Append_Elmt (Nod, Nested);
- end Save_Scenario;
-
- -------------------
-- Traverse_List --
-------------------
@@ -11365,28 +11327,6 @@ package body Sem_Elab is
Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
end Find_And_Process_Nested_Scenarios;
- ------------------------------
- -- Process_Nested_Scenarios --
- ------------------------------
-
- procedure Process_Nested_Scenarios (Nested : Elist_Id) is
- Nested_Elmt : Elmt_Id;
-
- begin
- Nested_Elmt := First_Elmt (Nested);
- while Present (Nested_Elmt) loop
- Process_Conditional_ABE
- (N => Node (Nested_Elmt),
- State => State);
-
- Next_Elmt (Nested_Elmt);
- end loop;
- end Process_Nested_Scenarios;
-
- -- Local variables
-
- Nested : Elist_Id;
-
-- Start of processing for Traverse_Body
begin
@@ -11411,23 +11351,10 @@ package body Sem_Elab is
Set_Is_Visited_Body (N);
end if;
- Nested := Nested_Scenarios (Defining_Entity (N));
-
- -- The subprogram body was already examined as part of the elaboration
- -- graph starting from a different top-level scenario. There is no need
- -- to traverse the declarations and statements again because this will
- -- yield the exact same scenarios. Use the nested scenarios collected
- -- during the first inspection of the body.
-
- if Present (Nested) then
- Process_Nested_Scenarios (Nested);
+ -- Examine the declarations and statements of the subprogram body for
+ -- suitable scenarios, save and process them accordingly.
- -- Otherwise examine the declarations and statements of the subprogram
- -- body for suitable scenarios, save and process them accordingly.
-
- else
- Find_And_Process_Nested_Scenarios;
- end if;
+ Find_And_Process_Nested_Scenarios;
end Traverse_Body;
-----------------
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -727,7 +727,7 @@ package body Sem_Util is
and then Scop = Current_Scope
then
-- The inherited operation is available at the earliest place after
- -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
+ -- the derived type declaration (RM 7.3.1 (6/1)). This is only
-- relevant for type extensions. If the parent operation appears
-- after the type extension, the operation is not visible.
@@ -740,8 +740,8 @@ package body Sem_Util is
then
if Sloc (Decl) > Sloc (Par) then
Next_E := Next_Entity (Par);
- Set_Next_Entity (Par, S);
- Set_Next_Entity (S, Next_E);
+ Link_Entities (Par, S);
+ Link_Entities (S, Next_E);
return;
else
@@ -7043,7 +7043,7 @@ package body Sem_Util is
null;
else
- Set_Next_Entity (Prev, Next_Entity (E));
+ Link_Entities (Prev, Next_Entity (E));
if No (Next_Entity (Prev)) then
Set_Last_Entity (Current_Scope, Prev);
@@ -19996,6 +19996,13 @@ package body Sem_Util is
end if;
end if;
+ -- Prev_Entity
+
+ Set_Prev_Entity (Id, Node_Id (
+ Copy_Field_With_Replacement
+ (Field => Union_Id (Prev_Entity (Id)),
+ Semantic => True)));
+
-- Next_Entity
Set_Next_Entity (Id, Node_Id (
@@ -22980,92 +22987,43 @@ package body Sem_Util is
end if;
end References_Generic_Formal_Type;
- -------------------
- -- Remove_Entity --
- -------------------
-
- procedure Remove_Entity (Id : Entity_Id) is
- Scop : constant Entity_Id := Scope (Id);
- Prev_Id : Entity_Id;
+ -------------------------------
+ -- Remove_Entity_And_Homonym --
+ -------------------------------
+ procedure Remove_Entity_And_Homonym (Id : Entity_Id) is
begin
- -- Remove the entity from the homonym chain. When the entity is the
- -- head of the chain, associate the entry in the name table with its
- -- homonym effectively making it the new head of the chain.
-
- if Current_Entity (Id) = Id then
- Set_Name_Entity_Id (Chars (Id), Homonym (Id));
-
- -- Otherwise link the previous and next homonyms
-
- else
- Prev_Id := Current_Entity (Id);
- if Present (Prev_Id) then
- while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop
- Prev_Id := Homonym (Prev_Id);
- end loop;
-
- Set_Homonym (Prev_Id, Homonym (Id));
- end if;
- end if;
-
- -- Remove the entity from the scope entity chain. When the entity is
- -- the head of the chain, set the next entity as the new head of the
- -- chain.
-
- if First_Entity (Scop) = Id then
- Prev_Id := Empty;
- Set_First_Entity (Scop, Next_Entity (Id));
-
- -- Otherwise the entity is either in the middle of the chain or it acts
- -- as its tail. Traverse and link the previous and next entities.
-
- else
- Prev_Id := First_Entity (Scop);
- while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop
- Next_Entity (Prev_Id);
- end loop;
-
- if Present (Prev_Id) then
- Set_Next_Entity (Prev_Id, Next_Entity (Id));
- end if;
- end if;
-
- -- Handle the case where the entity acts as the tail of the scope entity
- -- chain.
-
- if Last_Entity (Scop) = Id then
- Set_Last_Entity (Scop, Prev_Id);
- end if;
- end Remove_Entity;
+ Remove_Entity (Id);
+ Remove_Homonym (Id);
+ end Remove_Entity_And_Homonym;
--------------------
-- Remove_Homonym --
--------------------
- procedure Remove_Homonym (E : Entity_Id) is
- Prev : Entity_Id := Empty;
- H : Entity_Id;
+ procedure Remove_Homonym (Id : Entity_Id) is
+ Hom : Entity_Id;
+ Prev : Entity_Id := Empty;
begin
- if E = Current_Entity (E) then
- if Present (Homonym (E)) then
- Set_Current_Entity (Homonym (E));
+ if Id = Current_Entity (Id) then
+ if Present (Homonym (Id)) then
+ Set_Current_Entity (Homonym (Id));
else
- Set_Name_Entity_Id (Chars (E), Empty);
+ Set_Name_Entity_Id (Chars (Id), Empty);
end if;
else
- H := Current_Entity (E);
- while Present (H) and then H /= E loop
- Prev := H;
- H := Homonym (H);
+ Hom := Current_Entity (Id);
+ while Present (Hom) and then Hom /= Id loop
+ Prev := Hom;
+ Hom := Homonym (Hom);
end loop;
- -- If E is not on the homonym chain, nothing to do
+ -- If Id is not on the homonym chain, nothing to do
- if Present (H) then
- Set_Homonym (Prev, Homonym (E));
+ if Present (Hom) then
+ Set_Homonym (Prev, Homonym (Id));
end if;
end if;
end Remove_Homonym;
@@ -23103,9 +23061,7 @@ package body Sem_Util is
-- Start of processing for Remove_Overloaded_Entity
begin
- -- Remove the entity from both the homonym and scope chains
-
- Remove_Entity (Id);
+ Remove_Entity_And_Homonym (Id);
-- The entity denotes a primitive subprogram. Remove it from the list of
-- primitives of the associated controlling type.
@@ -24656,7 +24612,7 @@ package body Sem_Util is
-- destination scope.
if Present (Last_Entity (To)) then
- Set_Next_Entity (Last_Entity (To), Id);
+ Link_Entities (Last_Entity (To), Id);
else
Set_First_Entity (To, Id);
end if;
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -2489,14 +2489,14 @@ package Sem_Util is
-- Returns True if the expression Expr contains any references to a generic
-- type. This can only happen within a generic template.
- procedure Remove_Entity (Id : Entity_Id);
+ procedure Remove_Entity_And_Homonym (Id : Entity_Id);
-- Remove arbitrary entity Id from both the homonym and scope chains. Use
-- Remove_Overloaded_Entity for overloadable entities. Note: the removal
-- performed by this routine does not affect the visibility of existing
-- homonyms.
- procedure Remove_Homonym (E : Entity_Id);
- -- Removes E from the homonym chain
+ procedure Remove_Homonym (Id : Entity_Id);
+ -- Removes entity Id from the homonym chain
procedure Remove_Overloaded_Entity (Id : Entity_Id);
-- Remove arbitrary entity Id from the homonym chain, the scope chain and