+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.
+
+2014-07-17 Thomas Quinot <quinot@adacore.com>
+
+ * exp_disp.adb (Make_DT, Make_VM_TSD): Do not omit Check_TSD
+ call for types that do not have an explicit attribute definition
+ clause for External_Tag, as their default tag may clash with an
+ explicit tag defined for some other type.
+
+2014-07-17 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Is_Controlled_Function_Call): Recognize a
+ controlled function call with multiple actual parameters that
+ appears in Object.Operation form.
+
+2014-07-17 Thomas Quinot <quinot@adacore.com>
+
+ * einfo.ads, einfo.adb (Has_External_Tag_Rep_Clause): Remove
+ entity flag.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case
+ External_Tag): No need to set entity flag.
+ * sem_aux.ads, sem_aux.adb (Has_External_Tag_Rep_Clause):
+ Reimplement correctly in terms of Has_Rep_Item.
+
2014-07-17 Thomas Quinot <quinot@adacore.com>
* exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped):
-- Is_Private_Composite Flag107
-- Default_Expressions_Processed Flag108
-- Is_Non_Static_Subtype Flag109
- -- Has_External_Tag_Rep_Clause Flag110
-- Is_Formal_Subprogram Flag111
-- Is_Renaming_Of_Object Flag112
-- (unused) Flag2
-- (unused) Flag3
+ -- (unused) Flag110
+
-- (unused) Flag269
-- (unused) Flag270
return Flag47 (Id);
end Has_Exit;
- function Has_External_Tag_Rep_Clause (Id : E) return B is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- return Flag110 (Id);
- end Has_External_Tag_Rep_Clause;
-
function Has_Forward_Instantiation (Id : E) return B is
begin
return Flag175 (Id);
Set_Flag47 (Id, V);
end Set_Has_Exit;
- procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Tagged_Type (Id));
- Set_Flag110 (Id, V);
- end Set_Has_External_Tag_Rep_Clause;
-
procedure Set_Has_Forward_Instantiation (Id : E; V : B := True) is
begin
Set_Flag175 (Id, V);
W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id));
W ("Has_Enumeration_Rep_Clause", Flag66 (Id));
W ("Has_Exit", Flag47 (Id));
- W ("Has_External_Tag_Rep_Clause", Flag110 (Id));
W ("Has_Forward_Instantiation", Flag175 (Id));
W ("Has_Fully_Qualified_Name", Flag173 (Id));
W ("Has_Gigi_Rep_Item", Flag82 (Id));
-- that this does not imply a representation with holes, since the rep
-- clause may merely confirm the default 0..N representation.
--- Has_External_Tag_Rep_Clause (Flag110)
--- Defined in tagged types. Set if an external_tag rep. clause has been
--- given for this type. Use to avoid the generation of the default
--- external_tag.
-
-- Has_Exit (Flag47)
-- Defined in loop entities. Set if the loop contains an exit statement.
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
- -- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
-- Has_Record_Rep_Clause (Flag65) (base type only)
- -- Has_External_Tag_Rep_Clause (Flag110)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
function Has_Dynamic_Predicate_Aspect (Id : E) return B;
function Has_Enumeration_Rep_Clause (Id : E) return B;
function Has_Exit (Id : E) return B;
- function Has_External_Tag_Rep_Clause (Id : E) return B;
function Has_Forward_Instantiation (Id : E) return B;
function Has_Fully_Qualified_Name (Id : E) return B;
function Has_Gigi_Rep_Item (Id : E) return B;
procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True);
procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Exit (Id : E; V : B := True);
- procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Forward_Instantiation (Id : E; V : B := True);
procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True);
pragma Inline (Has_Dynamic_Predicate_Aspect);
pragma Inline (Has_Enumeration_Rep_Clause);
pragma Inline (Has_Exit);
- pragma Inline (Has_External_Tag_Rep_Clause);
pragma Inline (Has_Forward_Instantiation);
pragma Inline (Has_Fully_Qualified_Name);
pragma Inline (Has_Gigi_Rep_Item);
pragma Inline (Set_Has_Dynamic_Predicate_Aspect);
pragma Inline (Set_Has_Enumeration_Rep_Clause);
pragma Inline (Set_Has_Exit);
- pragma Inline (Set_Has_External_Tag_Rep_Clause);
pragma Inline (Set_Has_Forward_Instantiation);
pragma Inline (Set_Has_Fully_Qualified_Name);
pragma Inline (Set_Has_Gigi_Rep_Item);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- 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- --
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
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
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)),
return;
end if;
+ Freeze_Called_Function;
Build_Protected_Subprogram_Call (N,
Name => Name (N),
Rec => Rec,
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.
-- ??? 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 --
-----------------------------
-- 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;
-- 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);
end;
end if;
+ Append_List_To (Stmts, Additional_Cleanup);
return Stmts;
end Build_Cleanup_Statements;
-- 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;
-- 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"));
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);
-- 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)));
-- 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;
-- 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:
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;
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;
-- 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
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
-- 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
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;
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)
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
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;
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
------------------------------------
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.
-- 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;
-- 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
-- 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;
-- 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 :=
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;
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),
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
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);
-
- else
- SE.Actions_To_Be_Wrapped_After := L;
+ if No (Actions) then
+ Actions := L;
if Is_List_Member (SE.Node_To_Be_Wrapped) then
Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
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;
-----------------------------------
-----------------------------------
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);
-
- else
- SE.Actions_To_Be_Wrapped_Before := L;
+ Store_Actions_In_Scope (Before, L);
+ end Store_Before_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;
+ -----------------------------------
+ -- Store_Cleanup_Actions_In_Scope --
+ -----------------------------------
- Analyze_List (L);
- end if;
- end Store_Before_Actions_In_Scope;
+ procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
+ begin
+ Store_Actions_In_Scope (Cleanup, L);
+ end Store_Cleanup_Actions_In_Scope;
--------------------------------
-- Wrap_Transient_Declaration --
-- 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.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- 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- --
end if;
end if;
- -- If the type has a representation clause which specifies its external
- -- tag then generate code to check if the external tag of this type is
- -- the same as the external tag of some other declaration.
+ -- Generate code to check if the external tag of this type is the same
+ -- as the external tag of some other declaration.
-- Check_TSD (TSD'Unrestricted_Access);
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005
- and then Has_External_Tag_Rep_Clause (Typ)
and then RTE_Available (RE_Check_TSD)
and then not Debug_Flag_QQ
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Check_TSD), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (TSD, Loc),
+ Prefix => New_Occurrence_Of (TSD, Loc),
Attribute_Name => Name_Unchecked_Access))));
end if;
Expressions => TSD_Aggr_List)));
-- Generate:
- -- Check_TSD
- -- (TSD => TSD'Unrestricted_Access);
+ -- Check_TSD (TSD => TSD'Unrestricted_Access);
if Ada_Version >= Ada_2005
and then Is_Library_Level_Entity (Typ)
- and then Has_External_Tag_Rep_Clause (Typ)
and then RTE_Available (RE_Check_TSD)
and then not Debug_Flag_QQ
then
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
+-- 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- --
-------------------------------
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.
-
- Inode := N;
- while Nkind (Inode) /= N_Procedure_Call_Statement
- and then Nkind (Inode) in N_Subexpr
- loop
- Inode := Parent (Inode);
- end loop;
-
- -- Now insert the Lock and Unlock calls and the read/write calls
-
- -- 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 ???
-
Build_Full_Name (Obj, Vnm);
+ -- 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.
+
+ 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)));
+
+ -- Now set up a transient scope around the call, which will hold the
+ -- required lock/unlock actions.
+
+ 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;
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
+-- 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- --
-- 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.
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
- -- Determine if particular node denotes a controlled function call
+ -- Determine if particular node denotes a controlled function call. The
+ -- call may have been heavily expanded.
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
begin
if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
- end if;
- -- The function call may appear in object.operation format
+ -- When a function call appears in Object.Operation format, the
+ -- original representation has two possible forms depending on the
+ -- availability of actual parameters:
+ --
+ -- Obj.Func_Call -- N_Selected_Component
+ -- Obj.Func_Call (Param) -- N_Indexed_Component
- if Nkind (Expr) = N_Selected_Component then
- Expr := Selector_Name (Expr);
+ else
+ if Nkind (Expr) = N_Indexed_Component then
+ Expr := Prefix (Expr);
+ end if;
+
+ if Nkind (Expr) = N_Selected_Component then
+ Expr := Selector_Name (Expr);
+ end if;
end if;
return
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- 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- --
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;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- 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- --
-- 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
-- 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
return Empty;
end Get_Rep_Pragma;
+ ---------------------------------
+ -- Has_External_Tag_Rep_Clause --
+ ---------------------------------
+
+ function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is
+ begin
+ pragma Assert (Is_Tagged_Type (T));
+ return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False);
+ end Has_External_Tag_Rep_Clause;
+
------------------
-- Has_Rep_Item --
------------------
-- the given names then True is returned, otherwise False indicates that no
-- matching entry was found.
+ function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean;
+ -- Defined in tagged types. Set if an External_Tag rep. clause has been
+ -- given for this type. Use to avoid the generation of the default
+ -- External_Tag.
+
function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
-- True if T has discriminants and is unconstrained, or is an array type
-- whose element type Has_Unconstrained_Elements.
("static string required for tag name!", Nam);
end if;
- if VM_Target = No_VM then
- Set_Has_External_Tag_Rep_Clause (U_Ent);
- else
+ if VM_Target /= No_VM then
Error_Msg_Name_1 := Attr;
Error_Msg_N
("% attribute unsupported in this configuration", Nam);
-- 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;
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;
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
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
-- 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
-- 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)
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
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
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);
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);
projects / thirdparty / gcc.git / commitdiff
