OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-07-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2014-07-18 13:02:42 +02:00
parent 2941bf7dab
commit 4ac2bbbd05
8 changed files with 641 additions and 377 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
gcc/ada/ChangeLog
View File

@ -1,3 +1,50 @@
2014-07-18 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <dewar@adacore.com>
* gnat_rm.texi: Remove mention of obsolete attributes

17
gcc/ada/einfo.adb
View File

@ -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");

13
gcc/ada/einfo.ads
View File

@ -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)

63
gcc/ada/exp_aggr.adb
View File

@ -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;
----------------------------------

442
gcc/ada/exp_ch3.adb
View File

@ -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;
-- <finalization statements>
-- 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;

399
gcc/ada/exp_ch7.adb
View File

@ -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.
if Is_Controlled (Typ) then
Init := Find_Prim_Op (Typ, Name_Initialize);
-- Deep_Initialize
if Present (Init) then
Init := Ultimate_Alias (Init);
end if;
Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize);
-- Primitive Initialize
if Is_Controlled (Init_Typ) then
Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize);
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,23 +2389,41 @@ 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;
-- Obtain the proper type of the object being initialized
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;
if Is_Private_Type (Utyp)
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp);
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:
-- 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:
-- Object : Controlled_Type;
-- Controlled_TypeIP (Object);
-- [[Deep_]Initialize (Object);]
-- [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;]
-- where the user-defined initialize may be optional or may appear
-- inside a block when abort deferral is needed.
-- 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);
Stmt_2 := Next_Suitable_Statement (Stmt);
if Present (Nod_1) then
Nod_2 := Next_Suitable_Statement (Nod_1);
-- Check for an optional call to Deep_Initialize which may
-- appear within a block depending on whether the object has
-- controlled components.
-- The statement following an object declaration is always a
-- call to the type init proc.
if Present (Stmt_2) then
if Nkind (Stmt_2) = N_Block_Statement then
Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ);
Last_Init := Nod_1;
end if;
if Present (Call) then
Last_Init := Call;
Body_Insert := Stmt_2;
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.
Stmt := First (Statements (HSS));
while Present (Stmt) loop
if Is_Init_Call (Stmt, Utyp) then
Last_Init := Stmt;
Body_Insert := Nod_2;
exit;
end if;
Next (Stmt);
end loop;
end if;
end;
elsif Is_Init_Call (Nod_2, Utyp) then
Last_Init := Nod_2;
elsif Is_Init_Call (Stmt_2, Init_Typ) then
Last_Init := Stmt_2;
Body_Insert := Last_Init;
end if;
-- 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 (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<counter> : label;
Label_Id :=
@ -2541,7 +2610,7 @@ package body Exp_Ch7 is
Label_Construct => Label));
-- Create the associated jump with this object, generate:
--
-- when <counter> =>
-- goto L<counter>;
@ -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;

32
gcc/ada/exp_ch7.ads
View File

@ -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

5
gcc/ada/sem_ch9.adb
View File

@ -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