This patch supresses the finalization of an intermediate copy produced when a
cursor iterates over a collection. The intermediate copy is still finalized
when the associated loop goes out of scope.
------------
-- Source --
------------
-- types.ads
with Ada.Containers.Doubly_Linked_Lists;
package Types is
package Lists is new Ada.Containers.Doubly_Linked_Lists (Integer);
use Lists;
function Get_List (L : List) return List;
procedure Print_List (L : List);
procedure Zero_List (L : in out List) with
Post => (for all Index in Get_List (L) => Element (Index) = 0);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
function Get_List (L : List) return List is
begin
return L;
end Get_List;
procedure Print_List (L : List) is
begin
for Element of Get_List (L) loop
Put_Line (Integer'Image (Element));
end loop;
end Print_List;
procedure Zero_List (L : in out List) is
Result : Lists.List;
begin
for I of L loop
Put_Line (Integer'Image (I));
end loop;
Result.Append (0);
L := Result;
end Zero_List;
end Types;
-- main.adb
with Types; use Types;
procedure Main is
L : Lists.List;
begin
L.Append (111);
L.Append (1234);
L.Append (-9999);
Zero_List (L);
Print_List (L);
end Main;
-----------------
-- Compilation --
-----------------
gnatmake -q -gnat12 -gnata main.adb
---------------------
-- Expected output --
---------------------
111
1234
-9999
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Hristian Kirtchev <[email protected]>
* exp_ch5.adb (Expand_Iterator_Loop): Code cleanup and reorganization.
Set the associated loop as the related expression of internally
generated cursors.
* exp_ch7.adb (Is_Container_Cursor): New routine.
(Wrap_Transient_Declaration): Supress the finalization of the list
controller when the declaration denotes a container cursor.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 177147)
+++ exp_ch5.adb (working copy)
@@ -2859,13 +2859,10 @@
-- with the obvious replacements if "reverse" is specified.
declare
- Element_Type : constant Entity_Id := Etype (Id);
- Pack : constant Entity_Id := Scope (Base_Type (Typ));
- Name_Init : Name_Id;
- Name_Step : Name_Id;
- Cond : Node_Id;
- Cursor_Decl : Node_Id;
- Renaming_Decl : Node_Id;
+ Element_Type : constant Entity_Id := Etype (Id);
+ Pack : constant Entity_Id := Scope (Base_Type (Typ));
+ Name_Init : Name_Id;
+ Name_Step : Name_Id;
begin
Stats := Statements (N);
@@ -2876,52 +2873,24 @@
Cursor := Id;
end if;
+ -- Must verify that the container has a reverse iterator ???
+
if Reverse_Present (I_Spec) then
-
- -- Must verify that the container has a reverse iterator ???
-
Name_Init := Name_Last;
Name_Step := Name_Previous;
-
else
Name_Init := Name_First;
Name_Step := Name_Next;
end if;
- -- C : Cursor_Type := Container.First;
+ -- The code below only handles containers where Element is not a
+ -- primitive operation of the container. This excludes for now the
+ -- Hi-Lite formal containers. Generate:
+ --
+ -- Id : Element_Type renames Container.Element (Cursor);
- Cursor_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cursor,
- Object_Definition =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pack, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Cursor)),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Relocate_Node (Container),
- Selector_Name => Make_Identifier (Loc, Name_Init)));
-
- Insert_Action (N, Cursor_Decl);
-
- -- while C /= No_Element loop
-
- Cond := Make_Op_Ne (Loc,
- Left_Opnd => New_Occurrence_Of (Cursor, Loc),
- Right_Opnd => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_No_Element)));
-
if Of_Present (I_Spec) then
-
- -- Id : Element_Type renames Container.Element (Cursor);
-
- -- The code below only handles containers where Element is not
- -- a primitive operation of the container. This excludes
- -- for now the Hi-Lite formal containers.
-
- Renaming_Decl :=
+ Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
@@ -2934,9 +2903,7 @@
Selector_Name =>
Make_Identifier (Loc, Chars => Name_Element)),
Expressions =>
- New_List (New_Occurrence_Of (Cursor, Loc))));
-
- Prepend (Renaming_Decl, Stats);
+ New_List (New_Occurrence_Of (Cursor, Loc)))));
end if;
-- For both iterator forms, add call to step operation (Next or
@@ -2951,12 +2918,53 @@
Parameter_Associations =>
New_List (New_Occurrence_Of (Cursor, Loc))));
- New_Loop := Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc, Condition => Cond),
- Statements => Stats,
- End_Label => Empty);
+ -- Generate:
+ -- while Cursor /= No_Element loop
+ -- <Stats>
+ -- end loop;
+ New_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Cursor, Loc),
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_No_Element)))),
+ Statements => Stats,
+ End_Label => Empty);
+
+ -- When the cursor is internally generated, associate it with the
+ -- loop statement.
+
+ if Of_Present (I_Spec) then
+ Set_Ekind (Cursor, E_Variable);
+ Set_Related_Expression (Cursor, New_Loop);
+ end if;
+
+ -- Create the declaration of the cursor and insert it before the
+ -- source loop. Generate:
+ --
+ -- C : Cursor_Type := Container.First;
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cursor,
+ Object_Definition =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Pack, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Cursor)),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Relocate_Node (Container),
+ Selector_Name => Make_Identifier (Loc, Name_Init))));
+
-- If the range of iteration is given by a function call that
-- returns a container, the finalization actions have been saved
-- in the Condition_Actions of the iterator. Insert them now at
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 177087)
+++ exp_ch7.adb (working copy)
@@ -1517,9 +1517,10 @@
if Present (Len_Ref) then
Action :=
Make_Implicit_If_Statement (N,
- Condition => Make_Op_Gt (Loc,
- Left_Opnd => Len_Ref,
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Len_Ref,
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
Then_Statements => New_List (Action));
end if;
@@ -3417,15 +3418,45 @@
-- Finalize_One (_v2);
procedure Wrap_Transient_Declaration (N : Node_Id) is
- S : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Next_N : constant Node_Id := Next (N);
+ Enclosing_S : Entity_Id;
+ First_Decl_Loc : Source_Ptr;
LC : Entity_Id := Empty;
Nodes : List_Id;
- Loc : constant Source_Ptr := Sloc (N);
- First_Decl_Loc : Source_Ptr;
- Enclosing_S : Entity_Id;
+ S : Entity_Id;
Uses_SS : Boolean;
- Next_N : constant Node_Id := Next (N);
+ function Is_Container_Cursor (Decl : Node_Id) return Boolean;
+ -- Determine whether object declaration Decl is a cursor used to iterate
+ -- over an Ada 2005/12 container.
+
+ -------------------------
+ -- Is_Container_Cursor --
+ -------------------------
+
+ function Is_Container_Cursor (Decl : Node_Id) return Boolean is
+ Def_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Expr : constant Node_Id := Expression (Decl);
+
+ begin
+ -- A cursor declaration appears in the following form:
+ --
+ -- Index : Pack.Cursor := First (...);
+
+ return
+ Chars (Etype (Def_Id)) = Name_Cursor
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Function_Call
+ and then Chars (Name (Expr)) = Name_First
+ and then
+ (Nkind (Parent (Decl)) = N_Expression_With_Actions
+ or else
+ Nkind (Related_Expression (Def_Id)) = N_Loop_Statement);
+ end Is_Container_Cursor;
+
+ -- Start of processing for Wrap_Transient_Declaration
+
begin
S := Current_Scope;
Enclosing_S := Scope (S);
@@ -3503,6 +3534,29 @@
then
null;
+ -- The declaration of a container cursor is a special context where
+ -- the finalization of the list controller needs to be supressed. In
+ -- the following simplified example:
+ --
+ -- LC : Simple_List_Controller;
+ -- Temp : Ptr_Typ := Container_Creator_Function'Reference;
+ -- Deep_Tag_Attach (Temp, LC);
+ -- Obj : Pack.Cursor := First (Temp.all);
+ -- Finalize (LC);
+ -- <execute the loop>
+ --
+ -- the finalization of the list controller destroys the contents of
+ -- container Temp, and as a result Obj points to nothing. Note that
+ -- Temp will be finalized by the finalization list of the enclosing
+ -- scope.
+
+ elsif Ada_Version >= Ada_2012
+ and then Is_Container_Cursor (N)
+ then
+ null;
+
+ -- Finalize the list controller
+
else
Nodes :=
Make_Final_Call
