From patchwork Wed Nov 23 13:52:37 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 127312 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 826BB1007D4 for ; Thu, 24 Nov 2011 00:53:41 +1100 (EST) Received: (qmail 29611 invoked by alias); 23 Nov 2011 13:53:38 -0000 Received: (qmail 29030 invoked by uid 22791); 23 Nov 2011 13:53:10 -0000 X-SWARE-Spam-Status: No, hits=2.5 required=5.0 tests=AWL, BAYES_50, FILL_THIS_FORM, FILL_THIS_FORM_LOAN, TBC X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 23 Nov 2011 13:52:38 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 627512BB3A9; Wed, 23 Nov 2011 08:52:37 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id cNCTemGRYR5R; Wed, 23 Nov 2011 08:52:37 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 440242BB3A3; Wed, 23 Nov 2011 08:52:37 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 3732492BF6; Wed, 23 Nov 2011 08:52:37 -0500 (EST) Date: Wed, 23 Nov 2011 08:52:37 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Finalizable iterators for Ada 2012 containers Message-ID: <20111123135237.GA6932@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch implements finalizable iterators over Ada 2012 containers as defined in AI-20302. An iterator must render its related container "busy" when created either explicitly by calling Iterate or obtained through an iterator loop. When an iterator goes out of scope, the related container is no longer considered "busy" and normal element manipulation may be carried out. ------------ -- Source -- ------------ with Ada.Containers; use Ada.Containers; with Ada.Containers.Doubly_Linked_Lists; with Ada.Text_IO; use Ada.Text_IO; procedure Main is type Element is record Comp : Integer := 1234; end record; package DLL is new Ada.Containers.Doubly_Linked_Lists (Element_Type => Element, "=" => "="); List : DLL.List; begin DLL.Append (List, Element'(Comp => 1)); DLL.Append (List, Element'(Comp => 2)); DLL.Append (List, Element'(Comp => 3)); begin declare Iter : DLL.List_Iterator_Interfaces.Reversible_Iterator'Class := DLL.Iterate (List); begin DLL.Delete_First (List); exception when Program_Error => Put_Line ("DLL OK"); when others => Put_Line ("ERROR: DLL iterate"); end; DLL.Delete_First (List); exception when others => Put_Line ("ERROR: DLL should not be busy"); end; end Main; ----------------- -- Compilation -- ----------------- gnatmake -q -gnat12 main.adb ----------------------------------- -- Execution and expected output -- ----------------------------------- $./main $DLL OK Tested on x86_64-pc-linux-gnu, committed on trunk 2011-11-23 Hristian Kirtchev * a-comutr.adb, a-coorma.adb, a-coorse.adb, a-convec.adb, a-cihase.adb, a-cimutr.adb, a-coinve.adb, a-ciorma.adb, a-ciorse.adb, a-cobove.adb, a-cohama.adb, a-cihama.adb, a-cidlli.adb, a-cdlili.adb, a-cbhama.adb, a-cbhase.adb, a-cbmutr.adb, a-cborma.adb, a-cborse.adb, a-cbdlli.adb: Add with and use clause for Ada.Finalization. Type Iterator and Child_Iterator are now derived from Limited_Controlled. (Finalize): New routine. (Iterate): Add a renaming of counter Busy and increment it. Update the return aggregate. (Iterate_Children): Add a renaming of counter Busy and increment it. Update the return aggregate. (Iterate_Subtree): Add a renaming of counter Busy and increment it. Update the return aggregate. * a-cdlili.ads, a-cidlli.ads: Type List_Access is now a general access type. * a-cihama.ads: Type Map_Access is now a general access type. * a-comutr.ads, a-cimutr.ads: Use type Natural for the two locks associated with the tree. * a-cohama.ads: Type Map_Access is now a general access type. * a-coinve.ads, a-convec.ads: Type Vector_Access is now a general access type. * exp_ch5.adb (Expand_Iterator_Loop): Do not create a block to wrap the loop as this is done at an earlier step, during analysis. The declarations of the iterator and the cursor use the usual Insert_Action mechanism when added into the tree. * sem_ch5.adb (Analyze_Loop_Statement): Remove local constant Loop_Statement and replace all respective uses by N. Add local constant Loc. Preanalyze the loop iterator to discover whether it is a container iterator and if it is, wrap the loop in a block. This ensures that any controlled temporaries produced by the iteration scheme share the same lifetime of the loop. (Is_Container_Iterator): New routine. (Is_Wrapped_In_Block): New routine. (Pre_Analyze_Range): Move spec and body to the library level. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 181662) +++ exp_ch5.adb (working copy) @@ -3233,7 +3233,7 @@ Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Pack, Loc), Selector_Name => - Make_Identifier (Loc, Name_Has_Element)), + Make_Identifier (Loc, Name_Has_Element)), Parameter_Associations => New_List ( @@ -3250,21 +3250,19 @@ -- I : Iterator_Type renames Container; -- C : Pack.Cursor_Type := Container.[First | Last]; - declare - Decl1 : Node_Id; - Decl2 : Node_Id; - Decl3 : Node_Id; + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Iterator, + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec)))); - begin - Decl1 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Iterator, - Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), - Name => Relocate_Node (Name (I_Spec))); + -- Create declaration for cursor - -- Create declaration for cursor + declare + Decl : Node_Id; - Decl2 := + begin + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Cursor, Object_Definition => @@ -3275,31 +3273,14 @@ Selector_Name => Make_Identifier (Loc, Name_Init))); - Set_Assignment_OK (Decl2); - -- The cursor is only modified in expanded code, so it appears -- as unassigned to the warning machinery. We must suppress -- this spurious warning explicitly. - Decl3 := - Make_Pragma (Loc, - Chars => Name_Warnings, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Off)), - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Cursor, Loc)))); + Set_Warnings_Off (Cursor); + Set_Assignment_OK (Decl); - -- The expanded loop is wrapped in a block, to make the loop - -- variable local. - - New_Loop := - Make_Block_Statement (Loc, - Declarations => New_List (Decl1, Decl2, Decl3), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (New_Loop))); + Insert_Action (N, Decl); end; -- If the range of iteration is given by a function call that Index: a-cdlili.adb =================================================================== --- a-cdlili.adb (revision 181667) +++ a-cdlili.adb (working copy) @@ -27,18 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; - with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Doubly_Linked_Lists is - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -396,6 +398,22 @@ return Position.Node.Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -422,7 +440,7 @@ while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -441,7 +459,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -857,9 +875,7 @@ (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -867,7 +883,7 @@ begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -882,6 +898,8 @@ function Iterate (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -893,12 +911,20 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : List; Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -932,7 +958,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -945,7 +977,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1412,7 +1444,7 @@ while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1439,7 +1471,7 @@ begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; Index: a-cdlili.ads =================================================================== --- a-cdlili.ads (revision 181662) +++ a-cdlili.ads (working copy) @@ -306,7 +306,7 @@ for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is Index: a-cihama.adb =================================================================== --- a-cihama.adb (revision 181662) +++ a-cihama.adb (working copy) @@ -34,7 +34,6 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Maps is @@ -45,11 +44,14 @@ procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is limited new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -421,6 +423,18 @@ HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -433,7 +447,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -471,7 +485,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is @@ -687,10 +701,10 @@ procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing Iterate @@ -711,8 +725,15 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cihama.ads =================================================================== --- a-cihama.ads (revision 181662) +++ a-cihama.ads (working copy) @@ -341,11 +341,10 @@ use HT_Types; use Ada.Finalization; - overriding procedure Adjust (Container : in out Map); - + overriding procedure Adjust (Container : in out Map); overriding procedure Finalize (Container : in out Map); - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record Index: a-coinve.adb =================================================================== --- a-coinve.adb (revision 181662) +++ a-coinve.adb (working copy) @@ -29,7 +29,7 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is @@ -39,16 +39,18 @@ procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record Container : Vector_Access; Index : Index_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -1105,6 +1107,18 @@ end; end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1129,7 +1143,7 @@ if Container.Elements.EA (J) /= null and then Container.Elements.EA (J).all = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -1167,7 +1181,7 @@ return No_Element; end if; - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is @@ -1982,7 +1996,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2018,7 +2032,8 @@ begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= + Vector_Access'(Container'Unrestricted_Access) then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2029,7 +2044,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2051,7 +2066,7 @@ Insert (Container, Index, New_Item); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2064,7 +2079,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2101,7 +2116,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2112,7 +2127,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2134,7 +2149,7 @@ Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; ------------------ @@ -2465,7 +2480,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2476,7 +2491,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2498,7 +2513,7 @@ Insert_Space (Container, Index, Count); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2518,15 +2533,14 @@ (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2540,9 +2554,16 @@ function Iterate (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2550,10 +2571,16 @@ Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2566,7 +2593,7 @@ return No_Element; end if; - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -3313,7 +3340,7 @@ begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -3330,7 +3357,7 @@ if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -3376,7 +3403,7 @@ begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3491,7 +3518,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Index); + return Cursor'(Container'Unrestricted_Access, Index); end To_Cursor; -------------- Index: a-coinve.ads =================================================================== --- a-coinve.ads (revision 181662) +++ a-coinve.ads (working copy) @@ -426,7 +426,7 @@ for Vector'Read use Read; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 181662) +++ sem_ch5.adb (working copy) @@ -75,6 +75,14 @@ -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + procedure Pre_Analyze_Range (R_Copy : Node_Id); + -- Determine expected type of range or domain of iteration of Ada 2012 + -- loop by analyzing separate copy. Do the analysis and resolution of the + -- copy of the bound(s) with expansion disabled, to prevent the generation + -- of finalization actions. This prevents memory leaks when the bounds + -- contain calls to functions returning controlled arrays or when the + -- domain of iteration is a container. + ------------------------ -- Analyze_Assignment -- ------------------------ @@ -1618,90 +1626,6 @@ -- calls that use the secondary stack, returning True if any such call -- is found, and False otherwise. - procedure Pre_Analyze_Range (R_Copy : Node_Id); - -- Determine expected type of range or domain of iteration of Ada 2012 - -- loop by analyzing separate copy. Do the analysis and resolution of - -- the copy of the bound(s) with expansion disabled, to prevent the - -- generation of finalization actions. This prevents memory leaks when - -- the bounds contain calls to functions returning controlled arrays or - -- when the domain of iteration is a container. - - ----------------------- - -- Pre_Analyze_Range -- - ----------------------- - - procedure Pre_Analyze_Range (R_Copy : Node_Id) is - Save_Analysis : Boolean; - begin - Save_Analysis := Full_Analysis; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - Analyze (R_Copy); - - if Nkind (R_Copy) in N_Subexpr - and then Is_Overloaded (R_Copy) - then - - -- Apply preference rules for range of predefined integer types, - -- or diagnose true ambiguity. - - declare - I : Interp_Index; - It : Interp; - Found : Entity_Id := Empty; - - begin - Get_First_Interp (R_Copy, I, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then - if No (Found) then - Found := It.Typ; - else - if Scope (Found) = Standard_Standard then - null; - - elsif Scope (It.Typ) = Standard_Standard then - Found := It.Typ; - - else - -- Both of them are user-defined - - Error_Msg_N - ("ambiguous bounds in range of iteration", - R_Copy); - Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\\} ", R_Copy, Found); - Error_Msg_NE ("\\} ", R_Copy, It.Typ); - exit; - end if; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - if Is_Entity_Name (R_Copy) - and then Is_Type (Entity (R_Copy)) - then - - -- Subtype mark in iteration scheme - - null; - - elsif Nkind (R_Copy) in N_Subexpr then - - -- Expression in range, or Ada 2012 iterator - - Resolve (R_Copy); - end if; - - Expander_Mode_Restore; - Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; - -------------------- -- Process_Bounds -- -------------------- @@ -1855,7 +1779,7 @@ if New_Lo_Bound /= Lo and then Is_Static_Expression (New_Lo_Bound) then - Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); + Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); end if; if New_Hi_Bound /= Hi @@ -2034,7 +1958,7 @@ begin if Present (H) and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) + Enclosing_Dynamic_Scope (Id) and then Ekind (H) = E_Variable and then Is_Discrete_Type (Etype (H)) then @@ -2059,7 +1983,7 @@ then Process_Bounds (DS); - -- expander not active or else range of iteration is a subtype + -- Expander not active or else range of iteration is a subtype -- indication, an entity, or a function call that yields an -- aggregate or a container. @@ -2513,12 +2437,95 @@ ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is - Loop_Statement : constant Node_Id := N; - Id : constant Node_Id := Identifier (Loop_Statement); - Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + function Is_Container_Iterator (Iter : Node_Id) return Boolean; + -- Given a loop iteration scheme, determine whether it is an Ada 2012 + -- container iteration. + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean; + -- Determine whether node N is the sole statement of a block + + --------------------------- + -- Is_Container_Iterator -- + --------------------------- + + function Is_Container_Iterator (Iter : Node_Id) return Boolean is + begin + -- Infinite loop + + if No (Iter) then + return False; + + -- While loop + + elsif Present (Condition (Iter)) then + return False; + + -- for Def_Id in [reverse] Name loop + -- for Def_Id [: Subtype_Indication] of [reverse] Name loop + + elsif Present (Iterator_Specification (Iter)) then + declare + Nam : constant Node_Id := Name (Iterator_Specification (Iter)); + Nam_Copy : Node_Id; + + begin + Nam_Copy := New_Copy_Tree (Nam); + Set_Parent (Nam_Copy, Parent (Nam)); + Pre_Analyze_Range (Nam_Copy); + + -- The only two options here are iteration over a container or + -- an array. + + return not Is_Array_Type (Etype (Nam_Copy)); + end; + + -- for Def_Id in [reverse] Discrete_Subtype_Definition loop + + else + declare + LP : constant Node_Id := Loop_Parameter_Specification (Iter); + DS : constant Node_Id := Discrete_Subtype_Definition (LP); + DS_Copy : Node_Id; + + begin + DS_Copy := New_Copy_Tree (DS); + Set_Parent (DS_Copy, Parent (DS)); + Pre_Analyze_Range (DS_Copy); + + -- Check for a call to Iterate () + + return + Nkind (DS_Copy) = N_Function_Call + and then Needs_Finalization (Etype (DS_Copy)); + end; + end if; + end Is_Container_Iterator; + + ------------------------- + -- Is_Wrapped_In_Block -- + ------------------------- + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean is + HSS : constant Node_Id := Parent (N); + + begin + return + Nkind (HSS) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (HSS)) = N_Block_Statement + and then First (Statements (HSS)) = N + and then No (Next (First (Statements (HSS)))); + end Is_Wrapped_In_Block; + + -- Local declarations + + Id : constant Node_Id := Identifier (N); + Iter : constant Node_Id := Iteration_Scheme (N); + Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + -- Start of processing for Analyze_Loop_Statement + begin if Present (Id) then @@ -2534,15 +2541,13 @@ if No (Ent) then if Total_Errors_Detected /= 0 then - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); else raise Program_Error; end if; else - Generate_Reference (Ent, Loop_Statement, ' '); + Generate_Reference (Ent, N, ' '); Generate_Definition (Ent); -- If we found a label, mark its type. If not, ignore it, since it @@ -2555,7 +2560,7 @@ Set_Ekind (Ent, E_Loop); if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then - Set_Label_Construct (Parent (Ent), Loop_Statement); + Set_Label_Construct (Parent (Ent), N); end if; end if; end if; @@ -2563,13 +2568,30 @@ -- Case of no identifier present else - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Loop_Statement); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, N); end if; + -- Iteration over a container in Ada 2012 involves the creation of a + -- controlled iterator object. Wrap the loop in a block to ensure the + -- timely finalization of the iterator and release of container locks. + + if Ada_Version >= Ada_2012 + and then Is_Container_Iterator (Iter) + and then not Is_Wrapped_In_Block (N) + then + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (N))))); + + Analyze (N); + return; + end if; + -- Kill current values on entry to loop, since statements in the body of -- the loop may have been executed before the loop is entered. Similarly -- we kill values after the loop, since we do not know that the body of @@ -2610,7 +2632,7 @@ end; end if; - Analyze_Statements (Statements (Loop_Statement)); + Analyze_Statements (Statements (N)); end if; -- Finish up processing for the loop. We kill all current values, since @@ -2619,7 +2641,7 @@ -- know will execute at least once, but it's not worth the trouble and -- the front end is not in the business of flow tracing. - Process_End_Label (Loop_Statement, 'e', Ent); + Process_End_Label (N, 'e', Ent); End_Scope; Kill_Current_Values; @@ -2871,4 +2893,76 @@ end if; end Check_Unreachable_Code; + ----------------------- + -- Pre_Analyze_Range -- + ----------------------- + + procedure Pre_Analyze_Range (R_Copy : Node_Id) is + Save_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Nkind (R_Copy) in N_Subexpr + and then Is_Overloaded (R_Copy) + then + -- Apply preference rules for range of predefined integer types, or + -- diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + -- Subtype mark in iteration scheme + + if Is_Entity_Name (R_Copy) + and then Is_Type (Entity (R_Copy)) + then + null; + + -- Expression in range, or Ada 2012 iterator + + elsif Nkind (R_Copy) in N_Subexpr then + Resolve (R_Copy); + end if; + + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + end Pre_Analyze_Range; + end Sem_Ch5; Index: a-ciorse.adb =================================================================== --- a-ciorse.adb (revision 181666) +++ a-ciorse.adb (working copy) @@ -37,21 +37,22 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -571,6 +572,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1254,7 +1271,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1275,8 +1292,10 @@ function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1288,14 +1307,22 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1330,7 +1357,13 @@ -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- Index: a-coorma.adb =================================================================== --- a-coorma.adb (revision 181662) +++ a-coorma.adb (working copy) @@ -39,16 +39,18 @@ package body Ada.Containers.Ordered_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -488,6 +490,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -839,6 +857,8 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -850,12 +870,20 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Map; Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -890,7 +918,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cborma.adb =================================================================== --- a-cborma.adb (revision 181662) +++ a-cborma.adb (working copy) @@ -35,20 +35,23 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Count_Type; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -551,6 +554,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -900,6 +919,8 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -911,7 +932,13 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Container.First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -919,9 +946,10 @@ Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - - -- iterator was defined to behave the same as for a complete iterator, + -- Iterator was defined to behave the same as for a complete iterator, -- and iterate over the entire sequence of items. However, those -- semantics were unintuitive and arguably error-prone (it is too easy -- to accidentally create an endless loop), and so they were changed, @@ -953,7 +981,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration.) - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cidlli.adb =================================================================== --- a-cidlli.adb (revision 181667) +++ a-cidlli.adb (working copy) @@ -27,24 +27,26 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -429,6 +431,22 @@ return Position.Node.Element.all; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -459,7 +477,7 @@ while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -478,7 +496,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is @@ -884,9 +902,7 @@ (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -894,7 +910,7 @@ begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -908,8 +924,10 @@ function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class + return List_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -921,7 +939,13 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -929,6 +953,8 @@ Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -962,7 +988,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -975,7 +1007,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -1452,7 +1484,7 @@ while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1479,7 +1511,7 @@ begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; exception Index: a-cidlli.ads =================================================================== --- a-cidlli.ads (revision 181662) +++ a-cidlli.ads (working copy) @@ -309,7 +309,7 @@ for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is Index: a-cimutr.adb =================================================================== --- a-cimutr.adb (revision 181662) +++ a-cimutr.adb (working copy) @@ -28,35 +28,41 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Previous - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Last (Object : Child_Iterator) return Cursor; @@ -925,6 +931,34 @@ return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1304,8 +1338,7 @@ (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1326,13 +1359,19 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1349,7 +1388,7 @@ end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1396,9 +1435,16 @@ Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1409,8 +1455,17 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1423,7 +1478,7 @@ end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1789,8 +1844,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2052,7 +2107,7 @@ end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2555,8 +2610,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; Index: a-cimutr.ads =================================================================== --- a-cimutr.ads (revision 181662) +++ a-cimutr.ads (working copy) @@ -327,8 +327,8 @@ type Tree is new Controlled with record Root : aliased Tree_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; Index: a-cihase.adb =================================================================== --- a-cihase.adb (revision 181666) +++ a-cihase.adb (working copy) @@ -36,16 +36,18 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Containers.Prime_Numbers; +with System; use type System.Address; -with System; use type System.Address; - package body Ada.Containers.Indefinite_Hashed_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Forward_Iterator with record - Container : Set_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -569,6 +571,18 @@ HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -988,7 +1002,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -1007,9 +1021,17 @@ end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; ------------ @@ -1897,7 +1919,7 @@ Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; Free (X); @@ -1915,7 +1937,7 @@ begin if Node = null then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element.all; Index: a-cohama.adb =================================================================== --- a-cohama.adb (revision 181662) +++ a-cohama.adb (working copy) @@ -39,11 +39,14 @@ package body Ada.Containers.Hashed_Maps is - type Iterator is limited new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -385,6 +388,18 @@ HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -397,7 +412,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -435,7 +450,7 @@ return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is @@ -546,7 +561,7 @@ HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -588,7 +603,7 @@ HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -638,10 +653,10 @@ procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -662,8 +677,15 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cohama.ads =================================================================== --- a-cohama.ads (revision 181662) +++ a-cohama.ads (working copy) @@ -384,7 +384,7 @@ for Map'Read use Read; - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record Index: a-coorse.adb =================================================================== --- a-coorse.adb (revision 181666) +++ a-coorse.adb (working copy) @@ -42,16 +42,18 @@ package body Ada.Containers.Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -512,6 +514,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1160,7 +1178,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1182,6 +1200,8 @@ function Iterate (Container : Set) return Set_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1193,12 +1213,19 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null); end Iterate; function Iterate (Container : Set; Start : Cursor) return Set_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1233,7 +1260,12 @@ -- the start position has the same value irrespective of whether this is -- a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node); end Iterate; ---------- Index: a-cbhama.adb =================================================================== --- a-cbhama.adb (revision 181662) +++ a-cbhama.adb (working copy) @@ -34,15 +34,19 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Maps is - type Iterator is new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -392,6 +396,22 @@ HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -649,7 +669,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -670,8 +690,15 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cborse.adb =================================================================== --- a-cborse.adb (revision 181666) +++ a-cborse.adb (working copy) @@ -38,20 +38,23 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - type Iterator is limited new - Set_Iterator_Interfaces.Reversible_Iterator with record - Container : Set_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Count_Type; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -568,6 +571,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1221,8 +1240,10 @@ end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1234,12 +1255,20 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1274,7 +1303,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration.) - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- Index: a-comutr.adb =================================================================== --- a-comutr.adb (revision 181662) +++ a-comutr.adb (working copy) @@ -29,28 +29,34 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next (Object : Child_Iterator; @@ -898,6 +904,34 @@ return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1342,8 +1376,7 @@ (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1364,13 +1397,19 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1387,7 +1426,7 @@ end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1434,9 +1473,16 @@ Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1447,8 +1493,17 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1461,7 +1516,7 @@ end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1807,8 +1862,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2060,7 +2115,7 @@ end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2578,8 +2633,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; Index: a-comutr.ads =================================================================== --- a-comutr.ads (revision 181662) +++ a-comutr.ads (working copy) @@ -372,8 +372,8 @@ type Tree is new Controlled with record Root : aliased Root_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; Index: a-ciorma.adb =================================================================== --- a-ciorma.adb (revision 181662) +++ a-ciorma.adb (working copy) @@ -40,16 +40,18 @@ package body Ada.Containers.Indefinite_Ordered_Maps is pragma Suppress (All_Checks); - type Iterator is limited new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - overriding function Next (Object : Iterator; Position : Cursor) return Cursor; @@ -535,6 +537,22 @@ end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -857,7 +875,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; -- Start of processing for Iterate @@ -878,6 +896,8 @@ function Iterate (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -889,7 +909,13 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => null); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -897,6 +923,8 @@ Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -931,7 +959,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- Index: a-cobove.adb =================================================================== --- a-cobove.adb (revision 181662) +++ a-cobove.adb (working copy) @@ -28,17 +28,20 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; - +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Vectors is - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record - Container : Vector_Access; - Index : Index_Type; - end record; + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type; + end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -658,6 +661,22 @@ end if; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1607,8 +1626,7 @@ (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1630,8 +1648,16 @@ (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Index_Type'First); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1639,8 +1665,16 @@ Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Start.Index); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- Index: a-convec.adb =================================================================== --- a-convec.adb (revision 181662) +++ a-convec.adb (working copy) @@ -29,7 +29,6 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Vectors is @@ -37,12 +36,15 @@ procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with record Container : Vector_Access; Index : Index_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; overriding function Next @@ -778,6 +780,18 @@ Free (X); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -800,7 +814,7 @@ for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -835,7 +849,7 @@ if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end if; end First; @@ -1500,7 +1514,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1536,7 +1550,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1547,7 +1561,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1569,7 +1583,7 @@ Insert (Container, Index, New_Item); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -1582,7 +1596,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1619,7 +1633,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1630,7 +1644,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1652,7 +1666,7 @@ Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2036,7 +2050,7 @@ begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2047,7 +2061,7 @@ then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2069,7 +2083,7 @@ Insert_Space (Container, Index, Count => Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2089,15 +2103,14 @@ (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2112,9 +2125,16 @@ (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2122,9 +2142,16 @@ Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2136,7 +2163,7 @@ if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end if; end Last; @@ -2903,7 +2930,7 @@ begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -2915,7 +2942,7 @@ for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -2960,7 +2987,7 @@ begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3061,7 +3088,7 @@ if Index not in Index_Type'First .. Container.Last then return No_Element; else - return (Container'Unchecked_Access, Index); + return (Container'Unrestricted_Access, Index); end if; end To_Cursor; Index: a-convec.ads =================================================================== --- a-convec.ads (revision 181662) +++ a-convec.ads (working copy) @@ -410,7 +410,7 @@ Lock : Natural := 0; end record; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record Index: a-cbdlli.adb =================================================================== --- a-cbdlli.adb (revision 181667) +++ a-cbdlli.adb (working copy) @@ -27,16 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is - type Iterator is limited new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Count_Type; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Count_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -494,6 +498,22 @@ return Position.Container.Nodes (Position.Node).Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1064,9 +1084,7 @@ (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Count_Type := Container.First; begin @@ -1091,6 +1109,8 @@ (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- The value of the Node component influences the behavior of the First -- and Last selector functions of the iterator object. When the Node @@ -1102,7 +1122,13 @@ -- Note: For a forward iterator, Container.First is the beginning, and -- for a reverse iterator, Container.Last is the beginning. - return Iterator'(Container'Unrestricted_Access, Node => 0); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1110,6 +1136,8 @@ Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin -- It was formerly the case that when Start = No_Element, the partial -- iterator was defined to behave the same as for a complete iterator, @@ -1143,7 +1171,13 @@ -- the start position has the same value irrespective of whether this -- is a forward or reverse iteration. - return Iterator'(Container'Unrestricted_Access, Node => Start.Node); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- Index: a-cbmutr.adb =================================================================== --- a-cbmutr.adb (revision 181662) +++ a-cbmutr.adb (working copy) @@ -27,30 +27,38 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; + package body Ada.Containers.Bounded_Multiway_Trees is No_Node : constant Count_Type'Base := -1; - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next @@ -1229,6 +1237,34 @@ Right_Subtree => Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1732,8 +1768,7 @@ (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin if Container.Count = 0 then @@ -1758,13 +1793,19 @@ function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1786,9 +1827,9 @@ end if; declare + B : Natural renames Parent.Container.Busy; + C : Count_Type; NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; - C : Count_Type; begin B := B + 1; @@ -1836,9 +1877,16 @@ Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1849,8 +1897,17 @@ (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1869,7 +1926,7 @@ declare T : Tree renames Position.Container.all; - B : Integer renames T.Busy; + B : Natural renames T.Busy; begin B := B + 1; @@ -2259,8 +2316,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2529,7 +2586,7 @@ declare NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Count_Type; begin @@ -3209,8 +3266,8 @@ declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; Index: a-cbhase.adb =================================================================== --- a-cbhase.adb (revision 181666) +++ a-cbhase.adb (working copy) @@ -34,15 +34,20 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Sets is - type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record Container : Set_Access; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -569,6 +574,22 @@ HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -887,7 +908,7 @@ Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -906,9 +927,16 @@ end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container => Container'Unrestricted_Access); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access); end Iterate; ------------ @@ -1600,7 +1628,7 @@ begin if Node = 0 then - raise Constraint_Error with "key not in map"; -- ??? "set" + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Container.Nodes (Node).Element;