From: Arnaud Charlet Date: Fri, 18 Jul 2014 11:02:42 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: upstream/12.2.0~61920 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=4ac2bbbd057159e44cbe8d035eb0b6fc536bc40c;p=platform%2Fupstream%2Fgcc.git [multiple changes] 2014-07-18 Hristian Kirtchev * einfo.adb Last_Aggregate_Assignment is now Node 30. (Last_Aggregate_Assignment): Include constants in the assertion. Update the underlying node. (Set_Last_Aggregate_Assignment): Include constants in the assertion. Update the underlying node. (Write_Field11_Name): Remove the entry for Last_Aggregate_Assignment. (Write_Field30_Name): Add an entry for Last_Aggregate_Assignment. * einfo.ads Update the node designation and usage of attribute Last_Aggregate_Assignment. * exp_aggr.adb (Expand_Array_Aggregate): Store the last assignment statement used to initialize a controlled object. (Late_Expansion): Store the last assignment statement used to initialize a controlled record or an array of controlled objects. * exp_ch3.adb (Expand_N_Object_Declaration): Default initialization of objects is now performed in a separate routine. (Default_Initialize_Object): New routine. * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter Obj_Id. Update the comment on usage. (Find_Last_Init): Remove formal parameter Typ. Update comment on usage. Reimplement the logic. (Find_Last_Init_In_Block): New routine. (Is_Init_Call): Add formal parameter Init_Typ. Update the comment on usage. Account for the type init proc when trying to determine whether a statement is an initialization call. (Make_Adjust_Call): Rename formal parameter For_Parent to Skip_Self. Update all occurrences of For_Parent. Account for non-tagged types. Update the call to Make_Call. (Make_Call): Rename formal parameter For_Parent to Skip_Self. Update comment on usage. Update all occurrences of For_Parent. (Make_Final_Call): Rename formal parameter For_Parent to Skip_Self. Update all occurrences of For_Parent. Account for non-tagged types. Update the call to Make_Call. (Process_Object_Declaration): Most variables and constants are now local to the routine. * exp_ch7.ads (Make_Adjust_Call): Rename formal parameter For_Parent to Skip_Self. Update the comment on usage. (Make_Final_Call): Rename formal parameter For_Parent to Skip_Self. Update the comment on usage. 2014-07-18 Ed Schonberg * sem_ch9.adb (Analyze_Requeue): The entry being referenced can be a procedure that is implemented by entry, and have a formal that is a synchronized interface. It does not have to be declared as a protected operation. From-SVN: r212814 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 49cbaec..ac04798 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2014-07-18 Hristian Kirtchev + + * einfo.adb Last_Aggregate_Assignment is now Node 30. + (Last_Aggregate_Assignment): Include + constants in the assertion. Update the underlying node. + (Set_Last_Aggregate_Assignment): Include constants in the + assertion. Update the underlying node. (Write_Field11_Name): + Remove the entry for Last_Aggregate_Assignment. + (Write_Field30_Name): Add an entry for Last_Aggregate_Assignment. + * einfo.ads Update the node designation and usage of attribute + Last_Aggregate_Assignment. + * exp_aggr.adb (Expand_Array_Aggregate): Store the last + assignment statement used to initialize a controlled object. + (Late_Expansion): Store the last assignment statement used to + initialize a controlled record or an array of controlled objects. + * exp_ch3.adb (Expand_N_Object_Declaration): Default + initialization of objects is now performed in a separate routine. + (Default_Initialize_Object): New routine. + * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter + Obj_Id. Update the comment on usage. + (Find_Last_Init): Remove formal parameter Typ. Update comment on usage. + Reimplement the logic. (Find_Last_Init_In_Block): New routine. + (Is_Init_Call): Add formal parameter Init_Typ. Update the + comment on usage. Account for the type init proc when trying + to determine whether a statement is an initialization call. + (Make_Adjust_Call): Rename formal parameter For_Parent to + Skip_Self. Update all occurrences of For_Parent. Account for + non-tagged types. Update the call to Make_Call. + (Make_Call): Rename formal parameter For_Parent to Skip_Self. Update + comment on usage. Update all occurrences of For_Parent. + (Make_Final_Call): Rename formal parameter For_Parent to + Skip_Self. Update all occurrences of For_Parent. Account + for non-tagged types. Update the call to Make_Call. + (Process_Object_Declaration): Most variables and constants are + now local to the routine. + * exp_ch7.ads (Make_Adjust_Call): Rename formal parameter + For_Parent to Skip_Self. Update the comment on usage. + (Make_Final_Call): Rename formal parameter For_Parent to + Skip_Self. Update the comment on usage. + +2014-07-18 Ed Schonberg + + * sem_ch9.adb (Analyze_Requeue): The entry being referenced + can be a procedure that is implemented by entry, and have a + formal that is a synchronized interface. It does not have to + be declared as a protected operation. + 2014-07-18 Robert Dewar * gnat_rm.texi: Remove mention of obsolete attributes diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index dbefc1a..634d92a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -101,7 +101,6 @@ package body Einfo is -- Entry_Component Node11 -- Enumeration_Pos Uint11 -- Generic_Homonym Node11 - -- Last_Aggregate_Assignment Node11 -- Protected_Body_Subprogram Node11 -- Block_Node Node11 @@ -246,6 +245,7 @@ package body Einfo is -- Subprograms_For_Type Node29 -- Corresponding_Equality Node30 + -- Last_Aggregate_Assignment Node30 -- Static_Initialization Node30 -- Thunk_Entity Node31 @@ -2433,8 +2433,8 @@ package body Einfo is function Last_Aggregate_Assignment (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Variable); - return Node11 (Id); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + return Node30 (Id); end Last_Aggregate_Assignment; function Last_Assignment (Id : E) return N is @@ -5195,8 +5195,8 @@ package body Einfo is procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is begin - pragma Assert (Ekind (Id) = E_Variable); - Set_Node11 (Id, V); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + Set_Node30 (Id, V); end Set_Last_Aggregate_Assignment; procedure Set_Last_Assignment (Id : E; V : N) is @@ -8727,9 +8727,6 @@ package body Einfo is when E_Generic_Package => Write_Str ("Generic_Homonym"); - when E_Variable => - Write_Str ("Last_Aggregate_Assignment"); - when E_Function | E_Procedure | E_Entry | @@ -9526,6 +9523,10 @@ package body Einfo is when E_Function => Write_Str ("Corresponding_Equality"); + when E_Constant | + E_Variable => + Write_Str ("Last_Aggregate_Assignment"); + when E_Procedure => Write_Str ("Static_Initialization"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index fb55d1b..3422ac0 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3068,11 +3068,11 @@ package Einfo is -- initialization, it may or may not be set if the type does have -- preelaborable initialization. --- Last_Aggregate_Assignment (Node11) --- Applies to controlled variables initialized by an aggregate. Points to --- the last statement associated with the expansion of the aggregate. The --- attribute is used by the finalization machinery when marking an object --- as successfully initialized. +-- Last_Aggregate_Assignment (Node30) +-- Applies to controlled constants and variables initialized by an +-- aggregate. Points to the last statement associated with the expansion +-- of the aggregate. The attribute is used by the finalization machinery +-- when marking an object as successfully initialized. -- Last_Assignment (Node26) -- Defined in entities for variables, and OUT or IN OUT formals. Set for @@ -5412,6 +5412,7 @@ package Einfo is -- Related_Type (Node27) (constants only) -- Initialization_Statements (Node28) -- BIP_Initialization_Call (Node29) + -- Last_Aggregate_Assignment (Node30) -- Linker_Section_Pragma (Node33) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) @@ -6102,7 +6103,6 @@ package Einfo is -- Hiding_Loop_Variable (Node8) -- Current_Value (Node9) -- Encapsulating_State (Node10) - -- Last_Aggregate_Assignment (Node11) -- Esize (Uint12) -- Extra_Accessibility (Node13) -- Alignment (Uint14) @@ -6121,6 +6121,7 @@ package Einfo is -- Related_Type (Node27) -- Initialization_Statements (Node28) -- BIP_Initialization_Call (Node29) + -- Last_Aggregate_Assignment (Node30) -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Has_Alignment_Clause (Flag46) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3c2101f..de784b2 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -75,6 +75,15 @@ package body Exp_Aggr is type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure + procedure Collect_Initialization_Statements + (Obj : Entity_Id; + N : Node_Id; + Node_After : Node_Id); + -- If Obj is not frozen, collect actions inserted after N until, but not + -- including, Node_After, for initialization of Obj, and move them to an + -- expression with actions, which becomes the Initialization_Statements for + -- Obj. + function Has_Default_Init_Comps (N : Node_Id) return Boolean; -- N is an aggregate (record or array). Checks the presence of default -- initialization (<>) in any component (Ada 2005: AI-287). @@ -103,15 +112,6 @@ package body Exp_Aggr is -- statement of variant part will usually be small and probably in near -- sorted order. - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id); - -- If Obj is not frozen, collect actions inserted after N until, but not - -- including, Node_After, for initialization of Obj, and move them to an - -- expression with actions, which becomes the Initialization_Statements for - -- Obj. - ------------------------------------------------------ -- Local subprograms for Record Aggregate Expansion -- ------------------------------------------------------ @@ -5233,6 +5233,19 @@ package body Exp_Aggr is Index => First_Index (Typ), Into => Target, Scalar_Comp => Is_Scalar_Type (Ctyp)); + + -- Save the last assignment statement associated with the aggregate + -- when building a controlled object. This reference is utilized by + -- the finalization machinery when marking an object as successfully + -- initialized. + + if Needs_Finalization (Typ) + and then Is_Entity_Name (Target) + and then Present (Entity (Target)) + and then Ekind_In (Entity (Target), E_Constant, E_Variable) + then + Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); + end if; end; -- If the aggregate is the expression in a declaration, the expanded @@ -6210,23 +6223,8 @@ package body Exp_Aggr is if Is_Record_Type (Etype (N)) then Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target); - -- Save the last assignment statement associated with the aggregate - -- when building a controlled object. This reference is utilized by - -- the finalization machinery when marking an object as successfully - -- initialized. - - if Needs_Finalization (Typ) - and then Is_Entity_Name (Target) - and then Present (Entity (Target)) - and then Ekind (Entity (Target)) = E_Variable - then - Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); - end if; - - return Aggr_Code; - else pragma Assert (Is_Array_Type (Etype (N))); - return + Aggr_Code := Build_Array_Aggr_Code (N => N, Ctype => Component_Type (Etype (N)), @@ -6235,6 +6233,21 @@ package body Exp_Aggr is Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)), Indexes => No_List); end if; + + -- Save the last assignment statement associated with the aggregate + -- when building a controlled object. This reference is utilized by + -- the finalization machinery when marking an object as successfully + -- initialized. + + if Needs_Finalization (Typ) + and then Is_Entity_Name (Target) + and then Present (Entity (Target)) + and then Ekind_In (Entity (Target), E_Constant, E_Variable) + then + Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code)); + end if; + + return Aggr_Code; end Late_Expansion; ---------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b24a204..160cfea 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2623,9 +2623,8 @@ package body Exp_Ch3 is Statements => New_List ( Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (Local_DF_Id, Loc), - Parameter_Associations => New_List ( Make_Identifier (Loc, Name_uInit), New_Occurrence_Of (Standard_False, Loc))), @@ -4857,20 +4856,16 @@ package body Exp_Ch3 is Typ : constant Entity_Id := Etype (Def_Id); Base_Typ : constant Entity_Id := Base_Type (Typ); Expr_Q : Node_Id; - Id_Ref : Node_Id; - New_Ref : Node_Id; - - Init_After : Node_Id := N; - -- Node after which the init proc call is to be inserted. This is - -- normally N, except for the case of a shared passive variable, in - -- which case the init proc call must be inserted only after the bodies - -- of the shared variable procedures have been seen. function Build_Equivalent_Aggregate return Boolean; -- If the object has a constrained discriminated type and no initial -- value, it may be possible to build an equivalent aggregate instead, -- and prevent an actual call to the initialization procedure. + procedure Default_Initialize_Object (After : Node_Id); + -- Generate all default initialization actions for object Def_Id. Any + -- new code is inserted after node After. + function Rewrite_As_Renaming return Boolean; -- Indicate whether to rewrite a declaration with initialization into an -- object renaming declaration (see below). @@ -4911,11 +4906,10 @@ package body Exp_Ch3 is end if; if Ekind (Current_Scope) = E_Package - and then - (Restriction_Active (No_Elaboration_Code) - or else Is_Preelaborated (Current_Scope)) + and then + (Restriction_Active (No_Elaboration_Code) + or else Is_Preelaborated (Current_Scope)) then - -- Building a static aggregate is possible if the discriminants -- have static values and the other components have static -- defaults or none. @@ -5005,6 +4999,263 @@ package body Exp_Ch3 is end if; end Build_Equivalent_Aggregate; + ------------------------------- + -- Default_Initialize_Object -- + ------------------------------- + + procedure Default_Initialize_Object (After : Node_Id) is + function New_Object_Reference return Node_Id; + -- Return a new reference to Def_Id with attributes Assignment_OK and + -- Must_Not_Freeze already set. + + -------------------------- + -- New_Object_Reference -- + -------------------------- + + function New_Object_Reference return Node_Id is + Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); + + begin + -- The call to the type init proc or [Deep_]Finalize must not + -- freeze the related object as the call is internally generated. + -- This way legal rep clauses that apply to the object will not be + -- flagged. Note that the initialization call may be removed if + -- pragma Import is encountered or moved to the freeze actions of + -- the object because of an address clause. + + Set_Assignment_OK (Obj_Ref); + Set_Must_Not_Freeze (Obj_Ref); + + return Obj_Ref; + end New_Object_Reference; + + -- Local variables + + Abrt_HSS : Node_Id; + Abrt_Id : Entity_Id; + Abrt_Stmts : List_Id; + Aggr_Init : Node_Id; + Comp_Init : List_Id := No_List; + Fin_Call : Node_Id; + Fin_Stmts : List_Id := No_List; + Obj_Init : Node_Id := Empty; + Obj_Ref : Node_Id; + + -- Start of processing for Default_Initialize_Object + + begin + -- Step 1: Initialize the object + + if Needs_Finalization (Typ) and then not No_Initialization (N) then + Obj_Init := + Make_Init_Call + (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Typ); + end if; + + -- Step 2: Initialize the components of the object + + -- Do not initialize the components if their initialization is + -- prohibited or the type represents a value type in a .NET VM. + + if Has_Non_Null_Base_Init_Proc (Typ) + and then not No_Initialization (N) + and then not Initialization_Suppressed (Typ) + and then not Is_Value_Type (Typ) + then + -- Do not initialize the components if No_Default_Initialization + -- applies as the the actual restriction check will occur later + -- when the object is frozen as it is not known yet whether the + -- object is imported or not. + + if not Restriction_Active (No_Default_Initialization) then + + -- If the values of the components are compile-time known, use + -- their prebuilt aggregate form directly. + + Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); + + if Present (Aggr_Init) then + Set_Expression + (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); + + -- If type has discriminants, try to build an equivalent + -- aggregate using discriminant values from the declaration. + -- This is a useful optimization, in particular if restriction + -- No_Elaboration_Code is active. + + elsif Build_Equivalent_Aggregate then + null; + + -- Otherwise invoke the type init proc + + else + Obj_Ref := New_Object_Reference; + + if Comes_From_Source (Def_Id) then + Initialization_Warning (Obj_Ref); + end if; + + Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); + end if; + end if; + + -- Provide a default value if the object needs simple initialization + -- and does not already have an initial value. A generated temporary + -- do not require initialization because it will be assigned later. + + elsif Needs_Simple_Initialization + (Typ, Initialize_Scalars + and then not Has_Following_Address_Clause (N)) + and then not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) + then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); + Analyze_And_Resolve (Expression (N), Typ); + end if; + + -- Step 3: Add partial finalization and abort actions, generate: + + -- Type_Init_Proc (Obj); + -- begin + -- Deep_Initialize (Obj); + -- exception + -- when others => + -- Deep_Finalize (Obj, Self => False); + -- raise; + -- end; + + -- Step 3a: Build the finalization block (if applicable) + + -- The finalization block is required when both the object and its + -- controlled components are to be initialized. The block finalizes + -- the components if the object initialization fails. + + if Has_Controlled_Component (Typ) + and then Present (Comp_Init) + and then Present (Obj_Init) + and then not Restriction_Active (No_Exception_Propagation) + then + -- Generate: + -- Type_Init_Proc (Obj); + + Fin_Stmts := Comp_Init; + + -- Generate: + -- begin + -- Deep_Initialize (Obj); + -- exception + -- when others => + -- Deep_Finalize (Obj, Self => False); + -- raise; + -- end; + + Fin_Call := + Make_Final_Call + (Obj_Ref => New_Object_Reference, + Typ => Typ, + Skip_Self => True); + + if Present (Fin_Call) then + + -- Do not emit warnings related to the elaboration order when a + -- controlled object is declared before the body of Finalize is + -- seen. + + Set_No_Elaboration_Check (Fin_Call); + + Append_To (Fin_Stmts, + Make_Block_Statement (Loc, + Declarations => No_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Obj_Init), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Fin_Call, + Make_Raise_Statement (Loc))))))); + end if; + + -- Finalization is not required, the initialization calls are passed + -- to the abort block building circuitry, generate: + + -- Type_Init_Proc (Obj); + -- Deep_Initialize (Obj); + + else + if Present (Comp_Init) then + Fin_Stmts := Comp_Init; + end if; + + if Present (Obj_Init) then + if No (Fin_Stmts) then + Fin_Stmts := New_List; + end if; + + Append_To (Fin_Stmts, Obj_Init); + end if; + end if; + + -- Step 3b: Build the abort block (if applicable) + + -- The abort block is required when aborts are allowed and there is + -- at least one initialization call that needs protection. + + if Abort_Allowed + and then Present (Comp_Init) + and then Present (Obj_Init) + then + -- Generate: + -- Abort_Defer; + + Prepend_To (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + + -- Generate: + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; + + Abrt_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Set_Etype (Abrt_Id, Standard_Void_Type); + Set_Scope (Abrt_Id, Current_Scope); + + Abrt_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + + Abrt_Stmts := New_List ( + Make_Block_Statement (Loc, + Identifier => New_Occurrence_Of (Abrt_Id, Loc), + Declarations => No_List, + Handled_Statement_Sequence => Abrt_HSS)); + + Expand_At_End_Handler (Abrt_HSS, Abrt_Id); + + -- Abort is not required, the construct from Step 3a is to be added + -- in the tree (either finalization block or single initialization + -- call). + + else + Abrt_Stmts := Fin_Stmts; + end if; + + -- Step 4: Insert the whole initialization sequence into the tree + + Insert_Actions_After (After, Abrt_Stmts); + end Default_Initialize_Object; + ------------------------- -- Rewrite_As_Renaming -- ------------------------- @@ -5018,6 +5269,17 @@ package body Exp_Ch3 is and then Is_Entity_Name (Obj_Def); end Rewrite_As_Renaming; + -- Local variables + + Id_Ref : Node_Id; + New_Ref : Node_Id; + + Init_After : Node_Id := N; + -- Node after which the initialization actions are to be inserted. This + -- is normally N, except for the case of a shared passive variable, in + -- which case the init proc call must be inserted only after the bodies + -- of the shared variable procedures have been seen. + -- Start of processing for Expand_N_Object_Declaration begin @@ -5118,153 +5380,7 @@ package body Exp_Ch3 is Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); end if; - -- Expand Initialize call for controlled objects. One may wonder why - -- the Initialize Call is not done in the regular Init procedure - -- attached to the record type. That's because the init procedure is - -- recursively called on each component, including _Parent, thus the - -- Init call for a controlled object would generate not only one - -- Initialize call as it is required but one for each ancestor of - -- its type. This processing is suppressed if No_Initialization set. - - if not Needs_Finalization (Typ) or else No_Initialization (N) then - null; - - elsif not Abort_Allowed or else not Comes_From_Source (N) then - Insert_Action_After (Init_After, - Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Typ)); - - -- Abort allowed - - else - -- We need to protect the initialize call - - -- begin - -- Defer_Abort.all; - -- Initialize (...); - -- at end - -- Undefer_Abort.all; - -- end; - - -- ??? this won't protect the initialize call for controlled - -- components which are part of the init proc, so this block - -- should probably also contain the call to _init_proc but this - -- requires some code reorganization... - - declare - L : constant List_Id := New_List ( - Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Typ)); - - Blk : constant Node_Id := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, L)); - - begin - Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); - Set_At_End_Proc (Handled_Statement_Sequence (Blk), - New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); - Insert_Actions_After (Init_After, New_List (Blk)); - Expand_At_End_Handler - (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); - end; - end if; - - -- Call type initialization procedure if there is one. We build the - -- call and put it immediately after the object declaration, so that - -- it will be expanded in the usual manner. Note that this will - -- result in proper handling of defaulted discriminants. - - -- Need call if there is a base init proc - - if Has_Non_Null_Base_Init_Proc (Typ) - - -- Suppress call if No_Initialization set on declaration - - and then not No_Initialization (N) - - -- Suppress call for special case of value type for VM - - and then not Is_Value_Type (Typ) - - -- Suppress call if initialization suppressed for the type - - and then not Initialization_Suppressed (Typ) - then - -- Return without initializing when No_Default_Initialization - -- applies. Note that the actual restriction check occurs later, - -- when the object is frozen, because we don't know yet whether - -- the object is imported, which is a case where the check does - -- not apply. - - if Restriction_Active (No_Default_Initialization) then - return; - end if; - - -- The call to the initialization procedure does NOT freeze the - -- object being initialized. This is because the call is not a - -- source level call. This works fine, because the only possible - -- statements depending on freeze status that can appear after the - -- Init_Proc call are rep clauses which can safely appear after - -- actual references to the object. Note that this call may - -- subsequently be removed (if a pragma Import is encountered), - -- or moved to the freeze actions for the object (e.g. if an - -- address clause is applied to the object, causing it to get - -- delayed freezing). - - Id_Ref := New_Occurrence_Of (Def_Id, Loc); - Set_Must_Not_Freeze (Id_Ref); - Set_Assignment_OK (Id_Ref); - - declare - Init_Expr : constant Node_Id := - Static_Initialization (Base_Init_Proc (Typ)); - - begin - if Present (Init_Expr) then - Set_Expression - (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); - return; - - -- If type has discriminants, try to build equivalent aggregate - -- using discriminant values from the declaration. This - -- is a useful optimization, in particular if restriction - -- No_Elaboration_Code is active. - - elsif Build_Equivalent_Aggregate then - return; - - else - Initialization_Warning (Id_Ref); - - Insert_Actions_After (Init_After, - Build_Initialization_Call (Loc, Id_Ref, Typ)); - end if; - end; - - -- If simple initialization is required, then set an appropriate - -- simple initialization expression in place. This special - -- initialization is required even though No_Init_Flag is present, - -- but is not needed if there was an explicit initialization. - - -- An internally generated temporary needs no initialization because - -- it will be assigned subsequently. In particular, there is no point - -- in applying Initialize_Scalars to such a temporary. - - elsif Needs_Simple_Initialization - (Typ, - Initialize_Scalars - and then not Has_Following_Address_Clause (N)) - and then not Is_Internal (Def_Id) - and then not Has_Init_Expression (N) - then - Set_No_Initialization (N, False); - Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); - Analyze_And_Resolve (Expression (N), Typ); - end if; + Default_Initialize_Object (Init_After); -- Generate attribute for Persistent_BSS if needed @@ -7971,8 +8087,8 @@ package body Exp_Ch3 is if Warning_Needed then Error_Msg_N - ("Objects of the type cannot be initialized " - & "statically by default??", Parent (E)); + ("Objects of the type cannot be initialized statically " + & "by default??", Parent (E)); end if; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index b98362f..c6bec4b 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -380,14 +380,14 @@ package body Exp_Ch7 is -- Initial_Condition. N denotes the package spec or body. function Make_Call - (Loc : Source_Ptr; - Proc_Id : Entity_Id; - Param : Node_Id; - For_Parent : Boolean := False) return Node_Id; + (Loc : Source_Ptr; + Proc_Id : Entity_Id; + Param : Node_Id; + Skip_Self : Boolean := False) return Node_Id; -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of - -- routine [Deep_]Adjust / Finalize and an object parameter, create an - -- adjust / finalization call. Flag For_Parent should be set when field - -- _parent is being processed. + -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create + -- an adjust or finalization call. Wnen flag Skip_Self is set, the related + -- action has an effect on the components only (if any). function Make_Deep_Proc (Prim : Final_Primitives; @@ -2066,22 +2066,13 @@ package body Exp_Ch7 is Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Loc : constant Source_Ptr := Sloc (Decl); - Body_Ins : Node_Id; - Count_Ins : Node_Id; - Fin_Call : Node_Id; - Fin_Stmts : List_Id; - Inc_Decl : Node_Id; - Label : Node_Id; - Label_Id : Entity_Id; - Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; + Loc : constant Source_Ptr := Sloc (Decl); - function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; - -- Once it has been established that the current object is in fact a - -- return object of build-in-place function Func_Id, generate the - -- following cleanup code: + function Build_BIP_Cleanup_Stmts + (Func_Id : Entity_Id; + Obj_Id : Entity_Id) return Node_Id; + -- Func_Id denotes a build-in-place function. Obj_Id is the return + -- object of Func_Id. Generate the following cleanup code: -- -- if BIPallocfrom > Secondary_Stack'Pos -- and then BIPfinalizationmaster /= null @@ -2100,21 +2091,20 @@ package body Exp_Ch7 is procedure Find_Last_Init (Decl : Node_Id; - Typ : Entity_Id; Last_Init : out Node_Id; Body_Insert : out Node_Id); - -- An object declaration has at least one and at most two init calls: - -- that of the type and the user-defined initialize. Given an object - -- declaration, Last_Init denotes the last initialization call which - -- follows the declaration. Body_Insert denotes the place where the - -- finalizer body could be potentially inserted. + -- Find the last initialization call related to object declaration + -- Decl. Last_Init denotes the last initialization call which follows + -- Decl. Body_Insert denotes the finalizer body could be potentially + -- inserted. ----------------------------- -- Build_BIP_Cleanup_Stmts -- ----------------------------- function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id) return Node_Id + (Func_Id : Entity_Id; + Obj_Id : Entity_Id) return Node_Id is Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := @@ -2255,58 +2245,109 @@ package body Exp_Ch7 is procedure Find_Last_Init (Decl : Node_Id; - Typ : Entity_Id; Last_Init : out Node_Id; Body_Insert : out Node_Id) is + function Find_Last_Init_In_Block + (Blk : Node_Id; + Init_Typ : Entity_Id) return Node_Id; + -- Find the last initialization call within the statements of + -- block Blk. Init_Typ is type of the object being initialized. + function Is_Init_Call - (N : Node_Id; - Typ : Entity_Id) return Boolean; - -- Given an arbitrary node, determine whether N is a procedure - -- call and if it is, try to match the name of the call with the - -- [Deep_]Initialize proc of Typ. + (N : Node_Id; + Init_Typ : Entity_Id) return Boolean; + -- Determine whether node N denotes one of the initialization + -- procedures of type Init_Typ. function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; -- Given a statement which is part of a list, return the next - -- real statement while skipping over dynamic elab checks. + -- statement while skipping over dynamic elab checks. + + ----------------------------- + -- Find_Last_Init_In_Block -- + ----------------------------- + + function Find_Last_Init_In_Block + (Blk : Node_Id; + Init_Typ : Entity_Id) return Node_Id + is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + Stmt : Node_Id; + + begin + -- Examine the individual statements of the block in reverse to + -- locate the last initialization call. + + if Present (HSS) and then Present (Statements (HSS)) then + Stmt := Last (Statements (HSS)); + while Present (Stmt) loop + + -- Peek inside nested blocks in case aborts are allowed + + if Nkind (Stmt) = N_Block_Statement then + return Find_Last_Init_In_Block (Stmt, Init_Typ); + + elsif Is_Init_Call (Stmt, Init_Typ) then + return Stmt; + end if; + + Prev (Stmt); + end loop; + end if; + + return Empty; + end Find_Last_Init_In_Block; ------------------ -- Is_Init_Call -- ------------------ function Is_Init_Call - (N : Node_Id; - Typ : Entity_Id) return Boolean + (N : Node_Id; + Init_Typ : Entity_Id) return Boolean is - begin - -- A call to [Deep_]Initialize is always direct + Call_Id : Entity_Id; + Deep_Init : Entity_Id := Empty; + Prim_Init : Entity_Id := Empty; + Type_Init : Entity_Id := Empty; + begin if Nkind (N) = N_Procedure_Call_Statement and then Nkind (Name (N)) = N_Identifier then - declare - Call_Ent : constant Entity_Id := Entity (Name (N)); - Deep_Init : constant Entity_Id := - TSS (Typ, TSS_Deep_Initialize); - Init : Entity_Id := Empty; + Call_Id := Entity (Name (N)); - begin - -- A type may have controlled components but not be - -- controlled. + -- Obtain all possible initialization routines of the object + -- type and try to match the procedure call against one of + -- them. + + -- Deep_Initialize + + Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize); + + -- Primitive Initialize - if Is_Controlled (Typ) then - Init := Find_Prim_Op (Typ, Name_Initialize); + if Is_Controlled (Init_Typ) then + Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize); - if Present (Init) then - Init := Ultimate_Alias (Init); - end if; + if Present (Prim_Init) then + Prim_Init := Ultimate_Alias (Prim_Init); end if; + end if; - return - (Present (Deep_Init) and then Call_Ent = Deep_Init) - or else - (Present (Init) and then Call_Ent = Init); - end; + -- Type initialization routine + + if Has_Non_Null_Base_Init_Proc (Init_Typ) then + Type_Init := Base_Init_Proc (Init_Typ); + end if; + + return + (Present (Deep_Init) and then Call_Id = Deep_Init) + or else + (Present (Prim_Init) and then Call_Id = Prim_Init) + or else + (Present (Type_Init) and then Call_Id = Type_Init); end if; return False; @@ -2333,11 +2374,13 @@ package body Exp_Ch7 is -- Local variables - Obj_Id : constant Entity_Id := Defining_Entity (Decl); - Nod_1 : Node_Id := Empty; - Nod_2 : Node_Id := Empty; - Stmt : Node_Id; - Utyp : Entity_Id; + Obj_Id : constant Entity_Id := Defining_Entity (Decl); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + Call : Node_Id; + Init_Typ : Entity_Id := Obj_Typ; + Is_Conc : Boolean := False; + Stmt : Node_Id; + Stmt_2 : Node_Id; -- Start of processing for Find_Last_Init @@ -2346,24 +2389,42 @@ package body Exp_Ch7 is Body_Insert := Empty; -- Object renamings and objects associated with controlled - -- function results do not have initialization calls. + -- function results do not require initialization. if Has_No_Init then return; end if; - if Is_Concurrent_Type (Typ) then - Utyp := Corresponding_Record_Type (Typ); - else - Utyp := Typ; - end if; + -- Obtain the proper type of the object being initialized - if Is_Private_Type (Utyp) - and then Present (Full_View (Utyp)) - then - Utyp := Full_View (Utyp); + loop + if Is_Concurrent_Type (Init_Typ) + and then Present (Corresponding_Record_Type (Init_Typ)) + then + Is_Conc := True; + Init_Typ := Corresponding_Record_Type (Init_Typ); + + elsif Is_Private_Type (Init_Typ) + and then Present (Full_View (Init_Typ)) + then + Init_Typ := Full_View (Init_Typ); + + elsif Is_Untagged_Derivation (Init_Typ) + and then not Is_Conc + then + Init_Typ := Root_Type (Init_Typ); + + else + exit; + end if; + end loop; + + if Init_Typ /= Base_Type (Init_Typ) then + Init_Typ := Base_Type (Init_Typ); end if; + Stmt := Next_Suitable_Statement (Decl); + -- A limited controlled object initialized by a function call uses -- the build-in-place machinery to obtain its value. @@ -2381,11 +2442,10 @@ package body Exp_Ch7 is -- In this scenario the declaration of the temporary acts as the -- last initialization statement. - if Is_Limited_Type (Utyp) + if Is_Limited_Type (Init_Typ) and then Has_Init_Expression (Decl) and then No (Expression (Decl)) then - Stmt := Next (Decl); while Present (Stmt) loop if Nkind (Stmt) = N_Object_Declaration and then Present (Expression (Stmt)) @@ -2400,68 +2460,77 @@ package body Exp_Ch7 is Next (Stmt); end loop; - -- The init procedures are arranged as follows: - - -- Object : Controlled_Type; - -- Controlled_TypeIP (Object); - -- [[Deep_]Initialize (Object);] - - -- where the user-defined initialize may be optional or may appear - -- inside a block when abort deferral is needed. + -- In all other cases the initialization calls follow the related + -- object. The general structure of object initialization built by + -- routine Default_Initialize_Object is as follows: + + -- [begin -- aborts allowed + -- Abort_Defer;] + -- Type_Init_Proc (Obj); + -- [begin] -- exceptions allowed + -- Deep_Initialize (Obj); + -- [exception -- exceptions allowed + -- when others => + -- Deep_Finalize (Obj, Self => False); + -- raise; + -- end;] + -- [at end -- aborts allowed + -- Abort_Undefer; + -- end;] + + -- When aborts are allowed, the initialization calls are housed + -- within a block. + + elsif Nkind (Stmt) = N_Block_Statement then + Last_Init := Find_Last_Init_In_Block (Stmt, Init_Typ); + Body_Insert := Stmt; + + -- Otherwise the initialization calls follow the related object else - Nod_1 := Next_Suitable_Statement (Decl); - - if Present (Nod_1) then - Nod_2 := Next_Suitable_Statement (Nod_1); + Stmt_2 := Next_Suitable_Statement (Stmt); - -- The statement following an object declaration is always a - -- call to the type init proc. + -- Check for an optional call to Deep_Initialize which may + -- appear within a block depending on whether the object has + -- controlled components. - Last_Init := Nod_1; - end if; - - -- Optional user-defined init or deep init processing - - if Present (Nod_2) then - - -- The statement following the type init proc may be a block - -- statement in cases where abort deferral is required. - - if Nkind (Nod_2) = N_Block_Statement then - declare - HSS : constant Node_Id := - Handled_Statement_Sequence (Nod_2); - Stmt : Node_Id; - - begin - if Present (HSS) - and then Present (Statements (HSS)) - then - -- Examine individual block statements and locate - -- the call to [Deep_]Initialze. + if Present (Stmt_2) then + if Nkind (Stmt_2) = N_Block_Statement then + Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ); - Stmt := First (Statements (HSS)); - while Present (Stmt) loop - if Is_Init_Call (Stmt, Utyp) then - Last_Init := Stmt; - Body_Insert := Nod_2; + if Present (Call) then + Last_Init := Call; + Body_Insert := Stmt_2; + end if; - exit; - end if; + elsif Is_Init_Call (Stmt_2, Init_Typ) then + Last_Init := Stmt_2; + Body_Insert := Last_Init; + end if; - Next (Stmt); - end loop; - end if; - end; + -- If the object lacks a call to Deep_Initialize, then it must + -- have a call to its related type init proc. - elsif Is_Init_Call (Nod_2, Utyp) then - Last_Init := Nod_2; - end if; + elsif Is_Init_Call (Stmt, Init_Typ) then + Last_Init := Stmt; + Body_Insert := Last_Init; end if; end if; end Find_Last_Init; + -- Local variables + + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Body_Ins : Node_Id; + Count_Ins : Node_Id; + Fin_Call : Node_Id; + Fin_Stmts : List_Id; + Inc_Decl : Node_Id; + Label : Node_Id; + Label_Id : Entity_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + -- Start of processing for Process_Object_Declaration begin @@ -2492,7 +2561,7 @@ package body Exp_Ch7 is -- initialized via an aggregate, then the counter must be inserted -- after the last aggregate assignment. - if Ekind (Obj_Id) = E_Variable + if Ekind_In (Obj_Id, E_Constant, E_Variable) and then Present (Last_Aggregate_Assignment (Obj_Id)) then Count_Ins := Last_Aggregate_Assignment (Obj_Id); @@ -2502,7 +2571,7 @@ package body Exp_Ch7 is -- either [Deep_]Initialize or the type specific init proc. else - Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins); + Find_Last_Init (Decl, Count_Ins, Body_Ins); end if; Insert_After (Count_Ins, Inc_Decl); @@ -2526,7 +2595,7 @@ package body Exp_Ch7 is end if; -- Create the associated label with this object, generate: - -- + -- L : label; Label_Id := @@ -2541,7 +2610,7 @@ package body Exp_Ch7 is Label_Construct => Label)); -- Create the associated jump with this object, generate: - + -- -- when => -- goto L; @@ -2685,7 +2754,8 @@ package body Exp_Ch7 is if Is_Build_In_Place_Function (Func_Id) and then Needs_BIP_Finalization_Master (Func_Id) then - Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); + Append_To + (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id, Obj_Id)); end if; end; end if; @@ -4933,9 +5003,9 @@ package body Exp_Ch7 is ----------------------- function Make_Adjust_Call - (Obj_Ref : Node_Id; - Typ : Entity_Id; - For_Parent : Boolean := False) return Node_Id + (Obj_Ref : Node_Id; + Typ : Entity_Id; + Skip_Self : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); Adj_Id : Entity_Id := Empty; @@ -4972,11 +5042,13 @@ package body Exp_Ch7 is Ref := Unchecked_Convert_To (Utyp, Ref); end if; - -- Select the appropriate version of adjust - - if For_Parent then + if Skip_Self then if Has_Controlled_Component (Utyp) then - Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + if Is_Tagged_Type (Utyp) then + Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust); + else + Adj_Id := TSS (Utyp, TSS_Deep_Adjust); + end if; end if; -- Class-wide types, interfaces and types with controlled components @@ -5027,7 +5099,11 @@ package body Exp_Ch7 is Ref := Convert_View (Adj_Id, Ref); end if; - return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent); + return + Make_Call (Loc, + Proc_Id => Adj_Id, + Param => New_Copy_Tree (Ref), + Skip_Self => Skip_Self); else return Empty; end if; @@ -5075,19 +5151,18 @@ package body Exp_Ch7 is --------------- function Make_Call - (Loc : Source_Ptr; - Proc_Id : Entity_Id; - Param : Node_Id; - For_Parent : Boolean := False) return Node_Id + (Loc : Source_Ptr; + Proc_Id : Entity_Id; + Param : Node_Id; + Skip_Self : Boolean := False) return Node_Id is Params : constant List_Id := New_List (Param); begin - -- When creating a call to Deep_Finalize for a _parent field of a - -- derived type, disable the invocation of the nested Finalize by giving - -- the corresponding flag a False value. + -- Do not apply the controlled action to the object itself by signaling + -- the related routine to avoid self. - if For_Parent then + if Skip_Self then Append_To (Params, New_Occurrence_Of (Standard_False, Loc)); end if; @@ -6307,13 +6382,13 @@ package body Exp_Ch7 is if Needs_Finalization (Par_Typ) then Call := Make_Adjust_Call - (Obj_Ref => + (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Name_uParent)), - Typ => Par_Typ, - For_Parent => True); + Typ => Par_Typ, + Skip_Self => True); -- Generate: -- Deep_Adjust (V._parent, False); -- No_Except_Propagat @@ -6882,13 +6957,13 @@ package body Exp_Ch7 is if Needs_Finalization (Par_Typ) then Call := Make_Final_Call - (Obj_Ref => + (Obj_Ref => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Name_uParent)), - Typ => Par_Typ, - For_Parent => True); + Typ => Par_Typ, + Skip_Self => True); -- Generate: -- Deep_Finalize (V._parent, False); -- No_Except_Propag @@ -7118,9 +7193,9 @@ package body Exp_Ch7 is ---------------------- function Make_Final_Call - (Obj_Ref : Node_Id; - Typ : Entity_Id; - For_Parent : Boolean := False) return Node_Id + (Obj_Ref : Node_Id; + Typ : Entity_Id; + Skip_Self : Boolean := False) return Node_Id is Loc : constant Source_Ptr := Sloc (Obj_Ref); Atyp : Entity_Id; @@ -7203,11 +7278,13 @@ package body Exp_Ch7 is Set_Assignment_OK (Ref); end if; - -- Select the appropriate version of Finalize - - if For_Parent then + if Skip_Self then if Has_Controlled_Component (Utyp) then - Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + if Is_Tagged_Type (Utyp) then + Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize); + else + Fin_Id := TSS (Utyp, TSS_Deep_Finalize); + end if; end if; -- Class-wide types, interfaces and types with controlled components @@ -7278,7 +7355,11 @@ package body Exp_Ch7 is Ref := Convert_View (Fin_Id, Ref); end if; - return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent); + return + Make_Call (Loc, + Proc_Id => Fin_Id, + Param => New_Copy_Tree (Ref), + Skip_Self => Skip_Self); else return Empty; end if; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 86faac9..1217e5b 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -162,14 +162,14 @@ package Exp_Ch7 is -- latest extension contains a controlled component. function Make_Adjust_Call - (Obj_Ref : Node_Id; - Typ : Entity_Id; - For_Parent : Boolean := False) return Node_Id; + (Obj_Ref : Node_Id; + Typ : Entity_Id; + Skip_Self : Boolean := False) return Node_Id; -- Create a call to either Adjust or Deep_Adjust depending on the structure -- of type Typ. Obj_Ref is an expression with no-side effect (not required -- to have been previously analyzed) that references the object to be - -- adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be - -- set when an adjustment call is being created for field _parent. + -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, + -- only the components (if any) are adjusted. function Make_Attach_Call (Obj_Ref : Node_Id; @@ -191,15 +191,14 @@ package Exp_Ch7 is -- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref)); function Make_Final_Call - (Obj_Ref : Node_Id; - Typ : Entity_Id; - For_Parent : Boolean := False) return Node_Id; + (Obj_Ref : Node_Id; + Typ : Entity_Id; + Skip_Self : Boolean := False) return Node_Id; -- Create a call to either Finalize or Deep_Finalize depending on the - -- structure of type Typ. Obj_Ref is an expression (with no-side effect and - -- is not required to have been previously analyzed) that references the - -- object to be finalized. Typ is the expected type of Obj_Ref. Flag For_ - -- Parent must be set when a finalization call is being created for field - -- _parent. + -- structure of type Typ. Obj_Ref is an expression (with no-side effect + -- and is not required to have been previously analyzed) that references + -- the object to be finalized. Typ is the expected type of Obj_Ref. When + -- Skip_Self is set, only the components (if any) are finalized. procedure Make_Finalize_Address_Body (Typ : Entity_Id); -- Create the body of TSS routine Finalize_Address if Typ is controlled and @@ -300,7 +299,12 @@ package Exp_Ch7 is procedure Store_After_Actions_In_Scope (L : List_Id); -- Prepend the list L of actions to the beginning of the after-actions -- stored in the top of the scope stack (also analyzes these actions). - -- Why prepend rather than append ??? + -- + -- Note that we are prepending here rather than appending. This means that + -- if several calls are made to this procedure for the same scope, the + -- actions will be executed in reverse order of the calls (actions for the + -- last call executed first). Within the list L for a single call, the + -- actions are executed in the order in which they appear in this list. procedure Store_Cleanup_Actions_In_Scope (L : List_Id); -- Prepend the list L of actions to the beginning of the cleanup-actions diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 9dcd7de..fb47956 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2436,10 +2436,11 @@ package body Sem_Ch9 is -- AI05-0225: the target protected object of a requeue must be a -- variable. This is a binding interpretation that applies to all - -- versions of the language. + -- versions of the language. Note that the subprogram does not have + -- to be a protected operation: it can be an primitive implemented + -- by entry with a formal that is a protected interface. if Present (Target_Obj) - and then Ekind (Scope (Entry_Id)) in Protected_Kind and then not Is_Variable (Target_Obj) then Error_Msg_N