[Ada] Finalizable iterators for Ada 2012 containers

Message ID	20111123135237.GA6932@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-308417-incoming=patchwork.ozlabs.org@gcc.gnu.org> Date: Wed, 23 Nov 2011 08:52:37 -0500 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev <kirtchev@adacore.com> Subject: [Ada] Finalizable iterators for Ada 2012 containers Message-ID: <20111123135237.GA6932@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="k+w/mQv8wyuph6w0" 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 Sender: gcc-patches-owner@gcc.gnu.org

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;

[Ada] Finalizable iterators for Ada 2012 containers

Commit Message

Patch