diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 58 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 193 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 53 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_spark.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 296 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 81 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 112 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
16 files changed, 428 insertions, 425 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 30f5cd6..b0ce1be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,61 @@ +2018-05-24 Justin Squirek <squirek@adacore.com> + + * 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. + 2018-05-24 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch10.adb (Expand_Limited_With_Clause): Update the call to diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7ba4327..c0cb261 100644 --- a/gcc/ada/einfo.adb +++ b/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??"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 1baac05..e6dea67 100644 --- a/gcc/ada/einfo.ads +++ b/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); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c29aa80..30d6605 100644 --- a/gcc/ada/exp_attr.adb +++ b/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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4c3a7b7..a8e2499 100644 --- a/gcc/ada/exp_ch3.adb +++ b/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)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 21d87ef..3395c21 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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)); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 0a63645..dbccfed 100644 --- a/gcc/ada/exp_disp.adb +++ b/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; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index a8c8e3b..f59e5f3 100644 --- a/gcc/ada/exp_spark.adb +++ b/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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8ae2d2b..256f6bb 100644 --- a/gcc/ada/exp_util.adb +++ b/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); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 50485f1..a275619 100644 --- a/gcc/ada/freeze.adb +++ b/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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1a3e4d4..f3ba069 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index e838e6a..5eab1e0 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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 diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 866c6f9..cb4b853 100644 --- a/gcc/ada/sem_ch7.adb +++ b/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; ---------------------------- diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 0b7fcb4..9525f7f 100644 --- a/gcc/ada/sem_elab.adb +++ b/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; ----------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4e12f93..d205e58 100644 --- a/gcc/ada/sem_util.adb +++ b/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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 66280f9..2aa7432 100644 --- a/gcc/ada/sem_util.ads +++ b/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 |