If the trigger in a timed entry call is a dispatching primitive, the kind of
dispatching operation being invoked (procedure, protected entry or task entry)
is determined at run-time, and the construct expands into a test in which
the branches execute separate copies of the triggering statements. These copies
must be disjoint, because they may contain local declarations
The following must compile quietly in Ada2005 mode:
with System;
Procedure Addr is
package Buffer is
type Inter is synchronized interface;
procedure Get (Obj : in out Inter) is abstract;
function Data (Obj : Inter) return Integer is abstract;
end Buffer;
use Buffer;
protected type Actor is new Inter with
procedure Get;
function Data return Integer;
end Actor;
type Ptr is access all Actor;
protected body Actor is
procedure Get is begin null; end;
function Data return Integer is begin return 1; end;
end;
subtype Local is Integer;
procedure Produce (Object : access Buffer.Inter'class) is
begin
declare
X : Integer;
Output_Address : System.Address;
begin
select
Object.Get;
Output_Address := X'Address;
declare
Data : Local;
for Data'Address use Output_Address;
begin
Data := Object.Data;
end;
or
delay 1.0;
end select;
end;
end Produce;
begin
null;
end Addr;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-29 Ed Schonberg <schonb...@adacore.com>
* atree.ads, atree.adb (Copy_Separate_List): New function that applies
Copy_Separate_Tree to a list of nodes. Used to create disjoint copies
of statement lists that may contain local declarations.
* exp_ch9.adb (Expand_N_Timed_Entry_Call): Use Copy_Separate_List to
duplicate the triggering statements needed for the expansion of this
construct, when the trigger is a dispatching call to a synchronized
primitive.
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 178155)
+++ exp_ch9.adb (working copy)
@@ -10990,6 +10990,11 @@
-- end if;
-- end if;
-- end;
+ --
+ -- The triggering statement and the timed statements have not been
+ -- analyzed yet (see Analyzed_Timed_Entry_Call). They may contain local
+ -- declarations, and therefore the copies that are made during expansion
+ -- must be disjoint, as for any other inlining.
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@@ -11284,7 +11289,7 @@
-- <timed-statements>
-- end if;
- N_Stats := New_Copy_List_Tree (E_Stats);
+ N_Stats := Copy_Separate_List (E_Stats);
Prepend_To (N_Stats,
Make_If_Statement (Loc,
@@ -11327,7 +11332,7 @@
-- <dispatching-call>;
-- <triggering-statements>
- Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
+ Lim_Typ_Stmts := Copy_Separate_List (E_Stats);
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
-- Generate:
Index: atree.adb
===================================================================
--- atree.adb (revision 178155)
+++ atree.adb (working copy)
@@ -646,6 +646,24 @@
end Copy_Node;
------------------------
+ -- Copy_Separate_List --
+ ------------------------
+
+ function Copy_Separate_List (Source : List_Id) return List_Id is
+ Result : constant List_Id := New_List;
+ Nod : Node_Id;
+
+ begin
+ Nod := First (Source);
+ while Present (Nod) loop
+ Append (Copy_Separate_Tree (Nod), Result);
+ Next (Nod);
+ end loop;
+
+ return Result;
+ end Copy_Separate_List;
+
+ ------------------------
-- Copy_Separate_Tree --
------------------------
@@ -766,8 +784,8 @@
Set_Field4 (New_Id, Possible_Copy (Field4 (New_Id)));
Set_Field5 (New_Id, Possible_Copy (Field5 (New_Id)));
- -- Set Entity field to Empty
- -- Why is this done??? and why is it always right to do it???
+ -- Set Entity field to Empty to ensure that no entity references
+ -- are shared between the two, if the source is already analyzed.
if Nkind (New_Id) in N_Has_Entity
or else Nkind (New_Id) = N_Freeze_Entity
Index: atree.ads
===================================================================
--- atree.ads (revision 178155)
+++ atree.ads (working copy)
@@ -429,16 +429,20 @@
-- Source to be Empty, in which case Relocate_Node simply returns
-- Empty as the result.
+ function Copy_Separate_List (Source : List_Id) return List_Id;
+ -- Apply the following to a list of nodes
+
function Copy_Separate_Tree (Source : Node_Id) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Separate_Tree copies
-- the entire syntactic subtree, including recursively any descendants
-- whose parent field references a copied node (descendants not linked to
-- a copied node by the parent field are also copied.) The parent pointers
-- in the copy are properly set. Copy_Separate_Tree (Empty/Error) returns
- -- Empty/Error. The semantic fields are not copied and the new subtree
- -- does not share any entity with source subtree.
- -- But the code *does* copy semantic fields, and the description above
- -- is in any case unclear on this point ??? (RBKD)
+ -- Empty/Error. The new subtree does not share entities with the source,
+ -- but has new entities with the same name. Most of the time this routine
+ -- is called on an unanalyzed tree, and no semantic information is copied.
+ -- However, to ensure that no entities are shared between the two when the
+ -- source is already analyzed, entity fields in the copy are zeroed out.
procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id);
-- Exchange the contents of two entities. The parent pointers are switched
@@ -449,16 +453,15 @@
-- two entities may be list members.
function Extend_Node (Node : Node_Id) return Entity_Id;
- -- This function returns a copy of its input node with an extension
- -- added. The fields of the extension are set to Empty. Due to the way
- -- extensions are handled (as four consecutive array elements), it may
- -- be necessary to reallocate the node, so that the returned value is
- -- not the same as the input value, but where possible the returned
- -- value will be the same as the input value (i.e. the extension will
- -- occur in place). It is the caller's responsibility to ensure that
- -- any pointers to the original node are appropriately updated. This
- -- function is used only by Sinfo.CN to change nodes into their
- -- corresponding entities.
+ -- This function returns a copy of its input node with an extension added.
+ -- The fields of the extension are set to Empty. Due to the way extensions
+ -- are handled (as four consecutive array elements), it may be necessary
+ -- to reallocate the node, so that the returned value is not the same as
+ -- the input value, but where possible the returned value will be the same
+ -- as the input value (i.e. the extension will occur in place). It is the
+ -- caller's responsibility to ensure that any pointers to the original node
+ -- are appropriately updated. This function is used only by Sinfo.CN to
+ -- change nodes into their corresponding entities.
type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
@@ -475,7 +478,7 @@
-- the results of Process calls. See below for details.
generic
- with function Process (N : Node_Id) return Traverse_Result is <>;
+ with function Process (N : Node_Id) return Traverse_Result is <>;
function Traverse_Func (Node : Node_Id) return Traverse_Final_Result;
-- This is a generic function that, given the parent node for a subtree,
-- traverses all syntactic nodes of this tree, calling the given function
@@ -501,7 +504,7 @@
-- all calls to process returned either OK, OK_Orig, or Skip).
generic
- with function Process (N : Node_Id) return Traverse_Result is <>;
+ with function Process (N : Node_Id) return Traverse_Result is <>;
procedure Traverse_Proc (Node : Node_Id);
pragma Inline (Traverse_Proc);
-- This is the same as Traverse_Func except that no result is returned,
