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

[multiple changes] 

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.

From-SVN: r212719
This commit is contained in:
Arnaud Charlet 2014-07-17 08:19:52 +02:00
parent f65c67d340
commit 3629577991
19 changed files with 323 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gcc/ada/ChangeLog
View File

@ -1,3 +1,59 @@
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):

16
gcc/ada/einfo.adb
View File

@ -384,7 +384,6 @@ package body Einfo is
-- 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
@ -564,6 +563,8 @@ package body Einfo is
-- (unused) Flag2
-- (unused) Flag3
-- (unused) Flag110
-- (unused) Flag269
-- (unused) Flag270
@ -1443,12 +1444,6 @@ package body Einfo is
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);
@ -4150,12 +4145,6 @@ package body Einfo is
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);
@ -8188,7 +8177,6 @@ package body Einfo is
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));

11
gcc/ada/einfo.ads
View File

@ -1528,11 +1528,6 @@ package Einfo is
-- 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.
@ -5951,7 +5946,6 @@ package Einfo is
-- 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)
@ -5983,7 +5977,6 @@ package Einfo is
-- 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)
@ -6488,7 +6481,6 @@ package Einfo is
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;
@ -7114,7 +7106,6 @@ package Einfo is
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);
@ -7853,7 +7844,6 @@ package Einfo is
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);
@ -8326,7 +8316,6 @@ package Einfo is
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);

8
gcc/ada/exp_ch11.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -1960,9 +1960,11 @@ package body Exp_Ch11 is
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

29
gcc/ada/exp_ch6.adb
View File

@ -7150,6 +7150,26 @@ package body Exp_Ch6 is
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 @@ package body Exp_Ch6 is
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 @@ package body Exp_Ch6 is
return;
end if;
Freeze_Called_Function;
Build_Protected_Subprogram_Call (N,
Name => Name (N),
Rec => Rec,
@ -7189,13 +7211,6 @@ package body Exp_Ch6 is
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.

195
gcc/ada/exp_ch7.adb
View File

@ -150,6 +150,9 @@ package body Exp_Ch7 is
-- ??? 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
end;
end if;
Append_List_To (Stmts, Additional_Cleanup);
return Stmts;
end Build_Cleanup_Statements;
@ -792,9 +802,7 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 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;
@ -3691,6 +3677,9 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
------------------------------------
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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
-- 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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
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,20 +7889,17 @@ package body Exp_Ch7 is
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));
@ -7903,7 +7908,22 @@ package body Exp_Ch7 is
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 @@ package body Exp_Ch7 is
-----------------------------------
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;
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;
Analyze_List (L);
end if;
Store_Actions_In_Scope (Before, L);
end Store_Before_Actions_In_Scope;
-----------------------------------
-- Store_Cleanup_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 --
--------------------------------

4
gcc/ada/exp_ch7.ads
View File

@ -302,6 +302,10 @@ package Exp_Ch7 is
-- 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.

17
gcc/ada/exp_disp.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -6209,9 +6209,8 @@ package body Exp_Disp is
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);
@ -6226,16 +6225,16 @@ package body Exp_Disp is
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;
@ -6810,12 +6809,10 @@ package body Exp_Disp is
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

81
gcc/ada/exp_smem.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -129,63 +129,66 @@ package body Exp_Smem is
-------------------------------
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
Insert_After_And_Analyze (Inode,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Vnm))));
-- Now for a procedure call, but not a function call, insert the
-- call to write the object just before the unlock.
if Nkind (N) = N_Procedure_Call_Statement then
Insert_After_And_Analyze (Inode,
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 (New_Occurrence_Of (Vid, Loc))));
Store_Cleanup_Actions_In_Scope (Aft);
if Nkind (N) = N_Procedure_Call_Statement then
Wrap_Transient_Statement (N);
else
Wrap_Transient_Expression (N);
end if;
end Add_Shared_Var_Lock_Procs;
---------------------

9
gcc/ada/exp_smem.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -44,9 +44,10 @@ package Exp_Smem is
-- 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.

21
gcc/ada/exp_util.adb
View File

@ -4214,7 +4214,8 @@ package body Exp_Util is
(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.
@ -4233,12 +4234,22 @@ package body Exp_Util is
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

7
gcc/ada/expander.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -119,10 +119,7 @@ package body Expander is
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;

17
gcc/ada/sem.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -450,6 +450,11 @@ package Sem is
-- 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 @@ package Sem is
-- 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

10
gcc/ada/sem_aux.adb
View File

@ -602,6 +602,16 @@ package body Sem_Aux is
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 --
------------------

5
gcc/ada/sem_aux.ads
View File

@ -251,6 +251,11 @@ package Sem_Aux is
-- 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.

4
gcc/ada/sem_ch13.adb
View File

@ -4353,9 +4353,7 @@ package body Sem_Ch13 is
("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);

8
gcc/ada/sem_ch8.adb
View File

@ -7541,10 +7541,7 @@ package body Sem_Ch8 is
-- 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 @@ package body Sem_Ch8 is
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;

16
gcc/ada/sinfo.adb
View File

@ -432,6 +432,14 @@ package body Sinfo is
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 @@ package body Sinfo is
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

13
gcc/ada/sinfo.ads
View File

@ -832,6 +832,10 @@ package Sinfo is
-- 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 @@ package Sinfo is
-- 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 @@ package Sinfo is
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 @@ package Sinfo is
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 @@ package Sinfo is
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 @@ package Sinfo is
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);