diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-08 10:59:32 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-09-08 10:59:32 +0200 |
commit | 74a78a4f1c273094fbddf9235afc092a3aaadd69 (patch) | |
tree | 12c45476b5dca94550dbf46eb9c38a546d8e00e4 | |
parent | 133de112314c89d6467742ea3bcf3a4cf623532e (diff) | |
download | gcc-74a78a4f1c273094fbddf9235afc092a3aaadd69.zip gcc-74a78a4f1c273094fbddf9235afc092a3aaadd69.tar.gz gcc-74a78a4f1c273094fbddf9235afc092a3aaadd69.tar.bz2 |
[multiple changes]
2017-09-08 Hristian Kirtchev <kirtchev@adacore.com>
* exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration):
Reimplemented.
(Expand_SPARK_Potential_Renaming): Code clean up.
* sem_prag.adb (Analyze_Initialization_Item): Add a guard in case
the item does not have a proper entity.
(Analyze_Input_Item): Add a guard in case the item does not have a
proper entity.
(Collect_States_And_Objects): Include object renamings in the
items being collected.
(Resolve_State): Update the documentation of this routine.
* sem_util.adb (Entity_Of): Add circuitry to handle
renamings of function results.
(Remove_Entity): New routine.
(Remove_Overloaded_Entity): Take advantage of factorization.
* sem_util.ads (Entity_Of): Update the documentation
of this routine.
(Remove_Entity): New routine.
(Remove_Overloaded_Entity): Update the documentation of this
routine.
2017-09-08 Eric Botcazou <ebotcazou@adacore.com>
* repinfo.adb (List_Record_Info): During first loop,
do not override the normalized position and first bit
if they have already been set. Move fallback code
for the packed case to the case where it belongs.
* sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order):
Also adjust the normalized position of components.
(Adjust_Record_For_Reverse_Bit_Order_Ada_95): Likewise.
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* exp_disp.adb (Make_DT, Set_All_DT_Position): Handle properly
the placement of a primitive operation O that renames an operation
R declared in an inner package, and which is thus not a primitive
of the dispatching type of O. In this case O is a new primitive
and does not inherit its dispatch table position from R (which
has none).
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension_If_Expression,
Analyze_Dimension_Case_Expression): new subprograms to verify
the dimensional correctness of Ada2012 conditional expressions,
and set properly the dimensions of the construct.
* sem_res.adb (Resolve_If_Expression, Resolve_Case_Expression)):
call Analyze_Dimension.
2017-09-08 Ed Schonberg <schonberg@adacore.com>
* sem_type.adb (Expand_Interface_Conversion): Prevent an infinite
loop on an interface declared as a private extension of another
synchronized interface.
From-SVN: r251868
-rw-r--r-- | gcc/ada/ChangeLog | 56 | ||||
-rw-r--r-- | gcc/ada/exp_disp.adb | 46 | ||||
-rw-r--r-- | gcc/ada/exp_spark.adb | 72 | ||||
-rw-r--r-- | gcc/ada/repinfo.adb | 30 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 4 | ||||
-rw-r--r-- | gcc/ada/sem_dim.adb | 50 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 33 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_type.adb | 5 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 137 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 17 |
11 files changed, 341 insertions, 112 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 98850e9..1014e0e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,59 @@ +2017-09-08 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): + Reimplemented. + (Expand_SPARK_Potential_Renaming): Code clean up. + * sem_prag.adb (Analyze_Initialization_Item): Add a guard in case + the item does not have a proper entity. + (Analyze_Input_Item): Add a guard in case the item does not have a + proper entity. + (Collect_States_And_Objects): Include object renamings in the + items being collected. + (Resolve_State): Update the documentation of this routine. + * sem_util.adb (Entity_Of): Add circuitry to handle + renamings of function results. + (Remove_Entity): New routine. + (Remove_Overloaded_Entity): Take advantage of factorization. + * sem_util.ads (Entity_Of): Update the documentation + of this routine. + (Remove_Entity): New routine. + (Remove_Overloaded_Entity): Update the documentation of this + routine. + +2017-09-08 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Record_Info): During first loop, + do not override the normalized position and first bit + if they have already been set. Move fallback code + for the packed case to the case where it belongs. + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): + Also adjust the normalized position of components. + (Adjust_Record_For_Reverse_Bit_Order_Ada_95): Likewise. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Make_DT, Set_All_DT_Position): Handle properly + the placement of a primitive operation O that renames an operation + R declared in an inner package, and which is thus not a primitive + of the dispatching type of O. In this case O is a new primitive + and does not inherit its dispatch table position from R (which + has none). + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Analyze_Dimension_If_Expression, + Analyze_Dimension_Case_Expression): new subprograms to verify + the dimensional correctness of Ada2012 conditional expressions, + and set properly the dimensions of the construct. + * sem_res.adb (Resolve_If_Expression, Resolve_Case_Expression)): + call Analyze_Dimension. + +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Expand_Interface_Conversion): Prevent an infinite + loop on an interface declared as a private extension of another + synchronized interface. + 2017-09-08 Ed Schonberg <schonberg@adacore.com> * sem_ch12.adb (Check_Generic_Parent): New procedure within diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2abd7d1..e5e2c61 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -5896,6 +5896,16 @@ package body Exp_Disp is -- handling of renamings and eliminated primitives. E := Ultimate_Alias (Prim); + + -- If the alias is not a primitive operation then Prim does + -- not rename another primitive, but rather an operation + -- declared elsewhere (e.g. in another scope) and therefore + -- Prim is a new primitive. + + if No (Find_Dispatching_Type (E)) then + E := Prim; + end if; + Prim_Pos := UI_To_Int (DT_Position (E)); -- Skip predefined primitives because they are located in a @@ -7781,24 +7791,36 @@ package body Exp_Disp is Set_DT_Position_Value (Alias (Prim), DT_Position (E)); Set_Fixed_Prim (UI_To_Int (DT_Position (Prim))); - -- Overriding primitives must use the same entry as the - -- overridden primitive. + -- Overriding primitives must use the same entry as the overridden + -- primitive. Note that the Alias of the operation is set when the + -- operation is declared by a renaming, in which case it is not + -- overriding. If it renames another primitive it will use the + -- same dispatch table slot, but if it renames an operation in a + -- nested package it's a new primitive and will have its own slot. elsif not Present (Interface_Alias (Prim)) and then Present (Alias (Prim)) and then Chars (Prim) = Chars (Alias (Prim)) - and then Find_Dispatching_Type (Alias (Prim)) /= Typ - and then Is_Ancestor - (Find_Dispatching_Type (Alias (Prim)), Typ, - Use_Full_View => True) - and then Present (DTC_Entity (Alias (Prim))) + and then Nkind (Unit_Declaration_Node (Prim)) /= + N_Subprogram_Renaming_Declaration then - E := Alias (Prim); - Set_DT_Position_Value (Prim, DT_Position (E)); + declare + Par_Type : constant Entity_Id := + Find_Dispatching_Type (Alias (Prim)); + begin + if Present (Par_Type) + and then Par_Type /= Typ + and then Is_Ancestor (Par_Type, Typ, Use_Full_View => True) + and then Present (DTC_Entity (Alias (Prim))) + then + E := Alias (Prim); + Set_DT_Position_Value (Prim, DT_Position (E)); - if not Is_Predefined_Dispatching_Alias (E) then - Set_Fixed_Prim (UI_To_Int (DT_Position (E))); - end if; + if not Is_Predefined_Dispatching_Alias (E) then + Set_Fixed_Prim (UI_To_Int (DT_Position (E))); + end if; + end if; + end; end if; Next_Elmt (Prim_Elmt); diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 785652e..211fea3 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -292,10 +292,55 @@ package body Exp_SPARK is ------------------------------------------------ procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id) is + CFS : constant Boolean := Comes_From_Source (N); + Loc : constant Source_Ptr := Sloc (N); + Obj_Id : constant Entity_Id := Defining_Entity (N); + Nam : constant Node_Id := Name (N); + Typ : constant Entity_Id := Etype (Subtype_Mark (N)); + begin - -- Unconditionally remove all side effects from the name + -- Transform a renaming of the form + + -- Obj_Id : <subtype mark> renames <function call>; + + -- into + + -- Obj_Id : constant <subtype mark> := <function call>; + + -- Invoking Evaluate_Name and ultimately Remove_Side_Effects introduces + -- a temporary to capture the function result. Once potential renamings + -- are rewritten for SPARK, the temporary may be leaked out into source + -- constructs and lead to confusing error diagnostics. Using an object + -- declaration prevents this unwanted side effect. + + if Nkind (Nam) = N_Function_Call then + Rewrite (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Nam)); + + -- Inherit the original Comes_From_Source status of the renaming - Evaluate_Name (Name (N)); + Set_Comes_From_Source (N, CFS); + + -- Sever the link to the renamed function result because the entity + -- will no longer alias anything. + + Set_Renamed_Object (Obj_Id, Empty); + + -- Remove the entity of the renaming declaration from visibility as + -- the analysis of the object declaration will reintroduce it again. + + Remove_Entity (Obj_Id); + Analyze (N); + + -- Otherwise unconditionally remove all side effects from the name + + else + Evaluate_Name (Nam); + end if; end Expand_SPARK_N_Object_Renaming_Declaration; ------------------------ @@ -324,29 +369,30 @@ package body Exp_SPARK is procedure Expand_SPARK_Potential_Renaming (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Ren_Id : constant Entity_Id := Entity (N); + Obj_Id : constant Entity_Id := Entity (N); Typ : constant Entity_Id := Etype (N); - Obj_Id : Node_Id; + Ren : Node_Id; begin -- Replace a reference to a renaming with the actual renamed object - if Ekind (Ren_Id) in Object_Kind then - Obj_Id := Renamed_Object (Ren_Id); + if Ekind (Obj_Id) in Object_Kind then + Ren := Renamed_Object (Obj_Id); - if Present (Obj_Id) then + if Present (Ren) then - -- The renamed object is an entity when instantiating generics - -- or inlining bodies. In this case the renaming is part of the - -- mapping "prologue" which links actuals to formals. + -- Instantiations and inlining of subprograms employ "prologues" + -- which map actual to formal parameters by means of renamings. + -- Replace a reference to a formal by the corresponding actual + -- parameter. - if Nkind (Obj_Id) in N_Entity then - Rewrite (N, New_Occurrence_Of (Obj_Id, Loc)); + if Nkind (Ren) in N_Entity then + Rewrite (N, New_Occurrence_Of (Ren, Loc)); -- Otherwise the renamed object denotes a name else - Rewrite (N, New_Copy_Tree (Obj_Id, New_Sloc => Loc)); + Rewrite (N, New_Copy_Tree (Ren, New_Sloc => Loc)); Reset_Analyzed_Flags (N); end if; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 57528d6..2634ee8 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -894,30 +894,30 @@ package body Repinfo is Cfbit := Component_Bit_Offset (Comp); if Rep_Not_Constant (Cfbit) then - UI_Image_Length := 2; + -- If the record is not packed, then we know that all fields + -- whose position is not specified have a starting normalized + -- bit position of zero. + if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) + then + Set_Normalized_First_Bit (Comp, Uint_0); + end if; + + UI_Image_Length := 2; -- For "??" marker else -- Complete annotation in case not done - Set_Normalized_Position (Comp, Cfbit / SSU); - Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + if Unknown_Normalized_First_Bit (Comp) then + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + end if; Sunit := Cfbit / SSU; UI_Image (Sunit); end if; - -- If the record is not packed, then we know that all fields - -- whose position is not specified have a starting normalized - -- bit position of zero. - - if Unknown_Normalized_First_Bit (Comp) - and then not Is_Packed (Ent) - then - Set_Normalized_First_Bit (Comp, Uint_0); - end if; - - Max_Suni_Length := - Natural'Max (Max_Suni_Length, UI_Image_Length); + Max_Suni_Length := Natural'Max (Max_Suni_Length, UI_Image_Length); end if; Next_Component_Or_Discriminant (Comp); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 90b629c..9b97f8f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -627,6 +627,7 @@ package body Sem_Ch13 is end if; Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_Position (Comp, Pos + NFB / SSU); Set_Normalized_First_Bit (Comp, NFB mod SSU); end; end loop; @@ -750,6 +751,9 @@ package body Sem_Ch13 is (System_Storage_Unit - 1) - (Start_Bit + CSZ - 1)); + Set_Normalized_Position (Comp, + Component_Bit_Offset (Comp) / System_Storage_Unit); + Set_Normalized_First_Bit (Comp, Component_Bit_Offset (Comp) mod System_Storage_Unit); end if; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index baa5639..6e829f9 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -194,6 +194,8 @@ package body Sem_Dim is OK_For_Dimension : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, + N_Case_Expression => True, + N_If_Expression => True, N_Expanded_Name => True, N_Explicit_Dereference => True, N_Defining_Identifier => True, @@ -254,6 +256,12 @@ package body Sem_Dim is -- N_Type_Conversion -- N_Unchecked_Type_Conversion + procedure Analyze_Dimension_Case_Expression (N : Node_Id); + -- Verify that all alternatives have the same dimension + + procedure Analyze_Dimension_If_Expression (N : Node_Id); + -- Verify that all alternatives have the same dimension + procedure Analyze_Dimension_Number_Declaration (N : Node_Id); -- Procedure to analyze dimension of expression in a number declaration. -- This allows a named number to have nontrivial dimensions, while by @@ -1179,6 +1187,12 @@ package body Sem_Dim is => Analyze_Dimension_Has_Etype (N); + when N_Case_Expression => + Analyze_Dimension_Case_Expression (N); + + when N_If_Expression => + Analyze_Dimension_If_Expression (N); + -- In the presence of a repaired syntax error, an identifier -- may be introduced without a usable type. @@ -1768,6 +1782,27 @@ package body Sem_Dim is end if; end Analyze_Dimension_Call; + --------------------------------------- + -- Analyze_Dimension_Case_Expression -- + --------------------------------------- + + procedure Analyze_Dimension_Case_Expression (N : Node_Id) is + Alt : Node_Id; + Frst : constant Node_Id := First (Alternatives (N)); + Dims : constant Dimension_Type := Dimensions_Of (Expression (Frst)); + begin + Alt := Next (Frst); + while Present (Alt) loop + if Dimensions_Of (Expression (Alt)) /= Dims then + Error_Msg_N ("dimension mismatch in case expression", Alt); + exit; + end if; + + Next (Alt); + end loop; + Copy_Dimensions (Expression (Frst), N); + end Analyze_Dimension_Case_Expression; + --------------------------------------------- -- Analyze_Dimension_Component_Declaration -- --------------------------------------------- @@ -2102,6 +2137,21 @@ package body Sem_Dim is end case; end Analyze_Dimension_Has_Etype; + ------------------------------------- + -- Analyze_Dimension_If_Expression -- + ------------------------------------- + + procedure Analyze_Dimension_If_Expression (N : Node_Id) is + Then_Expr : constant Node_Id := Next (First (Expressions (N))); + Else_Expr : constant Node_Id := Next (Then_Expr); + begin + if Dimensions_Of (Then_Expr) /= Dimensions_Of (Else_Expr) then + Error_Msg_N ("dimensions mismatch in conditional expression", N); + else + Copy_Dimensions (Then_Expr, N); + end if; + end Analyze_Dimension_If_Expression; + ------------------------------------------ -- Analyze_Dimension_Number_Declaration -- ------------------------------------------ diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 2f6b230..dc0f830 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -283,9 +283,9 @@ package body Sem_Prag is -- reference for future checks (see Analyze_Refined_State_In_Decls). procedure Resolve_State (N : Node_Id); - -- Handle the overloading of state names by parameterless functions. When N - -- denotes a function, this routine finds the corresponding state and sets - -- the entity of N to that of the state. + -- Handle the overloading of state names by functions. When N denotes a + -- function, this routine finds the corresponding state and sets the entity + -- of N to that of the state. procedure Rewrite_Assertion_Kind (N : Node_Id; @@ -2811,9 +2811,10 @@ package body Sem_Prag is if Is_Entity_Name (Item) then Item_Id := Entity_Of (Item); - if Ekind_In (Item_Id, E_Abstract_State, - E_Constant, - E_Variable) + if Present (Item_Id) + and then Ekind_In (Item_Id, E_Abstract_State, + E_Constant, + E_Variable) then -- The state or variable must be declared in the visible -- declarations of the package (SPARK RM 7.1.5(7)). @@ -2918,14 +2919,15 @@ package body Sem_Prag is if Is_Entity_Name (Input) then Input_Id := Entity_Of (Input); - if Ekind_In (Input_Id, E_Abstract_State, - E_Constant, - E_Generic_In_Out_Parameter, - E_Generic_In_Parameter, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) + if Present (Input_Id) + and then Ekind_In (Input_Id, E_Abstract_State, + E_Constant, + E_Generic_In_Out_Parameter, + E_Generic_In_Parameter, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter, + E_Variable) then -- The input cannot denote states or objects declared -- within the related package (SPARK RM 7.1.5(4)). @@ -3073,7 +3075,8 @@ package body Sem_Prag is Decl := First (Visible_Declarations (Pack_Spec)); while Present (Decl) loop if Comes_From_Source (Decl) - and then Nkind (Decl) = N_Object_Declaration + and then Nkind_In (Decl, N_Object_Declaration, + N_Object_Renaming_Declaration) then Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2d8751c..ed96c53 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6772,6 +6772,7 @@ package body Sem_Res is Set_Etype (N, Typ); Eval_Case_Expression (N); + Analyze_Dimension (N); end Resolve_Case_Expression; ------------------------------- @@ -8357,6 +8358,8 @@ package body Sem_Res is if not Error_Posted (N) then Eval_If_Expression (N); end if; + + Analyze_Dimension (N); end Resolve_If_Expression; ------------------------------- diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index f098760..c9d8f4b 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2947,11 +2947,14 @@ package body Sem_Type is -- Continue climbing else - -- Use the full-view of private types (if allowed) + -- Use the full-view of private types (if allowed). + -- Guard against infinite loops when full view has same + -- type as parent, as can happen with interface extensions, if Use_Full_View and then Is_Private_Type (Par) and then Present (Full_View (Par)) + and then Par /= Etype (Full_View (Par)) then Par := Etype (Full_View (Par)); else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e9bcdad..968de98 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7117,23 +7117,46 @@ package body Sem_Util is --------------- function Entity_Of (N : Node_Id) return Entity_Id is - Id : Entity_Id; + Id : Entity_Id; + Ren : Node_Id; begin + -- Assume that the arbitrary node does not have an entity + Id := Empty; if Is_Entity_Name (N) then Id := Entity (N); - -- Follow a possible chain of renamings to reach the root renamed - -- object. + -- Follow a possible chain of renamings to reach the earliest renamed + -- source object. while Present (Id) and then Is_Object (Id) and then Present (Renamed_Object (Id)) loop - if Is_Entity_Name (Renamed_Object (Id)) then - Id := Entity (Renamed_Object (Id)); + Ren := Renamed_Object (Id); + + -- The reference renames an abstract state or a whole object + + -- Obj : ...; + -- Ren : ... renames Obj; + + if Is_Entity_Name (Ren) then + Id := Entity (Ren); + + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + elsif Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + + -- Otherwise the reference renames something which does not yield + -- an abstract state or a whole object. Treat the reference as not + -- having a proper entity for SPARK legality purposes. + else Id := Empty; exit; @@ -20369,6 +20392,61 @@ 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; + + 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); + 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; + + -- 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; + + Set_Next_Entity (Prev_Id, Next_Entity (Id)); + 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_Homonym -- -------------------- @@ -20428,57 +20506,14 @@ package body Sem_Util is -- Local variables - Scop : constant Entity_Id := Scope (Id); - Formal : Entity_Id; - Prev_Id : Entity_Id; + Formal : Entity_Id; -- Start of processing for Remove_Overloaded_Entity 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); - 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; - - -- 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)); + -- Remove the entity from both the homonym and scope chains - -- 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; - - Set_Next_Entity (Prev_Id, Next_Entity (Id)); - 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; + Remove_Entity (Id); -- The entity denotes a primitive subprogram. Remove it from the list of -- primitives of the associated controlling type. diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b8f4bed..58a362b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -689,8 +689,9 @@ package Sem_Util is -- are entered using Sem_Ch6.Enter_Overloadable_Entity. function Entity_Of (N : Node_Id) return Entity_Id; - -- Return the entity of N or Empty. If N is a renaming, return the entity - -- of the root renamed object. + -- Obtain the entity of arbitrary node N. If N is a renaming, return the + -- entity of the earliest renamed source abstract state or whole object. + -- If no suitable entity is available, return Empty. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); -- This procedure is called after issuing a message complaining about an @@ -2265,14 +2266,20 @@ 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); + -- 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_Overloaded_Entity (Id : Entity_Id); -- Remove arbitrary entity Id from the homonym chain, the scope chain and - -- the primitive operations list of the associated controlling type. NOTE: - -- the removal performed by this routine does not affect the visibility of - -- existing homonyms. + -- the primitive operations list of the associated controlling type. Use + -- Remove_Entity for non-overloadable entities. Note: the removal performed + -- by this routine does not affect the visibility of existing homonyms. function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id; -- Returns the name of E without Suffix |