===================================================================
@@ -150,6 +150,9 @@
-- ??? The entire comment needs to be rewritten
-- ??? which entire comment?
+ procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
+ -- Shared processing for Store_xxx_Actions_In_Scope
+
-----------------------------
-- Finalization Management --
-----------------------------
@@ -296,11 +299,14 @@
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
- function Build_Cleanup_Statements (N : Node_Id) return List_Id;
+ function Build_Cleanup_Statements
+ (N : Node_Id;
+ Additional_Cleanup : List_Id) return List_Id;
-- Create the clean up calls for an asynchronous call block, task master,
- -- protected subprogram body, task allocation block or task body. If the
- -- context does not contain the above constructs, the routine returns an
- -- empty list.
+ -- protected subprogram body, task allocation block or task body, or
+ -- additional cleanup actions parked on a transient block. If the context
+ -- does not contain the above constructs, the routine returns an empty
+ -- list.
procedure Build_Finalizer
(N : Node_Id;
@@ -467,7 +473,10 @@
-- Build_Cleanup_Statements --
------------------------------
- function Build_Cleanup_Statements (N : Node_Id) return List_Id is
+ function Build_Cleanup_Statements
+ (N : Node_Id;
+ Additional_Cleanup : List_Id) return List_Id
+ is
Is_Asynchronous_Call : constant Boolean :=
Nkind (N) = N_Block_Statement
and then Is_Asynchronous_Call_Block (N);
@@ -626,6 +635,7 @@
end;
end if;
+ Append_List_To (Stmts, Additional_Cleanup);
return Stmts;
end Build_Cleanup_Statements;
@@ -792,9 +802,7 @@
-- Start of processing for Build_Finalization_Master
begin
- if Is_Private_Type (Ptr_Typ)
- and then Present (Full_View (Ptr_Typ))
- then
+ if Is_Private_Type (Ptr_Typ) and then Present (Full_View (Ptr_Typ)) then
Ptr_Typ := Full_View (Ptr_Typ);
end if;
@@ -887,9 +895,7 @@
-- inserted in the same source unit only once. The only exception to
-- this are instances using the same access type as generic actual.
- if Comes_From_Source (Ptr_Typ)
- and then not Inside_A_Generic
- then
+ if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
@@ -1436,9 +1442,7 @@
Expression => Make_Identifier (Loc, Chars (Counter_Id)),
Alternatives => Jump_Alts);
- if Acts_As_Clean
- and then Present (Jump_Block_Insert_Nod)
- then
+ if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
Insert_After (Jump_Block_Insert_Nod, Jump_Block);
else
Prepend_To (Finalizer_Stmts, Jump_Block);
@@ -1481,10 +1485,7 @@
-- aborts are allowed and the clean up statements require deferral or
-- there are controlled objects to be finalized.
- if Abort_Allowed
- and then
- (Defer_Abort or else Has_Ctrl_Objs)
- then
+ if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
Prepend_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc)));
@@ -1502,10 +1503,7 @@
-- Raise_From_Controlled_Operation (E);
-- end if;
- if Has_Ctrl_Objs
- and then Exceptions_OK
- and then not For_Package
- then
+ if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
Append_To (Finalizer_Stmts,
Build_Raise_Statement (Finalizer_Data));
end if;
@@ -1608,9 +1606,7 @@
-- When the finalizer acts solely as a clean up routine, the body
-- is inserted right after the spec.
- if Acts_As_Clean
- and then not Has_Ctrl_Objs
- then
+ if Acts_As_Clean and then not Has_Ctrl_Objs then
Insert_After (Fin_Spec, Fin_Body);
-- In all other cases the body is inserted after either:
@@ -1706,9 +1702,7 @@
if Preprocess then
Has_Tagged_Types := True;
- if Top_Level
- and then No (Last_Top_Level_Ctrl_Construct)
- then
+ if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
@@ -1723,9 +1717,7 @@
Counter_Val := Counter_Val + 1;
Has_Ctrl_Objs := True;
- if Top_Level
- and then No (Last_Top_Level_Ctrl_Construct)
- then
+ if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
Last_Top_Level_Ctrl_Construct := Decl;
end if;
@@ -1774,9 +1766,7 @@
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Transient variables are treated separately in order to
@@ -1824,7 +1814,7 @@
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
- N_Object_Declaration
+ N_Object_Declaration
and then Is_Finalizable_Transient
(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
@@ -1893,9 +1883,7 @@
-- finalization disabled. This applies only to objects at the
-- library level.
- if For_Package
- and then Finalize_Storage_Only (Obj_Typ)
- then
+ if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
-- Return object of a build-in-place function. This case is
@@ -3534,9 +3522,7 @@
begin
Func_Id := E;
- while Present (Func_Id)
- and then Func_Id /= Standard_Standard
- loop
+ while Present (Func_Id) and then Func_Id /= Standard_Standard loop
if Ekind (Func_Id) = E_Function then
return Func_Id;
end if;
@@ -3691,6 +3677,9 @@
and then
not Sec_Stack_Needed_For_Return (Scop)
and then VM_Target = No_VM;
+ Needs_Custom_Cleanup : constant Boolean :=
+ Nkind (N) = N_Block_Statement
+ and then Present (Cleanup_Actions (N));
Actions_Required : constant Boolean :=
Requires_Cleanup_Actions (N, True)
@@ -3699,10 +3688,12 @@
or else Is_Protected_Body
or else Is_Task_Allocation
or else Is_Task_Body
- or else Needs_Sec_Stack_Mark;
+ or else Needs_Sec_Stack_Mark
+ or else Needs_Custom_Cleanup;
HSS : Node_Id := Handled_Statement_Sequence (N);
Loc : Source_Ptr;
+ Cln : List_Id;
procedure Wrap_HSS_In_Block;
-- Move HSS inside a new block along with the original exception
@@ -3761,6 +3752,12 @@
return;
end if;
+ if Needs_Custom_Cleanup then
+ Cln := Cleanup_Actions (N);
+ else
+ Cln := No_List;
+ end if;
+
declare
Decls : List_Id := Declarations (N);
Fin_Id : Entity_Id;
@@ -3898,7 +3895,7 @@
Build_Finalizer
(N => N,
- Clean_Stmts => Build_Cleanup_Statements (N),
+ Clean_Stmts => Build_Cleanup_Statements (N, Cln),
Mark_Id => Mark,
Top_Decls => New_Decls,
Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
@@ -4440,10 +4437,10 @@
------------------------------------
procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
- After : constant List_Id :=
- Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_After;
- Before : constant List_Id :=
- Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped_Before;
+ Act_After : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
+ Act_Before : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
-- Last), but this was incorrect as Process_Transient_Object may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
@@ -4794,7 +4791,7 @@
-- Start of processing for Insert_Actions_In_Scope_Around
begin
- if No (Before) and then No (After) then
+ if No (Act_Before) and then No (Act_After) then
return;
end if;
@@ -4833,22 +4830,22 @@
-- 3) Target ........ Last_Obj
- if Present (Before) then
+ if Present (Act_Before) then
-- Flag declarations are inserted before the first object
- First_Obj := First (Before);
+ First_Obj := First (Act_Before);
- Insert_List_Before (Target, Before);
+ Insert_List_Before (Target, Act_Before);
end if;
- if Present (After) then
+ if Present (Act_After) then
-- Finalization calls are inserted after the last object
- Last_Obj := Last (After);
+ Last_Obj := Last (Act_After);
- Insert_List_After (Target, After);
+ Insert_List_After (Target, Act_After);
end if;
-- Check for transient controlled objects associated with Target and
@@ -4861,14 +4858,14 @@
-- Reset the action lists
- if Present (Before) then
+ if Present (Act_Before) then
Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped_Before := No_List;
+ Actions_To_Be_Wrapped (Before) := No_List;
end if;
- if Present (After) then
+ if Present (Act_After) then
Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped_After := No_List;
+ Actions_To_Be_Wrapped (After) := No_List;
end if;
end;
end Insert_Actions_In_Scope_Around;
@@ -6564,9 +6561,7 @@
-- order to generate the same state counter names as those from
-- Build_Initialize_Statements.
- if Num_Comps > 0
- and then Is_Local
- then
+ if Num_Comps > 0 and then Is_Local then
Counter := Counter + 1;
Counter_Id :=
@@ -7253,7 +7248,7 @@
Ekind (Typ) = E_Record_Type
and then Is_Concurrent_Record_Type (Typ)
and then Ekind (Corresponding_Concurrent_Type (Typ)) =
- E_Task_Type;
+ E_Task_Type;
Loc : constant Source_Ptr := Sloc (Typ);
Proc_Id : Entity_Id;
Stmts : List_Id;
@@ -7832,8 +7827,10 @@
end if;
-- Create the transient block. Set the parent now since the block itself
- -- is not part of the tree.
+ -- is not part of the tree. The current scope is the E_Block entity
+ -- that has been pushed by Establish_Transient_Scope.
+ pragma Assert (Ekind (Current_Scope) = E_Block);
Block :=
Make_Block_Statement (Loc,
Identifier => New_Occurrence_Of (Current_Scope, Loc),
@@ -7853,6 +7850,17 @@
Freeze_All (First_Entity (Current_Scope), Insert);
end if;
+ -- Transfer cleanup actions to the newly created block
+
+ declare
+ Cleanup_Actions : List_Id
+ renames Scope_Stack.Table (Scope_Stack.Last).
+ Actions_To_Be_Wrapped (Cleanup);
+ begin
+ Set_Cleanup_Actions (Block, Cleanup_Actions);
+ Cleanup_Actions := No_List;
+ end;
+
-- When the transient scope was established, we pushed the entry for the
-- transient scope onto the scope stack, so that the scope was active
-- for the installation of finalizable entities etc. Now we must remove
@@ -7881,21 +7889,18 @@
Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
end Set_Node_To_Be_Wrapped;
- ----------------------------------
- -- Store_After_Actions_In_Scope --
- ----------------------------------
+ ----------------------------
+ -- Store_Actions_In_Scope --
+ ----------------------------
- procedure Store_After_Actions_In_Scope (L : List_Id) is
- SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
+ SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
begin
- if Present (SE.Actions_To_Be_Wrapped_After) then
- Insert_List_Before_And_Analyze
- (First (SE.Actions_To_Be_Wrapped_After), L);
+ if No (Actions) then
+ Actions := L;
- else
- SE.Actions_To_Be_Wrapped_After := L;
-
if Is_List_Member (SE.Node_To_Be_Wrapped) then
Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
else
@@ -7903,7 +7908,22 @@
end if;
Analyze_List (L);
+
+ elsif AK = Before then
+ Insert_List_After_And_Analyze (Last (Actions), L);
+
+ else
+ Insert_List_Before_And_Analyze (First (Actions), L);
end if;
+ end Store_Actions_In_Scope;
+
+ ----------------------------------
+ -- Store_After_Actions_In_Scope --
+ ----------------------------------
+
+ procedure Store_After_Actions_In_Scope (L : List_Id) is
+ begin
+ Store_Actions_In_Scope (After, L);
end Store_After_Actions_In_Scope;
-----------------------------------
@@ -7911,26 +7931,19 @@
-----------------------------------
procedure Store_Before_Actions_In_Scope (L : List_Id) is
- SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
begin
- if Present (SE.Actions_To_Be_Wrapped_Before) then
- Insert_List_After_And_Analyze
- (Last (SE.Actions_To_Be_Wrapped_Before), L);
+ Store_Actions_In_Scope (Before, L);
+ end Store_Before_Actions_In_Scope;
- else
- SE.Actions_To_Be_Wrapped_Before := L;
+ -----------------------------------
+ -- Store_Cleanup_Actions_In_Scope --
+ -----------------------------------
- if Is_List_Member (SE.Node_To_Be_Wrapped) then
- Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
- else
- Set_Parent (L, SE.Node_To_Be_Wrapped);
- end if;
+ procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
+ begin
+ Store_Actions_In_Scope (Cleanup, L);
+ end Store_Cleanup_Actions_In_Scope;
- Analyze_List (L);
- end if;
- end Store_Before_Actions_In_Scope;
-
--------------------------------
-- Wrap_Transient_Declaration --
--------------------------------
===================================================================
@@ -302,6 +302,10 @@
-- stored in the top of the scope stack (also analyzes these actions).
-- Why prepend rather than append ???
+ procedure Store_Cleanup_Actions_In_Scope (L : List_Id);
+ -- Prepend the list L of actions to the beginning of the cleanup-actions
+ -- store in the top of the scope stack.
+
procedure Wrap_Transient_Declaration (N : Node_Id);
-- N is an object declaration. Expand the finalization calls after the
-- declaration and make the outer scope being the transient one.
===================================================================
@@ -432,6 +432,14 @@
return Node3 (N);
end Classifications;
+ function Cleanup_Actions
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return List5 (N);
+ end Cleanup_Actions;
+
function Comes_From_Extended_Return_Statement
(N : Node_Id) return Boolean is
begin
@@ -3599,6 +3607,14 @@
Set_Node3 (N, Val); -- semantic field, no parent set
end Set_Classifications;
+ procedure Set_Cleanup_Actions
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_List5 (N, Val); -- semantic field, no parent set
+ end Set_Cleanup_Actions;
+
procedure Set_Comes_From_Extended_Return_Statement
(N : Node_Id; Val : Boolean := True) is
begin
===================================================================
@@ -832,6 +832,10 @@
-- the secondary stack and thus the result is passed by reference rather
-- than copied another time.
+ -- Cleanup_Actions (List5-Sem)
+ -- Present in block statements created for transient blocks, contains
+ -- additional cleanup actions carried over from the transient scope.
+
-- Check_Address_Alignment (Flag11-Sem)
-- A flag present in N_Attribute_Definition clause for a 'Address
-- attribute definition. This flag is set if a dynamic check should be
@@ -4731,6 +4735,7 @@
-- Identifier (Node1) block direct name (set to Empty if not present)
-- Declarations (List2) (set to No_List if no DECLARE part)
-- Handled_Statement_Sequence (Node4)
+ -- Cleanup_Actions (List5-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Activation_Chain_Entity (Node3-Sem)
-- Has_Created_Identifier (Flag15)
@@ -8689,6 +8694,9 @@
function Classifications
(N : Node_Id) return Node_Id; -- Node3
+ function Cleanup_Actions
+ (N : Node_Id) return List_Id; -- List5
+
function Comes_From_Extended_Return_Statement
(N : Node_Id) return Boolean; -- Flag18
@@ -9696,6 +9704,9 @@
procedure Set_Classifications
(N : Node_Id; Val : Node_Id); -- Node3
+ procedure Set_Cleanup_Actions
+ (N : Node_Id; Val : List_Id); -- List5
+
procedure Set_Comes_From_Extended_Return_Statement
(N : Node_Id; Val : Boolean := True); -- Flag18
@@ -12369,6 +12380,7 @@
pragma Inline (Choices);
pragma Inline (Class_Present);
pragma Inline (Classifications);
+ pragma Inline (Cleanup_Actions);
pragma Inline (Comes_From_Extended_Return_Statement);
pragma Inline (Compile_Time_Known_Aggregate);
pragma Inline (Component_Associations);
@@ -12702,6 +12714,7 @@
pragma Inline (Set_Choices);
pragma Inline (Set_Class_Present);
pragma Inline (Set_Classifications);
+ pragma Inline (Set_Cleanup_Actions);
pragma Inline (Set_Comes_From_Extended_Return_Statement);
pragma Inline (Set_Compile_Time_Known_Aggregate);
pragma Inline (Set_Component_Associations);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -450,6 +450,11 @@
-- units and their instantiations, have led to a hybrid model that carries
-- more state than one would wish.
+ type Scope_Action_Kind is (Before, After, Cleanup);
+ type Scope_Actions is array (Scope_Action_Kind) of List_Id;
+ -- Transient blocks have three associated actions list, to be inserted
+ -- before and after the block's statements, and as cleanup actions.
+
type Scope_Stack_Entry is record
Entity : Entity_Id;
-- Entity representing the scope
@@ -496,11 +501,11 @@
-- Only used in transient scopes. Records the node which will
-- be wrapped by the transient block.
- Actions_To_Be_Wrapped_Before : List_Id;
- Actions_To_Be_Wrapped_After : List_Id;
- -- Actions that have to be inserted at the start or at the end of a
- -- transient block. Used to temporarily hold these actions until the
- -- block is created, at which time the actions are moved to the block.
+ Actions_To_Be_Wrapped : Scope_Actions;
+ -- Actions that have to be inserted at the start, at the end, or as
+ -- cleanup actions of a transient block. Used to temporarily hold these
+ -- actions until the block is created, at which time the actions are
+ -- moved to the block.
Pending_Freeze_Actions : List_Id;
-- Used to collect freeze entity nodes and associated actions that are
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -129,62 +129,65 @@
-------------------------------
procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
- Inode : Node_Id;
- Vnm : String_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
+ Vnm : String_Id;
+ Vid : Entity_Id;
+ Aft : constant List_Id := New_List;
begin
- -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
- -- the procedure or function call node. First we locate the right place
- -- to do the insertion, which is the call itself in the procedure call
- -- case, or else the nearest non subexpression node that contains the
- -- function call.
+ Build_Full_Name (Obj, Vnm);
- Inode := N;
- while Nkind (Inode) /= N_Procedure_Call_Statement
- and then Nkind (Inode) in N_Subexpr
- loop
- Inode := Parent (Inode);
- end loop;
+ -- Create constant string. Note that this must be done prior to
+ -- establishing the transient scope, as the finalizer needs to have
+ -- access to this object.
- -- Now insert the Lock and Unlock calls and the read/write calls
+ Vid := Make_Temporary (Loc, 'N', Obj);
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Vid,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression => Make_String_Literal (Loc, Vnm)));
- -- Two concerns here. First we are not dealing with the exception case,
- -- really we need some kind of cleanup routine to do the Unlock. Second,
- -- these lock calls should be inside the protected object processing,
- -- not outside, otherwise they can be done at the wrong priority,
- -- resulting in dead lock situations ???
+ -- Now set up a transient scope around the call, which will hold the
+ -- required lock/unlock actions.
- Build_Full_Name (Obj, Vnm);
+ Establish_Transient_Scope (N, Sec_Stack => False);
-- First insert the Lock call before
- Insert_Before_And_Analyze (Inode,
+ Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, Vnm))));
+ Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc))));
-- Now, right after the Lock, insert a call to read the object
- Insert_Before_And_Analyze (Inode,
+ Insert_Action (N,
Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
- -- Now insert the Unlock call after
+ -- Now for a procedure call, but not a function call, insert the
+ -- call to write the object just before the unlock.
- Insert_After_And_Analyze (Inode,
+ if Nkind (N) = N_Procedure_Call_Statement then
+ Append_To (Aft,
+ Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
+ end if;
+
+ -- Finally insert the Unlock call after
+
+ Append_To (Aft,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, Vnm))));
+ Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc))));
- -- Now for a procedure call, but not a function call, insert the
- -- call to write the object just before the unlock.
+ Store_Cleanup_Actions_In_Scope (Aft);
if Nkind (N) = N_Procedure_Call_Statement then
- Insert_After_And_Analyze (Inode,
- Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
+ Wrap_Transient_Statement (N);
+ else
+ Wrap_Transient_Expression (N);
end if;
end Add_Shared_Var_Lock_Procs;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,9 +44,10 @@
-- The argument is a protected subprogram call, before it is rewritten
-- by Exp_Ch9.Build_Protected_Subprogram_Call. This routine, which is
-- called only in the case of an external call to a protected object
- -- that has Is_Shared_Passive set, deals with installing the required
- -- global lock calls for this case. It also generates the necessary
- -- read/write calls for the protected object within the lock region.
+ -- that has Is_Shared_Passive set, deals with installing a transient scope
+ -- and acquiring the appropriate global lock calls for this case. It also
+ -- generates the necessary read/write calls for the protected object within
+ -- the lock region.
function Make_Shared_Var_Procs (N : Node_Id) return Node_Id;
-- N is the node for the declaration of a shared passive variable.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -119,10 +119,7 @@
if Serious_Errors_Detected > 0 and then Scope_Is_Transient then
Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List;
- Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List;
-
+ (Scope_Stack.Last).Actions_To_Be_Wrapped := (others => No_List);
Pop_Scope;
end if;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1960,9 +1960,11 @@
begin
if LCN = Statements (P)
or else
- LCN = SSE.Actions_To_Be_Wrapped_Before
+ LCN = SSE.Actions_To_Be_Wrapped (Before)
or else
- LCN = SSE.Actions_To_Be_Wrapped_After
+ LCN = SSE.Actions_To_Be_Wrapped (After)
+ or else
+ LCN = SSE.Actions_To_Be_Wrapped (Cleanup)
then
-- Loop through exception handlers
===================================================================
@@ -7150,6 +7150,26 @@
is
Rec : Node_Id;
+ procedure Freeze_Called_Function;
+ -- If it is a function call it can appear in elaboration code and
+ -- the called entity must be frozen before the call. This must be
+ -- done before the call is expanded, as the expansion may rewrite it
+ -- to something other than a call (e.g. a temporary initialized in a
+ -- transient block).
+
+ ----------------------------
+ -- Freeze_Called_Function --
+ ----------------------------
+
+ procedure Freeze_Called_Function is
+ begin
+ if Ekind (Subp) = E_Function then
+ Freeze_Expression (Name (N));
+ end if;
+ end Freeze_Called_Function;
+
+ -- Start of processing for Expand_Protected_Subprogram_Call
+
begin
-- If the protected object is not an enclosing scope, this is an inter-
-- object function call. Inter-object procedure calls are expanded by
@@ -7170,6 +7190,7 @@
Rec := Prefix (Prefix (Name (N)));
end if;
+ Freeze_Called_Function;
Build_Protected_Subprogram_Call (N,
Name => New_Occurrence_Of (Subp, Sloc (N)),
Rec => Convert_Concurrent (Rec, Etype (Rec)),
@@ -7182,6 +7203,7 @@
return;
end if;
+ Freeze_Called_Function;
Build_Protected_Subprogram_Call (N,
Name => Name (N),
Rec => Rec,
@@ -7189,13 +7211,6 @@
end if;
- -- If it is a function call it can appear in elaboration code and
- -- the called entity must be frozen here.
-
- if Ekind (Subp) = E_Function then
- Freeze_Expression (Name (N));
- end if;
-
-- Analyze and resolve the new call. The actuals have already been
-- resolved, but expansion of a function call will add extra actuals
-- if needed. Analysis of a procedure call already includes resolution.
===================================================================
@@ -7541,10 +7541,7 @@
-- this case (and we do the abort even with assertions off since the
-- penalty is incorrect code generation).
- if SST.Actions_To_Be_Wrapped_Before /= No_List
- or else
- SST.Actions_To_Be_Wrapped_After /= No_List
- then
+ if SST.Actions_To_Be_Wrapped /= Scope_Actions'(others => No_List) then
raise Program_Error;
end if;
@@ -7611,8 +7608,7 @@
SST.Is_Transient := False;
SST.Node_To_Be_Wrapped := Empty;
SST.Pending_Freeze_Actions := No_List;
- SST.Actions_To_Be_Wrapped_Before := No_List;
- SST.Actions_To_Be_Wrapped_After := No_List;
+ SST.Actions_To_Be_Wrapped := (others => No_List);
SST.First_Use_Clause := Empty;
SST.Is_Active_Stack_Base := False;
SST.Previous_Visibility := False;
This change addresses a missing unlock operation for the case of a call to a protected function appearing as the expression of a RETURN statement: the unlock was inserted after the statement containing the protected function call, which means that in the case of a RETURN statement it would never be executed. It is now properly generated as a cleanup action that is executed in all cases. The following test case must display '42' without hanging when executed repeatedly: $ gnatmake -q shared_prot_func_ret.adb $ ./shared_prot_func_ret 42 $ ./shared_prot_func_ret 42 package body Session_Db is type Table_Entry is record V, N : Integer; end record; protected Table is procedure Add (Name, Value : Integer); function Find (Name : Integer) return Integer; private T : Table_Entry; end Table; protected body Table is procedure Add (Name, Value : Integer) is begin T := (N => Name, V => Value); end Add; function Find (Name : Integer) return Integer is begin return T.V; end Find; end Table; --------- -- Add -- --------- procedure Add (Name : Integer; Value : Integer) is begin Table.Add (Name, Value); end Add; ---------- -- Find -- ---------- function Find (Name : Integer) return Integer is begin return Table.Find (Name); end Find; end Session_Db; package Session_Db is pragma Shared_Passive; procedure Add (Name : Integer; Value : Integer); function Find (Name : Integer) return Integer; end Session_Db; with Session_Db; use Session_Db; with Ada.Text_IO; use Ada.Text_IO; procedure Shared_Prot_Func_Ret is begin Session_Db.Add (3, 42); Put_Line (Session_Db.Find (3)'Img); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-17 Thomas Quinot <quinot@adacore.com> * sem.ads (Scope_Stack_Entry): Reorganize storage of action lists; introduce a new list (cleanup actions) for each (transient) scope. * sinfo.ads, sinfo.adb (Cleanup_Actions): New attribute for N_Block_Statement * exp_ch7.ads (Store_Cleanup_Actions_In_Scope): New subprogram. * exp_ch7.adb (Store_Actions_In_Scope): New subprogram, common processing for Store_xxx_Actions_In_Scope. (Build_Cleanup_Statements): Allow for a list of additional cleanup statements to be passed by the caller. (Expand_Cleanup_Actions): Take custom cleanup actions associated with an N_Block_Statement into account. (Insert_Actions_In_Scope_Around): Account for Scope_Stack_Entry reorganization (refactoring only, no behaviour change). (Make_Transient_Block): Add assertion to ensure that the current scope is indeed a block (namely, the entity for the transient block being constructed syntactically, which has already been established as a scope). If cleanup actions are present in the transient scope, transfer them now to the transient block. * exp_ch6.adb (Expand_Protected_Subprogram_Call): Freeze the called function while it is still present as the name in a call in the tree. This may not be the case later on if the call is rewritten into a transient block. * exp_smem.adb (Add_Shared_Var_Lock_Procs): The post-actions inserted after calling a protected operation on a shared passive protected must be performed in a block finalizer, not just inserted in the tree, so that they are executed even in case of a normal (RETURN) or abnormal (exception) transfer of control outside of the current scope. * exp_smem.ads (Add_Shared_Var_Lock_Procs): Update documentation * sem_ch8.adb, expander.adb, exp_ch11.adb: Adjust for Scope_Stack_Entry reorganization.