From 2c17ca0a2f305b29c9efa0e05e27583f775d005d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 2 Sep 2011 09:42:02 +0200 Subject: [PATCH] [multiple changes] 2011-09-02 Robert Dewar * exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb, g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor reformatting. 2011-09-02 Hristian Kirtchev * sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an inherited component with the enclosing derived type. Code reformatting. 2011-09-02 Gary Dismukes * checks.adb: (Determine_Range): Add test of OK1 to prevent the early return done when overflow checks are enabled, since comparisons against Lor and Hir should not be done when OK1 is False. 2011-09-02 Gary Dismukes * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Add new formal Master_Exp. When present, add that expression to the call as an extra actual. (Make_Build_In_Place_Call_In_Object_Declaration): Add variable Fmaster_Actual and in the case of a BIP call initializing a return object of an enclosing BIP function set it to a new reference to the implicit finalization master formal of the enclosing function. Fmaster_Actual is then passed to the new formal Master_Exp on the call to Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move initializations of Enclosing_Func to its declaration. 2011-09-02 Thomas Quinot * csets.ads: Minor reformatting 2011-09-02 Hristian Kirtchev * exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve the full view of a private type coming from an instantiation. * exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search loop to iterate over the declarations rather than use the First_Entity / Next_Entity scheme. From-SVN: r178438 --- gcc/ada/ChangeLog | 43 +++++++++++++++++++++++++++++++++ gcc/ada/checks.adb | 5 ++-- gcc/ada/csets.ads | 4 +-- gcc/ada/exp_aggr.adb | 17 +++++++++++-- gcc/ada/exp_ch4.adb | 48 +++++++++++++++++++++++------------- gcc/ada/exp_ch6.adb | 51 +++++++++++++++++++++++++++------------ gcc/ada/exp_util.adb | 27 ++++++++++----------- gcc/ada/g-comlin.adb | 1 + gcc/ada/g-comlin.ads | 25 +++++++++++-------- gcc/ada/lib-xref-alfa.adb | 4 +-- gcc/ada/lib-xref.adb | 20 +++++++-------- gcc/ada/s-htable.adb | 6 ++--- gcc/ada/sem_attr.adb | 4 +-- gcc/ada/sem_ch10.adb | 2 +- gcc/ada/sem_ch3.adb | 22 ++++++++++++----- 15 files changed, 193 insertions(+), 86 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 885cbad07ce..dec2a2cc10f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2011-09-02 Robert Dewar + + * exp_util.adb, sem_ch10.adb, sem_attr.adb, s-htable.adb, + g-comlin.adb, g-comlin.ads, lib-xref-alfa.adb, lib-xref.adb: Minor + reformatting. + +2011-09-02 Hristian Kirtchev + + * sem_ch3.adb: (Set_Anonymous_Type): Associate the itype of an + inherited component with the enclosing derived type. Code reformatting. + +2011-09-02 Gary Dismukes + + * checks.adb: (Determine_Range): Add test of OK1 to prevent the early + return done when overflow checks are enabled, since comparisons against + Lor and Hir should not be done when OK1 is False. + +2011-09-02 Gary Dismukes + + * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): + Add new formal Master_Exp. When present, add that expression to the + call as an extra actual. + (Make_Build_In_Place_Call_In_Object_Declaration): Add variable + Fmaster_Actual and in the case of a BIP call initializing a return + object of an enclosing BIP function set it to a + new reference to the implicit finalization master + formal of the enclosing function. Fmaster_Actual is + then passed to the new formal Master_Exp on the call to + Add_Finalization_Master_Actual_To_Build_ In_Place_Call. Move + initializations of Enclosing_Func to its declaration. + +2011-09-02 Thomas Quinot + + * csets.ads: Minor reformatting + +2011-09-02 Hristian Kirtchev + + * exp_aggr.adb: (Get_Constraint_Association): Add code to retrieve + the full view of a private type coming from an instantiation. + * exp_ch4.adb: (Current_Anonymous_Master): Reimplement the search + loop to iterate over the declarations rather than use the + First_Entity / Next_Entity scheme. + 2011-09-02 Ed Schonberg * sem_attr.adb: (Analyze_Attribute, case 'Range): when expanding diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 3eb0c4ec141..cb07771343b 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3479,10 +3479,11 @@ package body Checks is -- to restrict the possible range of results. -- If one of the computed bounds is outside the range of the base type, - -- the expression may raise an exception and we better indicate that + -- the expression may raise an exception and we had better indicate that -- the evaluation has failed, at least if checks are enabled. - if Enable_Overflow_Checks + if OK1 + and then Enable_Overflow_Checks and then not Is_Entity_Name (N) and then (Lor < Lo or else Hir > Hi) then diff --git a/gcc/ada/csets.ads b/gcc/ada/csets.ads index ebf167096e1..2f40e36aa8c 100644 --- a/gcc/ada/csets.ads +++ b/gcc/ada/csets.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -90,7 +90,7 @@ package Csets is -- This table has True entries for all characters that can legally appear -- in identifiers, including digits, the underline character, all letters -- including upper and lower case and extended letters (as controlled by - -- the setting of Opt.Identifier_Character_Set, left bracket for brackets + -- the setting of Opt.Identifier_Character_Set), left bracket for brackets -- notation wide characters and also ESC if wide characters are permitted -- in identifiers using escape sequences starting with ESC. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a54ebe8b297..03b686c5a9d 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1984,10 +1984,23 @@ package body Exp_Aggr is -------------------------------- function Get_Constraint_Association (T : Entity_Id) return Node_Id is - Typ_Def : constant Node_Id := Type_Definition (Parent (T)); - Indic : constant Node_Id := Subtype_Indication (Typ_Def); + Indic : Node_Id; + Typ : Entity_Id; begin + Typ := T; + + -- Handle private types in instances + + if In_Instance + and then Is_Private_Type (Typ) + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + Indic := Subtype_Indication (Type_Definition (Parent (Typ))); + -- ??? Also need to cover case of a type mark denoting a subtype -- with constraint. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3c6754b26bb..91d79e30fbe 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -380,12 +380,11 @@ package body Exp_Ch4 is ------------------------------ function Current_Anonymous_Master return Entity_Id is - Decls : List_Id; - Fin_Mas_Id : Entity_Id; - Loc : Source_Ptr; - Subp_Body : Node_Id; - Unit_Decl : Node_Id; - Unit_Id : Entity_Id; + Decls : List_Id; + Loc : Source_Ptr; + Subp_Body : Node_Id; + Unit_Decl : Node_Id; + Unit_Id : Entity_Id; begin Unit_Id := Cunit_Entity (Current_Sem_Unit); @@ -440,21 +439,35 @@ package body Exp_Ch4 is -- declarations and locate the entity. if Has_Anonymous_Master (Unit_Id) then - Fin_Mas_Id := First_Entity (Unit_Id); - while Present (Fin_Mas_Id) loop + declare + Decl : Node_Id; + Fin_Mas_Id : Entity_Id; - -- Look for the first variable whose type is Finalization_Master + begin + Decl := First (Decls); + while Present (Decl) loop - if Ekind (Fin_Mas_Id) = E_Variable - and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) - then - return Fin_Mas_Id; - end if; + -- Look for the first variable in the declarations whole type + -- is Finalization_Master. - Next_Entity (Fin_Mas_Id); - end loop; + if Nkind (Decl) = N_Object_Declaration then + Fin_Mas_Id := Defining_Identifier (Decl); - raise Program_Error; + if Ekind (Fin_Mas_Id) = E_Variable + and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master) + then + return Fin_Mas_Id; + end if; + end if; + + Next (Decl); + end loop; + + -- The master was not found even though the unit was labeled as + -- having one. + + raise Program_Error; + end; -- Create a new anonymous master @@ -462,6 +475,7 @@ package body Exp_Ch4 is declare First_Decl : constant Node_Id := First (Decls); Action : Node_Id; + Fin_Mas_Id : Entity_Id; begin -- Since the master and its associated initialization is inserted diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 75746422125..5df20678f1d 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -111,13 +111,15 @@ package body Exp_Ch6 is -- Extra_Formal in Subprogram_Call. procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id : Entity_Id; - Ptr_Typ : Entity_Id := Empty); + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp : Node_Id := Empty); -- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs -- finalization actions, add an actual parameter which is a pointer to the - -- finalization master of the caller. If Ptr_Typ is left Empty, this will - -- result in an automatic "null" value for the actual. + -- finalization master of the caller. If Master_Exp is not Empty, then that + -- will be passed as the actual. Otherwise, if Ptr_Typ is left Empty, this + -- will result in an automatic "null" value for the actual. procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; @@ -311,9 +313,10 @@ package body Exp_Ch6 is ----------------------------------------------------------- procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call : Node_Id; - Func_Id : Entity_Id; - Ptr_Typ : Entity_Id := Empty) + (Func_Call : Node_Id; + Func_Id : Entity_Id; + Ptr_Typ : Entity_Id := Empty; + Master_Exp : Node_Id := Empty) is begin if not Needs_BIP_Finalization_Master (Func_Id) then @@ -329,9 +332,16 @@ package body Exp_Ch6 is Desig_Typ : Entity_Id; begin + -- If there is a finalization master actual, such as the implicit + -- finalization master of an enclosing build-in-place function, + -- then this must be added as an extra actual of the call. + + if Present (Master_Exp) then + Actual := Master_Exp; + -- Case where the context does not require an actual master - if No (Ptr_Typ) then + elsif No (Ptr_Typ) then Actual := Make_Null (Loc); else @@ -7561,7 +7571,9 @@ package body Exp_Ch6 is Ptr_Typ_Decl : Node_Id; Def_Id : Entity_Id; New_Expr : Node_Id; - Enclosing_Func : Entity_Id; + Enclosing_Func : constant Entity_Id := + Enclosing_Subprogram (Obj_Def_Id); + Fmaster_Actual : Node_Id := Empty; Pass_Caller_Acc : Boolean := False; begin @@ -7613,8 +7625,6 @@ package body Exp_Ch6 is if Is_Return_Object (Defining_Identifier (Object_Decl)) then Pass_Caller_Acc := True; - Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); - -- When the enclosing function has a BIP_Alloc_Form formal then we -- pass it along to the callee (such as when the enclosing function -- has an unconstrained or tagged result type). @@ -7636,6 +7646,13 @@ package body Exp_Ch6 is (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); end if; + if Needs_BIP_Finalization_Master (Enclosing_Func) then + Fmaster_Actual := + New_Reference_To + (Build_In_Place_Formal + (Enclosing_Func, BIP_Finalization_Master), Loc); + end if; + -- Retrieve the BIPacc formal from the enclosing function and convert -- it to the access type of the callee's BIP_Object_Access formal. @@ -7686,14 +7703,18 @@ package body Exp_Ch6 is Establish_Transient_Scope (Object_Decl, Sec_Stack => True); end if; + -- Pass along any finalization master actual, which is needed in the + -- case where the called function initializes a return object of an + -- enclosing build-in-place function. + Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); + (Func_Call => Func_Call, + Func_Id => Function_Id, + Master_Exp => Fmaster_Actual); if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement and then Has_Task (Result_Subt) then - Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id); - -- Here we're passing along the master that was passed in to this -- function. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 65311f8eec3..736d3d03db7 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3901,7 +3901,6 @@ package body Exp_Util is begin Change := True; Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl)); - while Change loop Change := False; @@ -3971,7 +3970,6 @@ package body Exp_Util is function Is_Allocated (Trans_Id : Entity_Id) return Boolean is Expr : constant Node_Id := Expression (Parent (Trans_Id)); - begin return Is_Access_Type (Etype (Trans_Id)) @@ -3994,30 +3992,30 @@ package body Exp_Util is and then Requires_Transient_Scope (Desig) and then Nkind (Rel_Node) /= N_Simple_Return_Statement - -- Do not consider renamed or 'reference-d transient objects because - -- the act of renaming extends the object's lifetime. + -- Do not consider renamed or 'reference-d transient objects because + -- the act of renaming extends the object's lifetime. and then not Is_Aliased (Obj_Id, Decl) - -- Do not consider transient objects allocated on the heap since they - -- are attached to a finalization master. + -- Do not consider transient objects allocated on the heap since + -- they are attached to a finalization master. and then not Is_Allocated (Obj_Id) - -- If the transient object is a pointer, check that it is not - -- initialized by a function which returns a pointer or acts as a - -- renaming of another pointer. + -- If the transient object is a pointer, check that it is not + -- initialized by a function which returns a pointer or acts as a + -- renaming of another pointer. and then (not Is_Access_Type (Obj_Typ) or else not Initialized_By_Access (Obj_Id)) - -- Do not consider transient objects which act as indirect aliases of - -- build-in-place function results. + -- Do not consider transient objects which act as indirect aliases + -- of build-in-place function results. and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) - -- Do not consider conversions of tags to class-wide types + -- Do not consider conversions of tags to class-wide types and then not Is_Tag_To_CW_Conversion (Obj_Id); end Is_Finalizable_Transient; @@ -4200,8 +4198,7 @@ package body Exp_Util is begin -- If component reference is for an array with non-static bounds, -- then it is always aligned: we can only process unaligned arrays - -- with static bounds (more accurately bounds known at compile - -- time). + -- with static bounds (more precisely compile time known bounds). if Is_Array_Type (T) and then not Compile_Time_Known_Bounds (T) @@ -4262,6 +4259,8 @@ package body Exp_Util is -- alignment, and we either know it is too small, or cannot tell, -- then the component may be unaligned. + -- What is the following commented out code ??? + -- if Known_Alignment (Etype (P)) -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment -- and then M > Alignment (Etype (P)) diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index cce88b9daed..28c9d9812e4 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -3291,6 +3291,7 @@ package body GNAT.Command_Line is with "Expected integer parameter for '" & Switch & "'"; end; + return; when Switch_String => diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index f19d7baea5b..893a674ce18 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -707,9 +707,9 @@ package GNAT.Command_Line is Callback : Switch_Handler := null; Parser : Opt_Parser := Command_Line_Parser; Concatenate : Boolean := True); - -- Similar to the standard Getopt function. - -- For each switch found on the command line, this calls Callback, if the - -- switch is not handled automatically. + -- Similar to the standard Getopt function. For each switch found on the + -- command line, this calls Callback, if the switch is not handled + -- automatically. -- -- The list of valid switches are the ones from the configuration. The -- switches that were declared through Define_Switch with an Output @@ -726,12 +726,15 @@ package GNAT.Command_Line is -- will display an error message and raises Invalid_Switch again. -- -- This function automatically expands switches: - -- * If Define_Prefix was called (for instance "-gnaty") and the user - -- specifies "-gnatycb" on the command line, then Getopt returns - -- "-gnatyc" and "-gnatyb" separately. - -- * If Define_Alias was called (for instance "-gnatya = -gnatycb") then - -- the latter is returned (in this case it also expands -gnaty as per - -- the above. + -- + -- If Define_Prefix was called (for instance "-gnaty") and the user + -- specifies "-gnatycb" on the command line, then Getopt returns + -- "-gnatyc" and "-gnatyb" separately. + -- + -- If Define_Alias was called (for instance "-gnatya = -gnatycb") then + -- the latter is returned (in this case it also expands -gnaty as per + -- the above. + -- -- The goal is to make handling as easy as possible by leaving as much -- work as possible to this package. -- @@ -753,15 +756,17 @@ package GNAT.Command_Line is -- way to remove a switch from an existing command line. -- For instance: + -- declare -- Config : Command_Line_Configuration; -- Line : Command_Line; -- Args : Argument_List_Access; + -- begin -- Define_Switch (Config, "-gnatyc"); -- Define_Switch (Config, ...); -- for all valid switches -- Define_Prefix (Config, "-gnaty"); - -- + -- Set_Configuration (Line, Config); -- Add_Switch (Line, "-O2"); -- Add_Switch (Line, "-gnatyc"); diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 8a29818f37c..74d1421b915 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -457,7 +457,7 @@ package body Alfa is -- the entity definition. elsif Get_Scope_Num (T1.Key.Ent_Scope) /= - Get_Scope_Num (T2.Key.Ent_Scope) + Get_Scope_Num (T2.Key.Ent_Scope) then return Get_Scope_Num (T1.Key.Ent_Scope) < Get_Scope_Num (T2.Key.Ent_Scope); @@ -503,7 +503,7 @@ package body Alfa is -- Seventh test: for same entity, sort by reference location scope elsif Get_Scope_Num (T1.Key.Ref_Scope) /= - Get_Scope_Num (T2.Key.Ref_Scope) + Get_Scope_Num (T2.Key.Ref_Scope) then return Get_Scope_Num (T1.Key.Ref_Scope) < Get_Scope_Num (T2.Key.Ref_Scope); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 2dbf5ff23d2..15edfb6c57b 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -205,7 +205,7 @@ package body Lib.Xref is function Equal (F1, F2 : Xref_Entry_Number) return Boolean is Result : constant Boolean := - Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; + Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; begin return Result; end Equal; @@ -373,12 +373,12 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Nod : Node_Id; - Ref : Source_Ptr; - Def : Source_Ptr; - Ent : Entity_Id; + Nod : Node_Id; + Ref : Source_Ptr; + Def : Source_Ptr; + Ent : Entity_Id; - Actual_Typ : Character := Typ; + Actual_Typ : Character := Typ; Ref_Scope : Entity_Id; Ent_Scope : Entity_Id; @@ -1882,10 +1882,10 @@ package body Lib.Xref is if XE.Key.Typ = 'e' and then Ent /= Curent - and then (Refno = Nrefs or else - Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) - and then - not In_Extended_Main_Source_Unit (Ent) + and then (Refno = Nrefs + or else + Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) + and then not In_Extended_Main_Source_Unit (Ent) then goto Continue; end if; diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 68a4ac30d04..7b5ee031339 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -195,16 +195,16 @@ package body System.HTable is ------------------------ function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is - K : constant Key := Get_Key (E); + K : constant Key := Get_Key (E); Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr := Table (Index); + Elmt : Elmt_Ptr; begin + Elmt := Table (Index); loop if Elmt = Null_Ptr then Set_Next (E, Table (Index)); Table (Index) := E; - return True; elsif Equal (Get_Key (Elmt), K) then diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 69963e44501..43ae847921c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8892,8 +8892,8 @@ package body Sem_Attr is LB := Make_Attribute_Reference (Loc, Prefix => P, - Attribute_Name => Name_First, - Expressions => (Dims)); + Attribute_Name => Name_First, + Expressions => (Dims)); -- Do not share the dimension indicator, if present. Even -- though it is a static constant, its source location diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a0f0a798858..87334e43ff8 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2537,7 +2537,7 @@ package body Sem_Ch10 is Change_Selected_Component_To_Expanded_Name (Name (N)); - -- If this is a child unit without a spec, and it has benn analyzed + -- If this is a child unit without a spec, and it has been analyzed -- already, a declaration has been created for it. The with_clause -- must reflect the actual body, and not the generated declaration, -- to prevent spurious binding errors involving an out-of-date spec. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 91e30e65d39..aedc29f705f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15691,20 +15691,30 @@ package body Sem_Ch3 is ------------------------ procedure Set_Anonymous_Type (Id : Entity_Id) is - Typ : constant Entity_Id := Etype (Old_C); + Old_Typ : constant Entity_Id := Etype (Old_C); begin if Scope (Parent_Base) = Scope (Derived_Base) then - Set_Etype (Id, Typ); + Set_Etype (Id, Old_Typ); -- The parent and the derived type are in two different scopes. -- Reuse the type of the original discriminant / component by - -- copying it in order to preserve all attributes and update the - -- scope. + -- copying it in order to preserve all attributes. else - Set_Etype (Id, New_Copy (Typ)); - Set_Scope (Etype (Id), Current_Scope); + declare + Typ : constant Entity_Id := New_Copy (Old_Typ); + + begin + Set_Etype (Id, Typ); + + -- Since we do not generate component declarations for + -- inherited components, associate the itype with the + -- derived type. + + Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base)); + Set_Scope (Typ, Derived_Base); + end; end if; end Set_Anonymous_Type; -- 2.30.2