diff options
| author | Matthew Heaney <heaney@adacore.com> | 2005-06-16 10:56:24 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-06-16 10:56:24 +0200 |
| commit | 8704d4b30e3eace58fc9506cf3533b15835c784a (patch) | |
| tree | 60bbc3a40631ce4a825ff74330cd04720cf0d624 /gcc/ada | |
| parent | dc8f57914cb54a209cf2d52bb04d21502990842b (diff) | |
| download | gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.zip gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.tar.gz gcc-8704d4b30e3eace58fc9506cf3533b15835c784a.tar.bz2 | |
a-swunha.ads, [...]: Removed.
2005-06-14 Matthew Heaney <heaney@adacore.com>
* a-swunha.ads, a-swunha.adb: Removed. Replaced by a-swuwha.ad[sb]
* a-swuwha.ads, a-swuwha.adb: New files
* a-szunha.ads, a-szunha.adb: Removed, replaced by a-szuzha.ad[sb]
* a-szuzha.ads, a-szuzha.adb: New files.
* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,
a-crbtgk.adb, a-crbltr.ads, a-coorse.ads, a-coorse.adb, a-convec.ads,
a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohata.ads, a-cohama.ads,
a-cohama.adb, a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb,
a-cidlli.ads, a-cidlli.adb, a-chtgop.ads, a-chtgop.adb, a-cdlili.ads,
a-cdlili.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb,
a-cohase.ads, a-ciorma.ads, a-coorma.ads, a-ciormu.ads, a-coormu.ads,
a-swunha.adb, a-stunha.adb, a-ciorma.adb, a-coorma.adb, a-shcain.ads,
a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, a-stwiha.adb,
a-strhas.adb, a-stzhas.adb: synchronized to the latest version of the
Ada 2005 RM.
From-SVN: r101069
Diffstat (limited to 'gcc/ada')
49 files changed, 10382 insertions, 7076 deletions
diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 435679d..a9801e2 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.DOUBLY_LINKED_LISTS -- +-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -45,10 +45,6 @@ package body Ada.Containers.Doubly_Linked_Lists is -- Local Subprograms -- ----------------------- - procedure Delete_Node - (Container : in out List; - Node : in out Node_Access); - procedure Insert_Internal (Container : in out List; Before : Node_Access; @@ -88,38 +84,42 @@ package body Ada.Containers.Doubly_Linked_Lists is ------------ procedure Adjust (Container : in out List) is - Src : Node_Access := Container.First; - Length : constant Count_Type := Container.Length; + Src : Node_Access := Container.First; begin if Src = null then pragma Assert (Container.Last = null); - pragma Assert (Length = 0); + pragma Assert (Container.Length = 0); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 0); return; end if; pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - pragma Assert (Length > 0); + pragma Assert (Container.Length > 0); Container.First := null; Container.Last := null; Container.Length := 0; + Container.Busy := 0; + Container.Lock := 0; Container.First := new Node_Type'(Src.Element, null, null); - Container.Last := Container.First; - loop - Container.Length := Container.Length + 1; - Src := Src.Next; - exit when Src = null; + Container.Length := 1; + + Src := Src.Next; + + while Src /= null loop Container.Last.Next := new Node_Type'(Element => Src.Element, Prev => Container.Last, Next => null); Container.Last := Container.Last.Next; - end loop; + Container.Length := Container.Length + 1; - pragma Assert (Container.Length = Length); + Src := Src.Next; + end loop; end Adjust; ------------ @@ -129,8 +129,7 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Append (Container : in out List; New_Item : Element_Type; - Count : Count_Type := 1) - is + Count : Count_Type := 1) is begin Insert (Container, No_Element, New_Item, Count); end Append; @@ -140,8 +139,45 @@ package body Ada.Containers.Doubly_Linked_Lists is ----------- procedure Clear (Container : in out List) is + X : Node_Access; + begin - Delete_Last (Container, Count => Container.Length); + if Container.Length = 0 then + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; + end if; + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + X.Next := null; -- prevent mischief + + Container.First.Prev := null; + Container.Length := Container.Length - 1; + + Free (X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + Free (X); end Clear; -------------- @@ -150,8 +186,7 @@ package body Ada.Containers.Doubly_Linked_Lists is function Contains (Container : List; - Item : Element_Type) return Boolean - is + Item : Element_Type) return Boolean is begin return Find (Container, Item) /= No_Element; end Contains; @@ -165,22 +200,68 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : in out Cursor; Count : Count_Type := 1) is + X : Node_Access; + begin - if Position = No_Element then - return; + if Position.Node = null then + pragma Assert (Position.Container = null); + raise Constraint_Error; end if; if Position.Container /= List_Access'(Container'Unchecked_Access) then raise Program_Error; end if; + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := First (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + for Index in 1 .. Count loop - Delete_Node (Container, Position.Node); + X := Position.Node; + Container.Length := Container.Length - 1; - if Position.Node = null then - Position.Container := null; + if X = Container.Last then + Position := No_Element; + + Container.Last := X.Prev; + Container.Last.Next := null; + + X.Prev := null; -- prevent mischief + Free (X); return; end if; + + Position.Node := X.Next; + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + + X.Next := null; + X.Prev := null; + Free (X); end loop; end Delete; @@ -192,10 +273,33 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is - Node : Node_Access := Container.First; + X : Node_Access; + begin - for J in 1 .. Count_Type'Min (Count, Container.Length) loop - Delete_Node (Container, Node); + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + + for I in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + X.Next := null; -- prevent mischief + Free (X); end loop; end Delete_First; @@ -207,55 +311,35 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is - Node : Node_Access; - begin - for J in 1 .. Count_Type'Min (Count, Container.Length) loop - Node := Container.Last; - Delete_Node (Container, Node); - end loop; - end Delete_Last; - - ----------------- - -- Delete_Node -- - ----------------- - - procedure Delete_Node - (Container : in out List; - Node : in out Node_Access) - is - X : Node_Access := Node; + X : Node_Access; begin - Node := X.Next; - Container.Length := Container.Length - 1; + if Count >= Container.Length then + Clear (Container); + return; + end if; - if X = Container.First then - Container.First := X.Next; + if Count = 0 then + return; + end if; - if X = Container.Last then - pragma Assert (Container.First = null); - pragma Assert (Container.Length = 0); - Container.Last := null; - else - pragma Assert (Container.Length > 0); - Container.First.Prev := null; - end if; + if Container.Busy > 0 then + raise Program_Error; + end if; - elsif X = Container.Last then - pragma Assert (Container.Length > 0); + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); Container.Last := X.Prev; Container.Last.Next := null; - else - pragma Assert (Container.Length > 0); + Container.Length := Container.Length - 1; - X.Next.Prev := X.Prev; - X.Prev.Next := X.Next; - end if; - - Free (X); - end Delete_Node; + X.Prev := null; -- prevent mischief + Free (X); + end loop; + end Delete_Last; ------------- -- Element -- @@ -263,6 +347,21 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + return Position.Node.Element; end Element; @@ -280,8 +379,23 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Node = null then Node := Container.First; - elsif Position.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; + else + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); end if; while Node /= null loop @@ -317,131 +431,173 @@ package body Ada.Containers.Doubly_Linked_Lists is return Container.First.Element; end First_Element; - ------------------- - -- Generic_Merge -- - ------------------- + --------------------- + -- Generic_Sorting -- + --------------------- - procedure Generic_Merge - (Target : in out List; - Source : in out List) - is - LI : Cursor := First (Target); - RI : Cursor := First (Source); + package body Generic_Sorting is - begin - if Target'Address = Source'Address then - return; - end if; + --------------- + -- Is_Sorted -- + --------------- - while RI.Node /= null loop - if LI.Node = null then - Splice (Target, No_Element, Source); + function Is_Sorted (Container : List) return Boolean is + Node : Node_Access := Container.First; + + begin + for I in 2 .. Container.Length loop + if Node.Next.Element < Node.Element then + return False; + end if; + + Node := Node.Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + LI : Cursor := First (Target); + RI : Cursor := First (Source); + + begin + if Target'Address = Source'Address then return; end if; - if RI.Node.Element < LI.Node.Element then - declare - RJ : constant Cursor := RI; - begin - RI.Node := RI.Node.Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LI.Node.Next; + if Target.Busy > 0 + or else Source.Busy > 0 + then + raise Program_Error; end if; - end loop; - end Generic_Merge; - ------------------ - -- Generic_Sort -- - ------------------ + while RI.Node /= null loop + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; + + if RI.Node.Element < LI.Node.Element then + declare + RJ : Cursor := RI; + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LI.Node.Next; + end if; + end loop; + end Merge; - procedure Generic_Sort (Container : in out List) is + ---------- + -- Sort -- + ---------- - procedure Partition - (Pivot : in Node_Access; - Back : in Node_Access); + procedure Sort (Container : in out List) is - procedure Sort (Front, Back : Node_Access); + procedure Partition + (Pivot : in Node_Access; + Back : in Node_Access); - --------------- - -- Partition -- - --------------- + procedure Sort (Front, Back : Node_Access); - procedure Partition - (Pivot : Node_Access; - Back : Node_Access) - is - Node : Node_Access := Pivot.Next; + --------------- + -- Partition -- + --------------- - begin - while Node /= Back loop - if Node.Element < Pivot.Element then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; + procedure Partition + (Pivot : Node_Access; + Back : Node_Access) + is + Node : Node_Access := Pivot.Next; - begin - Prev.Next := Next; + begin + while Node /= Back loop + if Node.Element < Pivot.Element then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; + begin + Prev.Next := Next; - Node.Next := Pivot; - Node.Prev := Pivot.Prev; + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; - Pivot.Prev := Node; + Node.Next := Pivot; + Node.Prev := Pivot.Prev; - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; + Pivot.Prev := Node; - Node := Next; - end; + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; + else + Node := Node.Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Node_Access) is + Pivot : Node_Access; + + begin + if Front = null then + Pivot := Container.First; else - Node := Node.Next; + Pivot := Front.Next; end if; - end loop; - end Partition; - ---------- - -- Sort -- - ---------- + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; - procedure Sort (Front, Back : Node_Access) is - Pivot : Node_Access; + -- Start of processing for Sort begin - if Front = null then - Pivot := Container.First; - else - Pivot := Front.Next; + if Container.Length <= 1 then + return; end if; - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; end if; - end Sort; - -- Start of processing for Generic_Sort + Sort (Front => null, Back => null); - begin - Sort (Front => null, Back => null); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Sort; - pragma Assert (Container.Length = 0 - or else - (Container.First.Prev = null - and then Container.Last.Next = null)); - end Generic_Sort; + end Generic_Sorting; ----------------- -- Has_Element -- @@ -449,7 +605,26 @@ package body Ada.Containers.Doubly_Linked_Lists is function Has_Element (Position : Cursor) return Boolean is begin - return Position.Container /= null and then Position.Node /= null; + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; + + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + return True; end Has_Element; ------------ @@ -466,10 +641,23 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Container /= null - and then Before.Container /= List_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Container.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Container.Last); end if; if Count = 0 then @@ -477,10 +665,18 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; + if Container.Length > Count_Type'Last - Count then + raise Constraint_Error; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + New_Node := new Node_Type'(New_Item, null, null); Insert_Internal (Container, Before.Node, New_Node); - Position := Cursor'(Before.Container, New_Node); + Position := Cursor'(Container'Unchecked_Access, New_Node); for J in Count_Type'(2) .. Count loop New_Node := new Node_Type'(New_Item, null, null); @@ -508,10 +704,23 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Container /= null - and then Before.Container /= List_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Container.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Container.Last); end if; if Count = 0 then @@ -519,10 +728,18 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; + if Container.Length > Count_Type'Last - Count then + raise Constraint_Error; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + New_Node := new Node_Type; Insert_Internal (Container, Before.Node, New_Node); - Position := Cursor'(Before.Container, New_Node); + Position := Cursor'(Container'Unchecked_Access, New_Node); for J in Count_Type'(2) .. Count loop New_Node := new Node_Type; @@ -595,12 +812,26 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + Node : Node_Access := Container.First; + begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Next; - end loop; + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -647,10 +878,12 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Target.Length > 0 then - raise Constraint_Error; + if Source.Busy > 0 then + raise Program_Error; end if; + Clear (Target); + Target.First := Source.First; Source.First := null; @@ -668,9 +901,24 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Next (Position : in out Cursor) is begin if Position.Node = null then + pragma Assert (Position.Container = null); return; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + Position.Node := Position.Node.Next; if Position.Node = null then @@ -681,9 +929,24 @@ package body Ada.Containers.Doubly_Linked_Lists is function Next (Position : Cursor) return Cursor is begin if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -715,9 +978,24 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Previous (Position : in out Cursor) is begin if Position.Node = null then + pragma Assert (Position.Container = null); return; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + Position.Node := Position.Node.Prev; if Position.Node = null then @@ -728,9 +1006,24 @@ package body Ada.Containers.Doubly_Linked_Lists is function Previous (Position : Cursor) return Cursor is begin if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -750,8 +1043,42 @@ package body Ada.Containers.Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in Element_Type)) is + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + E : Element_Type renames Position.Node.Element; + + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin - Process (Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -766,7 +1093,7 @@ package body Ada.Containers.Doubly_Linked_Lists is X : Node_Access; begin - Clear (Item); -- ??? + Clear (Item); Count_Type'Base'Read (Stream, N); if N = 0 then @@ -814,8 +1141,29 @@ package body Ada.Containers.Doubly_Linked_Lists is (Position : Cursor; By : Element_Type) is + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + E : Element_Type renames Position.Node.Element; + begin - Position.Node.Element := By; + if Position.Container.Lock > 0 then + raise Program_Error; + end if; + + E := By; end Replace_Element; ------------------ @@ -832,8 +1180,23 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Node = null then Node := Container.Last; - elsif Position.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; + else + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); end if; while Node /= null loop @@ -855,12 +1218,26 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + Node : Node_Access := Container.Last; + begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Prev; - end loop; + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ------------------ @@ -918,6 +1295,13 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; + end if; + Container.First := J; Container.Last := I; loop @@ -952,10 +1336,23 @@ package body Ada.Containers.Doubly_Linked_Lists is Source : in out List) is begin - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; if Target'Address = Source'Address @@ -964,7 +1361,22 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error; + end if; + + if Target.Busy > 0 + or else Source.Busy > 0 + then + raise Program_Error; + end if; + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); pragma Assert (Before = No_Element); Target.First := Source.First; @@ -987,6 +1399,8 @@ package body Ada.Containers.Doubly_Linked_Lists is Target.First := Source.First; else + pragma Assert (Target.Length >= 2); + Before.Node.Prev.Next := Source.First; Source.First.Prev := Before.Node.Prev; @@ -1006,189 +1420,309 @@ package body Ada.Containers.Doubly_Linked_Lists is Before : Cursor; Position : Cursor) is - X : Node_Access := Position.Node; - begin - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; - if Position.Container /= null - and then Position.Container /= List_Access'(Target'Unchecked_Access) - then + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= List_Access'(Target'Unchecked_Access) then raise Program_Error; end if; - if X = null - or else X = Before.Node - or else X.Next = Before.Node + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Target.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Target.Last); + + if Position.Node = Before.Node + or else Position.Node.Next = Before.Node then return; end if; - pragma Assert (Target.Length > 0); + pragma Assert (Target.Length >= 2); + + if Target.Busy > 0 then + raise Program_Error; + end if; if Before.Node = null then - pragma Assert (X /= Target.Last); + pragma Assert (Position.Node /= Target.Last); - if X = Target.First then - Target.First := X.Next; + if Position.Node = Target.First then + Target.First := Position.Node.Next; Target.First.Prev := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Target.Last.Next := X; - X.Prev := Target.Last; + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; - Target.Last := X; + Target.Last := Position.Node; Target.Last.Next := null; return; end if; if Before.Node = Target.First then - pragma Assert (X /= Target.First); + pragma Assert (Position.Node /= Target.First); - if X = Target.Last then - Target.Last := X.Prev; + if Position.Node = Target.Last then + Target.Last := Position.Node.Prev; Target.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Target.First.Prev := X; - X.Next := Target.First; + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; - Target.First := X; + Target.First := Position.Node; Target.First.Prev := null; return; end if; - if X = Target.First then - Target.First := X.Next; + if Position.Node = Target.First then + Target.First := Position.Node.Next; Target.First.Prev := null; - elsif X = Target.Last then - Target.Last := X.Prev; + elsif Position.Node = Target.Last then + Target.Last := Position.Node.Prev; Target.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Before.Node.Prev.Next := X; - X.Prev := Before.Node.Prev; + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; - Before.Node.Prev := X; - X.Next := Before.Node; + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); end Splice; procedure Splice (Target : in out List; Before : Cursor; Source : in out List; - Position : Cursor) + Position : in out Cursor) is - X : Node_Access := Position.Node; - begin if Target'Address = Source'Address then Splice (Target, Before, Position); return; end if; - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; - if Position.Container /= null - and then Position.Container /= List_Access'(Source'Unchecked_Access) - then - raise Program_Error; + if Position.Node = null then + raise Constraint_Error; end if; - if X = null then - return; + if Position.Container /= List_Access'(Source'Unchecked_Access) then + raise Program_Error; end if; - pragma Assert (Source.Length > 0); + pragma Assert (Source.Length >= 1); pragma Assert (Source.First.Prev = null); pragma Assert (Source.Last.Next = null); - if X = Source.First then - Source.First := X.Next; + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Source.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Source.Last); + + if Target.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + if Target.Busy > 0 + or else Source.Busy > 0 + then + raise Program_Error; + end if; + + if Position.Node = Source.First then + Source.First := Position.Node.Next; Source.First.Prev := null; - if X = Source.Last then + if Position.Node = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; end if; - elsif X = Source.Last then - Source.Last := X.Prev; + elsif Position.Node = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Node.Prev; Source.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + pragma Assert (Source.Length >= 3); + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; if Target.Length = 0 then - pragma Assert (Before = No_Element); pragma Assert (Target.First = null); pragma Assert (Target.Last = null); + pragma Assert (Before = No_Element); - Target.First := X; - Target.Last := X; + Target.First := Position.Node; + Target.Last := Position.Node; + + Target.First.Prev := null; + Target.Last.Next := null; elsif Before.Node = null then - Target.Last.Next := X; - X.Next := Target.Last; + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; - Target.Last := X; + Target.Last := Position.Node; Target.Last.Next := null; elsif Before.Node = Target.First then - Target.First.Prev := X; - X.Next := Target.First; + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; - Target.First := X; + Target.First := Position.Node; Target.First.Prev := null; else - Before.Node.Prev.Next := X; - X.Prev := Before.Node.Prev; + pragma Assert (Target.Length >= 2); + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; - Before.Node.Prev := X; - X.Next := Before.Node; + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; end if; Target.Length := Target.Length + 1; Source.Length := Source.Length - 1; + + Position.Container := Target'Unchecked_Access; end Splice; ---------- -- Swap -- ---------- - -- Is this defined when I and J designate elements in different containers, - -- or should it raise an exception (Program_Error)??? - - procedure Swap (I, J : in Cursor) is - EI : constant Element_Type := I.Node.Element; + procedure Swap (I, J : Cursor) is begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI; + if I.Container = null + or else J.Container = null + then + raise Constraint_Error; + end if; + + if I.Container /= J.Container then + raise Program_Error; + end if; + + declare + C : List renames I.Container.all; + begin + pragma Assert (C.Length >= 1); + pragma Assert (C.First.Prev = null); + pragma Assert (C.Last.Next = null); + + pragma Assert (I.Node /= null); + pragma Assert (I.Node.Prev = null + or else I.Node.Prev.Next = I.Node); + pragma Assert (I.Node.Next = null + or else I.Node.Next.Prev = I.Node); + pragma Assert (I.Node.Prev /= null + or else I.Node = C.First); + pragma Assert (I.Node.Next /= null + or else I.Node = C.Last); + + if I.Node = J.Node then + return; + end if; + + pragma Assert (C.Length >= 2); + pragma Assert (J.Node /= null); + pragma Assert (J.Node.Prev = null + or else J.Node.Prev.Next = J.Node); + pragma Assert (J.Node.Next = null + or else J.Node.Next.Prev = J.Node); + pragma Assert (J.Node.Prev /= null + or else J.Node = C.First); + pragma Assert (J.Node.Next /= null + or else J.Node = C.Last); + + if C.Lock > 0 then + raise Program_Error; + end if; + + declare + EI : Element_Type renames I.Node.Element; + EJ : Element_Type renames J.Node.Element; + + EI_Copy : constant Element_Type := EI; + begin + EI := EJ; + EJ := EI_Copy; + end; + end; end Swap; ---------------- @@ -1197,11 +1731,10 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Swap_Links (Container : in out List; - I, J : Cursor) - is + I, J : Cursor) is begin - if I = No_Element - or else J = No_Element + if I.Container = null + or else J.Container = null then raise Constraint_Error; end if; @@ -1215,6 +1748,18 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; pragma Assert (Container.Length >= 1); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (I.Node /= null); + pragma Assert (I.Node.Prev = null + or else I.Node.Prev.Next = I.Node); + pragma Assert (I.Node.Next = null + or else I.Node.Next.Prev = I.Node); + pragma Assert (I.Node.Prev /= null + or else I.Node = Container.First); + pragma Assert (I.Node.Next /= null + or else I.Node = Container.Last); if I.Node = J.Node then return; @@ -1222,6 +1767,20 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); + pragma Assert (J.Node /= null); + pragma Assert (J.Node.Prev = null + or else J.Node.Prev.Next = J.Node); + pragma Assert (J.Node.Next = null + or else J.Node.Next.Prev = J.Node); + pragma Assert (J.Node.Prev /= null + or else J.Node = Container.First); + pragma Assert (J.Node.Next /= null + or else J.Node = Container.Last); + + if Container.Busy > 0 then + raise Program_Error; + end if; + declare I_Next : constant Cursor := Next (I); @@ -1255,8 +1814,43 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Update_Element (Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length >= 1); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + E : Element_Type renames Position.Node.Element; + + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin - Process (Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; ----------- @@ -1279,4 +1873,3 @@ package body Ada.Containers.Doubly_Linked_Lists is end Write; end Ada.Containers.Doubly_Linked_Lists; - diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index f87479c..32f8d77 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.DOUBLY_LINKED_LISTS -- +-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -122,18 +122,20 @@ package Ada.Containers.Doubly_Linked_Lists is Count : Count_Type := 1); generic - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - procedure Generic_Sort (Container : in out List); + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is - generic - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - procedure Generic_Merge (Target : in out List; Source : in out List); + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; procedure Reverse_List (Container : in out List); - procedure Swap (I, J : in Cursor); + procedure Swap (I, J : Cursor); procedure Swap_Links (Container : in out List; @@ -153,7 +155,7 @@ package Ada.Containers.Doubly_Linked_Lists is (Target : in out List; Before : Cursor; Source : in out List; - Position : Cursor); + Position : in out Cursor); function First (Container : List) return Cursor; @@ -200,14 +202,12 @@ private type Node_Access is access Node_Type; type Node_Type is - record + limited record Element : Element_Type; Next : Node_Access; Prev : Node_Access; end record; - function "=" (L, R : Node_Type) return Boolean is abstract; - use Ada.Finalization; type List is @@ -215,6 +215,8 @@ private First : Node_Access; Last : Node_Access; Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; end record; procedure Adjust (Container : in out List); @@ -235,7 +237,7 @@ private for List'Write use Write; - Empty_List : constant List := List'(Controlled with null, null, 0); + Empty_List : constant List := (Controlled with null, null, 0, 0, 0); type List_Access is access constant List; for List_Access'Storage_Size use 0; @@ -249,4 +251,3 @@ private No_Element : constant Cursor := Cursor'(null, null); end Ada.Containers.Doubly_Linked_Lists; - diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index 9a21ad0..010d557 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- A D A . C O N T A I N E R S . -- +-- H A S H _ T A B L E S . G E N E R I C _ K E Y S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -40,7 +41,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -------------------------- procedure Delete_Key_Sans_Free - (HT : in out HT_Type; + (HT : in out Hash_Table_Type; Key : Key_Type; X : out Node_Access) is @@ -49,18 +50,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is begin if HT.Length = 0 then - X := Null_Node; + X := null; return; end if; Indx := Index (HT, Key); X := HT.Buckets (Indx); - if X = Null_Node then + if X = null then return; end if; if Equivalent_Keys (Key, X) then + if HT.Busy > 0 then + raise Program_Error; + end if; HT.Buckets (Indx) := Next (X); HT.Length := HT.Length - 1; return; @@ -70,11 +74,14 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Prev := X; X := Next (Prev); - if X = Null_Node then + if X = null then return; end if; if Equivalent_Keys (Key, X) then + if HT.Busy > 0 then + raise Program_Error; + end if; Set_Next (Node => Prev, Next => Next (X)); HT.Length := HT.Length - 1; return; @@ -87,7 +94,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ---------- function Find - (HT : HT_Type; + (HT : Hash_Table_Type; Key : Key_Type) return Node_Access is Indx : Hash_Type; @@ -95,20 +102,20 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is begin if HT.Length = 0 then - return Null_Node; + return null; end if; Indx := Index (HT, Key); Node := HT.Buckets (Indx); - while Node /= Null_Node loop + while Node /= null loop if Equivalent_Keys (Key, Node) then return Node; end if; Node := Next (Node); end loop; - return Null_Node; + return null; end Find; -------------------------------- @@ -116,10 +123,10 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is -------------------------------- procedure Generic_Conditional_Insert - (HT : in out HT_Type; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean) + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) is Indx : constant Hash_Type := Index (HT, Key); B : Node_Access renames HT.Buckets (Indx); @@ -127,12 +134,16 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1; begin - if B = Null_Node then + if B = null then + if HT.Busy > 0 then + raise Program_Error; + end if; + declare Length : constant Length_Subtype := HT.Length; begin - Node := New_Node (Next => Null_Node); - Success := True; + Node := New_Node (Next => null); + Inserted := True; B := Node; HT.Length := Length + 1; @@ -144,20 +155,24 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Node := B; loop if Equivalent_Keys (Key, Node) then - Success := False; + Inserted := False; return; end if; Node := Next (Node); - exit when Node = Null_Node; + exit when Node = null; end loop; + if HT.Busy > 0 then + raise Program_Error; + end if; + declare Length : constant Length_Subtype := HT.Length; begin Node := New_Node (Next => B); - Success := True; + Inserted := True; B := Node; HT.Length := Length + 1; @@ -169,7 +184,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is ----------- function Index - (HT : HT_Type; + (HT : Hash_Table_Type; Key : Key_Type) return Hash_Type is begin return Hash (Key) mod HT.Buckets'Length; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads index 704c653..a0812ba 100644 --- a/gcc/ada/a-chtgke.ads +++ b/gcc/ada/a-chtgke.ads @@ -2,27 +2,44 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- A D A . C O N T A I N E R S . -- +-- H A S H _ T A B L E S . G E N E R I C _ K E Y S -- -- -- -- S p e c -- -- -- --- This specification is adapted from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - type HT_Type is new HT_Types.Hash_Table_Type with private; - use HT_Types; - Null_Node : Node_Access; - with function Next (Node : Node_Access) return Node_Access; with procedure Set_Next @@ -41,24 +58,24 @@ package Ada.Containers.Hash_Tables.Generic_Keys is pragma Preelaborate; function Index - (HT : HT_Type; + (HT : Hash_Table_Type; Key : Key_Type) return Hash_Type; pragma Inline (Index); procedure Delete_Key_Sans_Free - (HT : in out HT_Type; + (HT : in out Hash_Table_Type; Key : Key_Type; X : out Node_Access); - function Find (HT : HT_Type; Key : Key_Type) return Node_Access; + function Find (HT : Hash_Table_Type; Key : Key_Type) return Node_Access; generic with function New_Node (Next : Node_Access) return Node_Access; procedure Generic_Conditional_Insert - (HT : in out HT_Type; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean); + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index aa27f42..39879b6 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- A D A . C O N T A I N E R S . -- +-- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,7 +69,9 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end if; HT.Buckets := new Buckets_Type (Src_Buckets'Range); + -- TODO: allocate minimum size req'd. (See note below.) + -- NOTE: see note below about these comments. -- Probably we have to duplicate the Size (Src), too, in order -- to guarantee that @@ -80,11 +83,30 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- If we relax the requirement that the hash value must be the -- same, then of course we can't guarantee that following -- assignment that Dst = Src is true ??? + -- + -- NOTE: 17 Apr 2005 + -- What I said above is no longer true. The semantics of (map) equality + -- changed, such that we use key in the left map to look up the + -- equivalent key in the right map, and then compare the elements (using + -- normal equality) of the equivalent keys. So it doesn't matter that + -- the maps have different capacities (i.e. the hash tables have + -- different lengths), since we just look up the key, irrespective of + -- its map's hash table length. All the RM says we're required to do + -- it arrange for the target map to "=" the source map following an + -- assignment (that is, following an Adjust), so it doesn't matter + -- what the capacity of the target map is. What I'll probably do is + -- allocate a new hash table that has the minimum size necessary, + -- instead of allocating a new hash table whose size exactly matches + -- that of the source. (See the assignment that immediately precedes + -- these comments.) What we really need is a special Assign operation + -- (not unlike what we have already for Vector) that allows the user to + -- choose the capacity of the target. + -- END NOTE. for Src_Index in Src_Buckets'Range loop Src_Node := Src_Buckets (Src_Index); - if Src_Node /= Null_Node then + if Src_Node /= null then declare Dst_Node : constant Node_Access := Copy_Node (Src_Node); @@ -100,7 +122,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end; Src_Node := Next (Src_Node); - while Src_Node /= Null_Node loop + while Src_Node /= null loop declare Dst_Node : constant Node_Access := Copy_Node (Src_Node); @@ -145,8 +167,12 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Node : Node_Access; begin + if HT.Busy > 0 then + raise Program_Error; + end if; + while HT.Length > 0 loop - while HT.Buckets (Index) = Null_Node loop + while HT.Buckets (Index) = null loop Index := Index + 1; end loop; @@ -158,7 +184,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Bucket := Next (Bucket); HT.Length := HT.Length - 1; Free (Node); - exit when Bucket = Null_Node; + exit when Bucket = null; end loop; end; end loop; @@ -172,7 +198,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is (HT : in out Hash_Table_Type; X : Node_Access) is - pragma Assert (X /= Null_Node); + pragma Assert (X /= null); Indx : Hash_Type; Prev : Node_Access; @@ -186,7 +212,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Indx := Index (HT, X); Prev := HT.Buckets (Indx); - if Prev = Null_Node then + if Prev = null then raise Program_Error; end if; @@ -203,7 +229,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop Curr := Next (Prev); - if Curr = Null_Node then + if Curr = null then raise Program_Error; end if; @@ -217,75 +243,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end loop; end Delete_Node_Sans_Free; - --------------------- - -- Ensure_Capacity -- - --------------------- - - procedure Ensure_Capacity - (HT : in out Hash_Table_Type; - N : Count_Type) - is - NN : Hash_Type; - - begin - if N = 0 then - if HT.Length = 0 then - Free (HT.Buckets); - - elsif HT.Length < HT.Buckets'Length then - NN := Prime_Numbers.To_Prime (HT.Length); - - -- ASSERT: NN >= HT.Length - - if NN < HT.Buckets'Length then - Rehash (HT, Size => NN); - end if; - end if; - - return; - end if; - - if HT.Buckets = null then - NN := Prime_Numbers.To_Prime (N); - - -- ASSERT: NN >= N - - Rehash (HT, Size => NN); - return; - end if; - - if N <= HT.Length then - if HT.Length >= HT.Buckets'Length then - return; - end if; - - NN := Prime_Numbers.To_Prime (HT.Length); - - -- ASSERT: NN >= HT.Length - - if NN < HT.Buckets'Length then - Rehash (HT, Size => NN); - end if; - - return; - end if; - - -- ASSERT: N > HT.Length - - if N = HT.Buckets'Length then - return; - end if; - - NN := Prime_Numbers.To_Prime (N); - - -- ASSERT: NN >= N - -- ASSERT: NN > HT.Length - - if NN /= HT.Buckets'Length then - Rehash (HT, Size => NN); - end if; - end Ensure_Capacity; - -------------- -- Finalize -- -------------- @@ -305,12 +262,12 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is begin if HT.Length = 0 then - return Null_Node; + return null; end if; Indx := HT.Buckets'First; loop - if HT.Buckets (Indx) /= Null_Node then + if HT.Buckets (Indx) /= null then return HT.Buckets (Indx); end if; @@ -331,7 +288,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end if; for J in Buckets'Range loop - while Buckets (J) /= Null_Node loop + while Buckets (J) /= null loop Node := Buckets (J); Buckets (J) := Next (Node); Free (Node); @@ -370,7 +327,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop L_Node := L.Buckets (L_Index); - exit when L_Node /= Null_Node; + exit when L_Node /= null; L_Index := L_Index + 1; end loop; @@ -385,7 +342,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is L_Node := Next (L_Node); - if L_Node = Null_Node then + if L_Node = null then if N = 0 then return True; end if; @@ -393,7 +350,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is loop L_Index := L_Index + 1; L_Node := L.Buckets (L_Index); - exit when L_Node /= Null_Node; + exit when L_Node /= null; end loop; end if; end loop; @@ -404,22 +361,32 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ----------------------- procedure Generic_Iteration (HT : Hash_Table_Type) is - Node : Node_Access; + Busy : Natural renames HT'Unrestricted_Access.all.Busy; begin - if HT.Buckets = null - or else HT.Length = 0 - then + if HT.Length = 0 then return; end if; - for Indx in HT.Buckets'Range loop - Node := HT.Buckets (Indx); - while Node /= Null_Node loop - Process (Node); - Node := Next (Node); + Busy := Busy + 1; + + declare + Node : Node_Access; + begin + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= null loop + Process (Node); + Node := Next (Node); + end loop; end loop; - end loop; + exception + when others => + Busy := Busy - 1; + raise; + end; + + Busy := Busy - 1; end Generic_Iteration; ------------------ @@ -436,10 +403,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is N, M : Count_Type'Base; begin - -- As with the sorted set, it's not clear whether read is allowed to - -- have side effect if it fails. For now, we assume side effects are - -- allowed since it simplifies the algorithm ??? - -- Clear (HT); declare @@ -452,6 +415,10 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Hash_Type'Read (Stream, Last); + -- TODO: don't immediately deallocate the buckets array we + -- already have. Instead, allocate a new buckets array only + -- if it needs to expanded because of the value of Last. + if Last /= 0 then HT.Buckets := new Buckets_Type (0 .. Last); end if; @@ -461,15 +428,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is while N > 0 loop Hash_Type'Read (Stream, I); pragma Assert (I in HT.Buckets'Range); - pragma Assert (HT.Buckets (I) = Null_Node); + pragma Assert (HT.Buckets (I) = null); Count_Type'Base'Read (Stream, M); pragma Assert (M >= 1); pragma Assert (M <= N); HT.Buckets (I) := New_Node (Stream); - pragma Assert (HT.Buckets (I) /= Null_Node); - pragma Assert (Next (HT.Buckets (I)) = Null_Node); + pragma Assert (HT.Buckets (I) /= null); + pragma Assert (Next (HT.Buckets (I)) = null); Y := HT.Buckets (I); @@ -477,8 +444,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is for J in Count_Type range 2 .. M loop X := New_Node (Stream); - pragma Assert (X /= Null_Node); - pragma Assert (Next (X) = Null_Node); + pragma Assert (X /= null); + pragma Assert (Next (X) = null); Set_Next (Node => Y, Next => X); Y := X; @@ -517,11 +484,11 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is for Indx in HT.Buckets'Range loop X := HT.Buckets (Indx); - if X /= Null_Node then + if X /= null then M := 1; loop X := Next (X); - exit when X = Null_Node; + exit when X = null; M := M + 1; end loop; @@ -534,7 +501,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is X := Next (X); end loop; - pragma Assert (X = Null_Node); + pragma Assert (X = null); end if; end loop; end Generic_Write; @@ -567,14 +534,18 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; - if Target.Length > 0 then - raise Constraint_Error; + if Source.Busy > 0 then + raise Program_Error; end if; - Free (Target.Buckets); + Clear (Target); - Target.Buckets := Source.Buckets; - Source.Buckets := null; + declare + Buckets : constant Buckets_Access := Target.Buckets; + begin + Target.Buckets := Source.Buckets; + Source.Buckets := Buckets; + end; Target.Length := Source.Length; Source.Length := 0; @@ -591,19 +562,19 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Result : Node_Access := Next (Node); begin - if Result /= Null_Node then + if Result /= null then return Result; end if; for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop Result := HT.Buckets (Indx); - if Result /= Null_Node then + if Result /= null then return Result; end if; end loop; - return Null_Node; + return null; end Next; ------------ @@ -642,7 +613,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is declare Src_Bucket : Node_Access renames Src_Buckets (Src_Index); begin - while Src_Bucket /= Null_Node loop + while Src_Bucket /= null loop declare Src_Node : constant Node_Access := Src_Bucket; Dst_Index : constant Hash_Type := @@ -662,6 +633,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is exception when others => + -- NOTE: see todo below. -- Not clear that we can deallocate the nodes, -- because they may be designated by outstanding -- iterators. Which means they're now lost... ??? @@ -671,7 +643,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- Dst : Node_Access renames NB (J); -- X : Node_Access; -- begin - -- while Dst /= Null_Node loop + -- while Dst /= null loop -- X := Dst; -- Dst := Succ (Dst); -- Free (X); @@ -679,9 +651,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is -- end; -- end loop; + -- TODO: 17 Apr 2005 + -- What I should do instead is go ahead and deallocate the + -- nodes, since when assertions are enabled, we vet the + -- cursors, and we modify the state of a node enough when + -- it is deallocated in order to detect mischief. + -- END TODO. Free (Dst_Buckets); - raise; + raise; -- TODO: raise Program_Error instead end; -- exit when L = 0; @@ -697,5 +675,85 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is Free (Src_Buckets); end Rehash; -end Ada.Containers.Hash_Tables.Generic_Operations; + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type) + is + NN : Hash_Type; + + begin + if N = 0 then + if HT.Length = 0 then + Free (HT.Buckets); + + elsif HT.Length < HT.Buckets'Length then + NN := Prime_Numbers.To_Prime (HT.Length); + + -- ASSERT: NN >= HT.Length + + if NN < HT.Buckets'Length then + if HT.Busy > 0 then + raise Program_Error; + end if; + + Rehash (HT, Size => NN); + end if; + end if; + + return; + end if; + + if HT.Buckets = null then + NN := Prime_Numbers.To_Prime (N); + + -- ASSERT: NN >= N + + Rehash (HT, Size => NN); + return; + end if; + + if N <= HT.Length then + if HT.Length >= HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (HT.Length); + + -- ASSERT: NN >= HT.Length + + if NN < HT.Buckets'Length then + if HT.Busy > 0 then + raise Program_Error; + end if; + + Rehash (HT, Size => NN); + end if; + + return; + end if; + -- ASSERT: N > HT.Length + + if N = HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (N); + + -- ASSERT: NN >= N + -- ASSERT: NN > HT.Length + + if NN /= HT.Buckets'Length then + if HT.Busy > 0 then + raise Program_Error; + end if; + + Rehash (HT, Size => NN); + end if; + end Reserve_Capacity; + +end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads index 232c719..7d6e545 100644 --- a/gcc/ada/a-chtgop.ads +++ b/gcc/ada/a-chtgop.ads @@ -2,12 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- A D A . C O N T A I N E R S . -- +-- H A S H _ T A B L E S . G E N E R I C _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- --- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- -- copy and modify this specification, provided that if you redistribute a -- @@ -22,12 +21,8 @@ generic with package HT_Types is new Generic_Hash_Table_Types (<>); - type Hash_Table_Type is new HT_Types.Hash_Table_Type with private; - use HT_Types; - Null_Node : in Node_Access; - with function Hash_Node (Node : Node_Access) return Hash_Type; with function Next (Node : Node_Access) return Node_Access; @@ -72,7 +67,7 @@ package Ada.Containers.Hash_Tables.Generic_Operations is function Capacity (HT : Hash_Table_Type) return Count_Type; - procedure Ensure_Capacity + procedure Reserve_Capacity (HT : in out Hash_Table_Type; N : Count_Type); @@ -108,4 +103,3 @@ package Ada.Containers.Hash_Tables.Generic_Operations is HT : out Hash_Table_Type); end Ada.Containers.Hash_Tables.Generic_Operations; - diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index 252b64f..6fb6d9e 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -48,10 +49,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- Local Subprograms -- ----------------------- - procedure Delete_Node - (Container : in out List; - Node : in out Node_Access); - procedure Insert_Internal (Container : in out List; Before : Node_Access; @@ -77,15 +74,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is L := Left.First; R := Right.First; for J in 1 .. Left.Length loop - if L.Element = null then - if R.Element /= null then - return False; - end if; - - elsif R.Element = null then - return False; - - elsif L.Element.all /= R.Element.all then + if L.Element.all /= R.Element.all then return False; end if; @@ -108,6 +97,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Src = null then pragma Assert (Container.Last = null); pragma Assert (Container.Length = 0); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 0); return; end if; @@ -118,41 +109,40 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.First := null; Container.Last := null; Container.Length := 0; + Container.Busy := 0; + Container.Lock := 0; - Dst := new Node_Type'(null, null, null); + declare + Element : Element_Access := new Element_Type'(Src.Element.all); + begin + Dst := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; - if Src.Element /= null then + Container.First := Dst; + Container.Last := Dst; + Container.Length := 1; + + Src := Src.Next; + while Src /= null loop + declare + Element : Element_Access := new Element_Type'(Src.Element.all); begin - Dst.Element := new Element_Type'(Src.Element.all); + Dst := new Node_Type'(Element, null, Prev => Container.Last); exception when others => - Free (Dst); + Free (Element); raise; end; - end if; - - Container.First := Dst; - - Container.Last := Dst; - loop - Container.Length := Container.Length + 1; - Src := Src.Next; - exit when Src = null; - - Dst := new Node_Type'(null, Prev => Container.Last, Next => null); - - if Src.Element /= null then - begin - Dst.Element := new Element_Type'(Src.Element.all); - exception - when others => - Free (Dst); - raise; - end; - end if; Container.Last.Next := Dst; Container.Last := Dst; + Container.Length := Container.Length + 1; + + Src := Src.Next; end loop; end Adjust; @@ -174,8 +164,63 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ----------- procedure Clear (Container : in out List) is + X : Node_Access; + begin - Delete_Last (Container, Count => Container.Length); + if Container.Length = 0 then + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + pragma Assert (Container.Busy = 0); + pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; + end if; + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + Container.Length := Container.Length - 1; + + X.Next := null; -- prevent mischief + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; + + Free (X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; + + Free (X); end Clear; -------------- @@ -198,22 +243,88 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : in out Cursor; Count : Count_Type := 1) is + X : Node_Access; + begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; if Position.Container /= List_Access'(Container'Unchecked_Access) then raise Program_Error; end if; + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := First (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + for Index in 1 .. Count loop - Delete_Node (Container, Position.Node); + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; - if Position.Node = null then - Position.Container := null; + Container.Last := X.Prev; + Container.Last.Next := null; + + X.Prev := null; -- prevent mischief + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; + + Free (X); return; end if; + + Position.Node := X.Next; + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + + X.Prev := null; + X.Next := null; + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; + + Free (X); end loop; end Delete; @@ -225,10 +336,43 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is - Node : Node_Access := Container.First; + X : Node_Access; + begin - for J in 1 .. Count_Type'Min (Count, Container.Length) loop - Delete_Node (Container, Node); + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + + for I in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + X.Next := null; -- prevent mischief + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; + + Free (X); end loop; end Delete_First; @@ -240,57 +384,45 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1) is - Node : Node_Access; - begin - for J in 1 .. Count_Type'Min (Count, Container.Length) loop - Node := Container.Last; - Delete_Node (Container, Node); - end loop; - end Delete_Last; - - ----------------- - -- Delete_Node -- - ----------------- - - procedure Delete_Node - (Container : in out List; - Node : in out Node_Access) - is - X : Node_Access := Node; + X : Node_Access; begin - Node := X.Next; - Container.Length := Container.Length - 1; + if Count >= Container.Length then + Clear (Container); + return; + end if; - if X = Container.First then - Container.First := X.Next; + if Count = 0 then + return; + end if; - if X = Container.Last then - pragma Assert (Container.First = null); - pragma Assert (Container.Length = 0); - Container.Last := null; - else - pragma Assert (Container.Length > 0); - Container.First.Prev := null; - end if; + if Container.Busy > 0 then + raise Program_Error; + end if; - elsif X = Container.Last then - pragma Assert (Container.Length > 0); + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); Container.Last := X.Prev; Container.Last.Next := null; - else - pragma Assert (Container.Length > 0); + Container.Length := Container.Length - 1; - X.Next.Prev := X.Prev; - X.Prev.Next := X.Next; + X.Prev := null; -- prevent mischief - end if; + begin + Free (X.Element); + exception + when others => + X.Element := null; + Free (X); + raise; + end; - Free (X.Element); - Free (X); - end Delete_Node; + Free (X); + end loop; + end Delete_Last; ------------- -- Element -- @@ -298,6 +430,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + return Position.Node.Element.all; end Element; @@ -315,14 +463,29 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Node = null then Node := Container.First; - elsif Position.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; + + else + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); end if; while Node /= null loop - if Node.Element /= null - and then Node.Element.all = Item - then + if Node.Element.all = Item then return Cursor'(Container'Unchecked_Access, Node); end if; @@ -354,135 +517,168 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Container.First.Element.all; end First_Element; - ------------------- - -- Generic_Merge -- - ------------------- + --------------------- + -- Generic_Sorting -- + --------------------- - procedure Generic_Merge - (Target : in out List; - Source : in out List) - is - LI : Cursor; - RI : Cursor; + package body Generic_Sorting is - begin - if Target'Address = Source'Address then - return; - end if; + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Node : Node_Access := Container.First; + + begin + for I in 2 .. Container.Length loop + if Node.Next.Element.all < Node.Element.all then + return False; + end if; + + Node := Node.Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- - LI := First (Target); - RI := First (Source); - while RI.Node /= null loop - if LI.Node = null then - Splice (Target, No_Element, Source); + procedure Merge + (Target : in out List; + Source : in out List) + is + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then return; end if; - if LI.Node.Element = null then - LI.Node := LI.Node.Next; - - elsif RI.Node.Element = null - or else RI.Node.Element.all < LI.Node.Element.all + if Target.Busy > 0 + or else Source.Busy > 0 then - declare - RJ : constant Cursor := RI; - begin - RI.Node := RI.Node.Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LI.Node.Next; + raise Program_Error; end if; - end loop; - end Generic_Merge; - ------------------ - -- Generic_Sort -- - ------------------ + LI := First (Target); + RI := First (Source); + while RI.Node /= null loop + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; - procedure Generic_Sort (Container : in out List) is - procedure Partition (Pivot : Node_Access; Back : Node_Access); + if RI.Node.Element.all < LI.Node.Element.all then + declare + RJ : Cursor := RI; + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; - procedure Sort (Front, Back : Node_Access); + else + LI.Node := LI.Node.Next; + end if; + end loop; + end Merge; - --------------- - -- Partition -- - --------------- + ---------- + -- Sort -- + ---------- - procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access := Pivot.Next; + procedure Sort (Container : in out List) is + procedure Partition (Pivot : Node_Access; Back : Node_Access); - begin - while Node /= Back loop - if Pivot.Element = null then - Node := Node.Next; + procedure Sort (Front, Back : Node_Access); - elsif Node.Element = null - or else Node.Element.all < Pivot.Element.all - then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; - begin - Prev.Next := Next; + --------------- + -- Partition -- + --------------- - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; + procedure Partition (Pivot : Node_Access; Back : Node_Access) is + Node : Node_Access := Pivot.Next; - Node.Next := Pivot; - Node.Prev := Pivot.Prev; + begin + while Node /= Back loop + if Node.Element.all < Pivot.Element.all then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; + begin + Prev.Next := Next; + + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; + + Node.Next := Pivot; + Node.Prev := Pivot.Prev; + + Pivot.Prev := Node; + + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; - Pivot.Prev := Node; + else + Node := Node.Next; + end if; + end loop; + end Partition; - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; + ---------- + -- Sort -- + ---------- - Node := Next; - end; + procedure Sort (Front, Back : Node_Access) is + Pivot : Node_Access; + begin + if Front = null then + Pivot := Container.First; else - Node := Node.Next; + Pivot := Front.Next; end if; - end loop; - end Partition; - ---------- - -- Sort -- - ---------- + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; - procedure Sort (Front, Back : Node_Access) is - Pivot : Node_Access; + -- Start of processing for Sort begin - if Front = null then - Pivot := Container.First; - else - Pivot := Front.Next; + if Container.Length <= 1 then + return; end if; - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; end if; - end Sort; - -- Start of processing for Generic_Sort + Sort (Front => null, Back => null); - begin - Sort (Front => null, Back => null); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Sort; - pragma Assert (Container.Length = 0 - or else (Container.First.Prev = null - and Container.Last.Next = null)); - end Generic_Sort; + end Generic_Sorting; ----------------- -- Has_Element -- @@ -490,7 +686,27 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Has_Element (Position : Cursor) return Boolean is begin - return Position.Container /= null and then Position.Node /= null; + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; + + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + return True; end Has_Element; ------------ @@ -507,10 +723,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Container /= null - and then Before.Container /= List_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Before.Node.Element /= null); + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Container.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Container.Last); end if; if Count = 0 then @@ -518,6 +748,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; + if Container.Length > Count_Type'Last - Count then + raise Constraint_Error; + end if; + + if Container.Busy > 0 then + raise Program_Error; + end if; + declare Element : Element_Access := new Element_Type'(New_Item); begin @@ -529,7 +767,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end; Insert_Internal (Container, Before.Node, New_Node); - Position := Cursor'(Before.Container, New_Node); + Position := Cursor'(Container'Unchecked_Access, New_Node); for J in Count_Type'(2) .. Count loop @@ -623,12 +861,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : in Cursor)) is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + Node : Node_Access := Container.First; + begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Next; - end loop; + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -641,10 +893,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Target.Length > 0 then - raise Constraint_Error; + if Source.Busy > 0 then + raise Program_Error; end if; + Clear (Target); + Target.First := Source.First; Source.First := null; @@ -693,9 +947,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Next (Position : in out Cursor) is begin if Position.Node = null then + pragma Assert (Position.Container = null); return; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + Position.Node := Position.Node.Next; if Position.Node = null then @@ -706,9 +976,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Next (Position : Cursor) return Cursor is begin if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -740,9 +1026,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Previous (Position : in out Cursor) is begin if Position.Node = null then + pragma Assert (Position.Container = null); return; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + Position.Node := Position.Node.Prev; if Position.Node = null then @@ -753,9 +1055,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Previous (Position : Cursor) return Cursor is begin if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -775,8 +1093,43 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in Element_Type)) is + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + E : Element_Type renames Position.Node.Element.all; + + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin - Process (Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -787,11 +1140,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Stream : access Root_Stream_Type'Class; Item : out List) is - N : Count_Type'Base; - X : Node_Access; + N : Count_Type'Base; + Dst : Node_Access; begin - Clear (Item); -- ??? + Clear (Item); Count_Type'Base'Read (Stream, N); @@ -799,36 +1152,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - X := new Node_Type; - + declare + Element : Element_Access := + new Element_Type'(Element_Type'Input (Stream)); begin - X.Element := new Element_Type'(Element_Type'Input (Stream)); + Dst := new Node_Type'(Element, null, null); exception when others => - Free (X); + Free (Element); raise; end; - Item.First := X; - - Item.Last := X; - loop - Item.Length := Item.Length + 1; - exit when Item.Length = N; - - X := new Node_Type; + Item.First := Dst; + Item.Last := Dst; + Item.Length := 1; + while Item.Length < N loop + declare + Element : Element_Access := + new Element_Type'(Element_Type'Input (Stream)); begin - X.Element := new Element_Type'(Element_Type'Input (Stream)); + Dst := new Node_Type'(Element, Next => null, Prev => Item.Last); exception when others => - Free (X); + Free (Element); raise; end; - X.Prev := Item.Last; - Item.Last.Next := X; - Item.Last := X; + Item.Last.Next := Dst; + Item.Last := Dst; + Item.Length := Item.Length + 1; end loop; end Read; @@ -840,8 +1193,29 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; By : Element_Type) is + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + X : Element_Access := Position.Node.Element; + begin + if Position.Container.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Element := new Element_Type'(By); Free (X); end Replace_Element; @@ -860,14 +1234,29 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Node = null then Node := Container.Last; - elsif Position.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; + + else + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Container.Length > 0); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Container.Last); end if; while Node /= null loop - if Node.Element /= null - and then Node.Element.all = Item - then + if Node.Element.all = Item then return Cursor'(Container'Unchecked_Access, Node); end if; @@ -885,13 +1274,26 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : in Cursor)) is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + Node : Node_Access := Container.Last; begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Prev; - end loop; + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ------------------ @@ -949,6 +1351,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + if Container.Busy > 0 then + raise Program_Error; + end if; + Container.First := J; Container.Last := I; loop @@ -983,10 +1392,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Source : in out List) is begin - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Element /= null); + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; if Target'Address = Source'Address @@ -995,8 +1418,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error; + end if; + + if Target.Busy > 0 + or else Source.Busy > 0 + then + raise Program_Error; + end if; + if Target.Length = 0 then pragma Assert (Before = No_Element); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); Target.First := Source.First; Target.Last := Source.Last; @@ -1018,6 +1456,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Target.First := Source.First; else + pragma Assert (Target.Length >= 2); Before.Node.Prev.Next := Source.First; Source.First.Prev := Before.Node.Prev; @@ -1037,141 +1476,207 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Before : Cursor; Position : Cursor) is - X : Node_Access := Position.Node; - begin - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Element /= null); + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; - if Position.Container /= null - and then Position.Container /= List_Access'(Target'Unchecked_Access) - then + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= List_Access'(Target'Unchecked_Access) then raise Program_Error; end if; - if X = null - or else X = Before.Node - or else X.Next = Before.Node + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Target.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Target.Last); + + if Position.Node = Before.Node + or else Position.Node.Next = Before.Node then return; end if; - pragma Assert (Target.Length > 0); + pragma Assert (Target.Length >= 2); + + if Target.Busy > 0 then + raise Program_Error; + end if; if Before.Node = null then - pragma Assert (X /= Target.Last); + pragma Assert (Position.Node /= Target.Last); - if X = Target.First then - Target.First := X.Next; + if Position.Node = Target.First then + Target.First := Position.Node.Next; Target.First.Prev := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Target.Last.Next := X; - X.Prev := Target.Last; + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; - Target.Last := X; + Target.Last := Position.Node; Target.Last.Next := null; return; end if; if Before.Node = Target.First then - pragma Assert (X /= Target.First); + pragma Assert (Position.Node /= Target.First); - if X = Target.Last then - Target.Last := X.Prev; + if Position.Node = Target.Last then + Target.Last := Position.Node.Prev; Target.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Target.First.Prev := X; - X.Next := Target.First; + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; - Target.First := X; + Target.First := Position.Node; Target.First.Prev := null; return; end if; - if X = Target.First then - Target.First := X.Next; + if Position.Node = Target.First then + Target.First := Position.Node.Next; Target.First.Prev := null; - elsif X = Target.Last then - Target.Last := X.Prev; + elsif Position.Node = Target.Last then + Target.Last := Position.Node.Prev; Target.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; - Before.Node.Prev.Next := X; - X.Prev := Before.Node.Prev; + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; - Before.Node.Prev := X; - X.Next := Before.Node; + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); end Splice; procedure Splice (Target : in out List; Before : Cursor; Source : in out List; - Position : Cursor) + Position : in out Cursor) is - X : Node_Access := Position.Node; - begin if Target'Address = Source'Address then Splice (Target, Before, Position); return; end if; - if Before.Container /= null - and then Before.Container /= List_Access'(Target'Unchecked_Access) - then - raise Program_Error; + if Before.Node /= null then + if Before.Container /= List_Access'(Target'Unchecked_Access) then + raise Program_Error; + end if; + + pragma Assert (Target.Length >= 1); + pragma Assert (Target.First.Prev = null); + pragma Assert (Target.Last.Next = null); + + pragma Assert (Before.Node.Element /= null); + pragma Assert (Before.Node.Prev = null + or else Before.Node.Prev.Next = Before.Node); + pragma Assert (Before.Node.Next = null + or else Before.Node.Next.Prev = Before.Node); + pragma Assert (Before.Node.Prev /= null + or else Before.Node = Target.First); + pragma Assert (Before.Node.Next /= null + or else Before.Node = Target.Last); end if; - if Position.Container /= null - and then Position.Container /= List_Access'(Source'Unchecked_Access) - then - raise Program_Error; + if Position.Node = null then + raise Constraint_Error; end if; - if X = null then - return; + if Position.Container /= List_Access'(Source'Unchecked_Access) then + raise Program_Error; end if; - pragma Assert (Source.Length > 0); + pragma Assert (Source.Length >= 1); pragma Assert (Source.First.Prev = null); pragma Assert (Source.Last.Next = null); - if X = Source.First then - Source.First := X.Next; + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Source.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Source.Last); + + if Target.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + if Target.Busy > 0 + or else Source.Busy > 0 + then + raise Program_Error; + end if; + + if Position.Node = Source.First then + Source.First := Position.Node.Next; Source.First.Prev := null; - if X = Source.Last then + if Position.Node = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; end if; - elsif X = Source.Last then - Source.Last := X.Prev; + elsif Position.Node = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Node.Prev; Source.Last.Next := null; else - X.Prev.Next := X.Next; - X.Next.Prev := X.Prev; + pragma Assert (Source.Length >= 3); + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; end if; if Target.Length = 0 then @@ -1179,33 +1684,41 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Target.First = null); pragma Assert (Target.Last = null); - Target.First := X; - Target.Last := X; + Target.First := Position.Node; + Target.Last := Position.Node; + + Target.First.Prev := null; + Target.Last.Next := null; elsif Before.Node = null then - Target.Last.Next := X; - X.Next := Target.Last; + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position.Node; + Position.Node.Prev := Target.Last; - Target.Last := X; + Target.Last := Position.Node; Target.Last.Next := null; elsif Before.Node = Target.First then - Target.First.Prev := X; - X.Next := Target.First; + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position.Node; + Position.Node.Next := Target.First; - Target.First := X; + Target.First := Position.Node; Target.First.Prev := null; else - Before.Node.Prev.Next := X; - X.Prev := Before.Node.Prev; + pragma Assert (Target.Length >= 2); + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; - Before.Node.Prev := X; - X.Next := Before.Node; + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; end if; Target.Length := Target.Length + 1; Source.Length := Source.Length - 1; + + Position.Container := Target'Unchecked_Access; end Splice; ---------- @@ -1213,15 +1726,62 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ---------- procedure Swap (I, J : Cursor) is + begin + if I.Container = null + or else J.Container = null + then + raise Constraint_Error; + end if; - -- Is this op legal when I and J designate elements in different - -- containers, or should it raise an exception (e.g. Program_Error). + if I.Container /= J.Container then + raise Program_Error; + end if; - EI : constant Element_Access := I.Node.Element; + declare + C : List renames I.Container.all; + begin + pragma Assert (C.Length > 0); + pragma Assert (C.First.Prev = null); + pragma Assert (C.Last.Next = null); + + pragma Assert (I.Node /= null); + pragma Assert (I.Node.Element /= null); + pragma Assert (I.Node.Prev = null + or else I.Node.Prev.Next = I.Node); + pragma Assert (I.Node.Next = null + or else I.Node.Next.Prev = I.Node); + pragma Assert (I.Node.Prev /= null + or else I.Node = C.First); + pragma Assert (I.Node.Next /= null + or else I.Node = C.Last); + + if I.Node = J.Node then + return; + end if; - begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI; + pragma Assert (C.Length > 1); + pragma Assert (J.Node /= null); + pragma Assert (J.Node.Element /= null); + pragma Assert (J.Node.Prev = null + or else J.Node.Prev.Next = J.Node); + pragma Assert (J.Node.Next = null + or else J.Node.Next.Prev = J.Node); + pragma Assert (J.Node.Prev /= null + or else J.Node = C.First); + pragma Assert (J.Node.Next /= null + or else J.Node = C.Last); + + if C.Lock > 0 then + raise Program_Error; + end if; + + declare + EI_Copy : constant Element_Access := I.Node.Element; + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI_Copy; + end; + end; end Swap; ---------------- @@ -1233,8 +1793,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I = No_Element - or else J = No_Element + if I.Container = null + or else J.Container = null then raise Constraint_Error; end if; @@ -1248,12 +1808,39 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; pragma Assert (Container.Length >= 1); + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + pragma Assert (I.Node /= null); + pragma Assert (I.Node.Element /= null); + pragma Assert (I.Node.Prev = null + or else I.Node.Prev.Next = I.Node); + pragma Assert (I.Node.Next = null + or else I.Node.Next.Prev = I.Node); + pragma Assert (I.Node.Prev /= null + or else I.Node = Container.First); + pragma Assert (I.Node.Next /= null + or else I.Node = Container.Last); if I.Node = J.Node then return; end if; pragma Assert (Container.Length >= 2); + pragma Assert (J.Node /= null); + pragma Assert (J.Node.Element /= null); + pragma Assert (J.Node.Prev = null + or else J.Node.Prev.Next = J.Node); + pragma Assert (J.Node.Next = null + or else J.Node.Next.Prev = J.Node); + pragma Assert (J.Node.Prev /= null + or else J.Node = Container.First); + pragma Assert (J.Node.Next /= null + or else J.Node = Container.Last); + + if Container.Busy > 0 then + raise Program_Error; + end if; declare I_Next : constant Cursor := Next (I); @@ -1278,6 +1865,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end; end if; end; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); end Swap_Links; -------------------- @@ -1288,8 +1878,43 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is + pragma Assert (Position.Container /= null); + pragma Assert (Position.Container.Length > 0); + pragma Assert (Position.Container.First.Prev = null); + pragma Assert (Position.Container.Last.Next = null); + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Position.Node.Prev = null + or else Position.Node.Prev.Next = Position.Node); + pragma Assert (Position.Node.Next = null + or else Position.Node.Next.Prev = Position.Node); + pragma Assert (Position.Node.Prev /= null + or else Position.Node = Position.Container.First); + pragma Assert (Position.Node.Next /= null + or else Position.Node = Position.Container.Last); + + E : Element_Type renames Position.Node.Element.all; + + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin - Process (Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; ----------- @@ -1310,5 +1935,3 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Write; end Ada.Containers.Indefinite_Doubly_Linked_Lists; - - diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index 2f4ebcb..07341a8 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ D O U B L Y _ L I N K E D _ L I S T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -118,16 +119,16 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Count : Count_Type := 1); generic - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - procedure Generic_Sort (Container : in out List); + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is - generic - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - procedure Generic_Merge - (Target : in out List; - Source : in out List); + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; procedure Reverse_List (Container : in out List); @@ -149,7 +150,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is (Target : in out List; Before : Cursor; Source : in out List; - Position : Cursor); + Position : in out Cursor); function First (Container : List) return Cursor; @@ -198,14 +199,12 @@ private type Element_Access is access Element_Type; type Node_Type is - record + limited record Element : Element_Access; Next : Node_Access; Prev : Node_Access; end record; - function "=" (L, R : Node_Type) return Boolean is abstract; - use Ada.Finalization; type List is @@ -213,6 +212,8 @@ private First : Node_Access; Last : Node_Access; Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; end record; procedure Adjust (Container : in out List); @@ -233,7 +234,7 @@ private for List'Write use Write; - Empty_List : constant List := List'(Controlled with null, null, 0); + Empty_List : constant List := List'(Controlled with null, null, 0, 0, 0); type List_Access is access constant List; for List_Access'Storage_Size use 0; @@ -247,5 +248,3 @@ private No_Element : constant Cursor := Cursor'(null, null); end Ada.Containers.Indefinite_Doubly_Linked_Lists; - - diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index c0bfaed..8467800 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ H A S H E D _ M A P S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -43,15 +44,6 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Indefinite_Hashed_Maps is - type Key_Access is access Key_Type; - type Element_Access is access Element_Type; - - type Node_Type is limited record - Key : Key_Access; - Element : Element_Access; - Next : Node_Access; - end record; - procedure Free_Key is new Ada.Unchecked_Deallocation (Key_Type, Key_Access); @@ -65,17 +57,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Copy_Node (Node : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + pragma Inline (Equivalent_Key_Node); function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean; procedure Free (X : in out Node_Access); - pragma Inline (Free); + -- pragma Inline (Free); function Hash_Node (Node : Node_Access) return Hash_Type; pragma Inline (Hash_Node); @@ -89,6 +81,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); + function Vet (Position : Cursor) return Boolean; + procedure Write_Node (Stream : access Root_Stream_Type'Class; Node : Node_Access); @@ -100,8 +94,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations (HT_Types => HT_Types, - Hash_Table_Type => Map, - Null_Node => null, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next, @@ -111,13 +103,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is package Key_Ops is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Map, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Key_Type, Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + Equivalent_Keys => Equivalent_Key_Node); --------- -- "=" -- @@ -125,26 +115,37 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); - function "=" (Left, Right : Map) return Boolean renames Is_Equal; + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; ------------ -- Adjust -- ------------ - procedure Adjust (Container : in out Map) renames HT_Ops.Adjust; + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; -------------- -- Capacity -- -------------- - function Capacity (Container : Map) - return Count_Type renames HT_Ops.Capacity; + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; ----------- -- Clear -- ----------- - procedure Clear (Container : in out Map) renames HT_Ops.Clear; + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; -------------- -- Contains -- @@ -182,7 +183,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then raise Constraint_Error; @@ -193,7 +194,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position = No_Element then + if Position.Node = null then + raise Constraint_Error; return; end if; @@ -201,9 +203,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Program_Error; end if; - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Position.Node); + pragma Assert (Position.Node.Next /= Position.Node); + pragma Assert (Position.Node.Key /= null); + pragma Assert (Position.Node.Element /= null); + + if Container.HT.Busy > 0 then + raise Program_Error; + end if; + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + Free (Position.Node); Position.Container := null; end Delete; @@ -219,23 +229,30 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Element.all; end Element; - --------------------- - -- Equivalent_Keys -- - --------------------- + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean is begin return Equivalent_Keys (Key, Node.Key.all); - end Equivalent_Keys; + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin + pragma Assert (Vet (Left)); + pragma Assert (Vet (Right)); return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); end Equivalent_Keys; @@ -244,6 +261,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Key_Type) return Boolean is begin + pragma Assert (Vet (Left)); return Equivalent_Keys (Left.Node.Key.all, Right); end Equivalent_Keys; @@ -252,6 +270,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Cursor) return Boolean is begin + pragma Assert (Vet (Right)); return Equivalent_Keys (Left, Right.Node.Key.all); end Equivalent_Keys; @@ -262,7 +281,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Exclude (Container : in out Map; Key : Key_Type) is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); Free (X); end Exclude; @@ -270,14 +289,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -- Finalize -- -------------- - procedure Finalize (Container : in out Map) renames HT_Ops.Finalize; + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; ---------- -- Find -- ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin if Node = null then @@ -292,11 +314,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -------------------- function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean is - R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all); - R_Node : Node_Access := R_Map.Buckets (R_Index); + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all); + R_Node : Node_Access := R_HT.Buckets (R_Index); begin while R_Node /= null loop @@ -315,7 +337,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ----------- function First (Container : Map) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container); + Node : constant Node_Access := HT_Ops.First (Container.HT); begin if Node = null then return No_Element; @@ -332,11 +354,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); begin - if X /= null then + if X = null then + return; + end if; + + X.Next := X; -- detect mischief (in Vet) + + begin Free_Key (X.Key); + exception + when others => + X.Key := null; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + end; + + Deallocate (X); + raise; + end; + + begin Free_Element (X.Element); - Deallocate (X); - end if; + exception + when others => + X.Element := null; + + Deallocate (X); + raise; + end; + + Deallocate (X); end Free; ----------------- @@ -345,7 +396,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Has_Element (Position : Cursor) return Boolean is begin - return Position /= No_Element; + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; + + pragma Assert (Vet (Position)); + return True; end Has_Element; --------------- @@ -376,11 +433,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + K := Position.Node.Key; E := Position.Node.Element; Position.Node.Key := new Key_Type'(Key); - Position.Node.Element := new Element_Type'(New_Item); + + begin + Position.Node.Element := new Element_Type'(New_Item); + exception + when others => + Free_Key (K); + raise; + end; Free_Key (K); Free_Element (E); @@ -420,11 +488,17 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise; end New_Node; + HT : Hash_Table_Type renames Container.HT; + -- Start of processing for Insert begin - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Insert (Container, Key, Position.Node, Inserted); + if HT.Length >= HT_Ops.Capacity (HT) then + -- TODO: see note in a-cohama.adb. + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; + + Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -450,7 +524,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Is_Empty (Container : Map) return Boolean is begin - return Container.Length = 0; + return Container.HT.Length = 0; end Is_Empty; ------------- @@ -479,7 +553,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -- Start of processing Iterate begin - Iterate (Container); + Iterate (Container.HT); end Iterate; --------- @@ -488,6 +562,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Key.all; end Key; @@ -497,7 +572,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Length (Container : Map) return Count_Type is begin - return Container.Length; + return Container.HT.Length; end Length; ---------- @@ -506,7 +581,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Move (Target : in out Map; - Source : in out Map) renames HT_Ops.Move; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; ---------- -- Next -- @@ -524,13 +603,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Next (Position : Cursor) return Cursor is begin - if Position = No_Element then + if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; declare - M : Map renames Position.Container.all; - Node : constant Node_Access := HT_Ops.Next (M, Position.Node); + pragma Assert (Vet (Position)); + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); begin if Node = null then @@ -547,10 +628,35 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Query_Element (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key.all, Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -561,7 +667,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Read (Stream : access Root_Stream_Type'Class; - Container : out Map) renames Read_Nodes; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; --------------- -- Read_Node -- @@ -602,7 +712,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Key : Key_Type; New_Item : Element_Type) is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); K : Key_Access; E : Element_Access; @@ -612,11 +722,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Constraint_Error; end if; + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + K := Node.Key; E := Node.Element; Node.Key := new Key_Type'(Key); - Node.Element := new Element_Type'(New_Item); + + begin + Node.Element := new Element_Type'(New_Item); + exception + when others => + Free_Key (K); + raise; + end; Free_Key (K); Free_Element (E); @@ -627,8 +748,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is + pragma Assert (Vet (Position)); X : Element_Access := Position.Node.Element; begin + if Position.Container.HT.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Element := new Element_Type'(By); Free_Element (X); end Replace_Element; @@ -639,7 +765,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Reserve_Capacity (Container : in out Map; - Capacity : Count_Type) renames HT_Ops.Ensure_Capacity; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; -------------- -- Set_Next -- @@ -656,12 +786,93 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key.all, Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Key = null then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null then + return False; + end if; + + X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- weird + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + ----------- -- Write -- ----------- @@ -670,7 +881,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Write (Stream : access Root_Stream_Type'Class; - Container : Map) renames Write_Nodes; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; ---------------- -- Write_Node -- @@ -686,4 +901,3 @@ package body Ada.Containers.Indefinite_Hashed_Maps is end Write_Node; end Ada.Containers.Indefinite_Hashed_Maps; - diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 7769cbb..1f15c58 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ H A S H E D _ M A P S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,6 +36,7 @@ with Ada.Containers.Hash_Tables; with Ada.Streams; +with Ada.Finalization; generic type Key_Type (<>) is private; @@ -61,6 +63,8 @@ package Ada.Containers.Indefinite_Hashed_Maps is procedure Clear (Container : in out Map); + function Key (Position : Cursor) return Key_Type; + function Element (Position : Cursor) return Element_Type; procedure Query_Element @@ -105,14 +109,14 @@ package Ada.Containers.Indefinite_Hashed_Maps is (Container : in out Map; Key : Key_Type); - procedure Exclude - (Container : in out Map; - Key : Key_Type); - procedure Delete (Container : in out Map; Position : in out Cursor); + procedure Exclude + (Container : in out Map; + Key : Key_Type); + function Contains (Container : Map; Key : Key_Type) return Boolean; @@ -125,12 +129,6 @@ package Ada.Containers.Indefinite_Hashed_Maps is (Container : Map; Key : Key_Type) return Element_Type; - function Capacity (Container : Map) return Count_Type; - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type); - function First (Container : Map) return Cursor; function Next (Position : Cursor) return Cursor; @@ -139,8 +137,6 @@ package Ada.Containers.Indefinite_Hashed_Maps is function Has_Element (Position : Cursor) return Boolean; - function Key (Position : Cursor) return Key_Type; - function Equivalent_Keys (Left, Right : Cursor) return Boolean; @@ -156,16 +152,48 @@ package Ada.Containers.Indefinite_Hashed_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)); + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type); + private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + type Node_Type; type Node_Access is access Node_Type; - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + type Key_Access is access Key_Type; + type Element_Access is access Element_Type; - use HT_Types; + type Node_Type is limited record + Key : Key_Access; + Element : Element_Access; + Next : Node_Access; + end record; + + package HT_Types is new Hash_Tables.Generic_Hash_Table_Types + (Node_Type, + Node_Access); + + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; - type Map is new Hash_Table_Type with null record; + use HT_Types; + use Ada.Finalization; procedure Adjust (Container : in out Map); @@ -198,9 +226,6 @@ private for Map'Read use Read; - Empty_Map : constant Map := (Hash_Table_Type with null record); + Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); end Ada.Containers.Indefinite_Hashed_Maps; - - - diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index cc5589f..f47d9a6 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ H A S H E D _ S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -45,849 +46,1184 @@ with System; use type System.Address; with Ada.Containers.Prime_Numbers; -with Ada.Finalization; use Ada.Finalization; - package body Ada.Containers.Indefinite_Hashed_Sets is - type Element_Access is access Element_Type; + ----------------------- + -- Local Subprograms -- + ----------------------- - type Node_Type is - limited record - Element : Element_Access; - Next : Node_Access; - end record; + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); - function Hash_Node - (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); - function Hash_Node - (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Element.all); - end Hash_Node; + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; - function Next - (Node : Node_Access) return Node_Access; - pragma Inline (Next); + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; - function Next - (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; + procedure Free (X : in out Node_Access); - procedure Set_Next - (Node : Node_Access; - Next : Node_Access); - pragma Inline (Set_Next); + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); - procedure Set_Next - (Node : Node_Access; - Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; + pragma Inline (Is_In); - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Node.Element.all); - end Equivalent_Keys; + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); - function Copy_Node - (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); + procedure Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Element : Element_Type); - function Copy_Node - (Source : Node_Access) return Node_Access is + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); - Target : constant Node_Access := - new Node_Type'(Element => Source.Element, - Next => null); - begin - return Target; - end Copy_Node; + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + -------------------------- + -- Local Instantiations -- + -------------------------- procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - procedure Free (X : in out Node_Access); - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - begin - if X /= null then - Free_Element (X.Element); - Deallocate (X); - end if; - end Free; - package HT_Ops is new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Table_Type => Set, - Null_Node => null, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); package Element_Keys is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Set, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Element_Type, Hash => Hash, Equivalent_Keys => Equivalent_Keys); + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); - procedure Adjust (Container : in out Set) renames HT_Ops.Adjust; - - procedure Finalize (Container : in out Set) renames HT_Ops.Finalize; - - - function Find_Equal_Key - (R_Set : Set; - L_Node : Node_Access) return Boolean; + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); - function Find_Equal_Key - (R_Set : Set; - L_Node : Node_Access) return Boolean is + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); - R_Index : constant Hash_Type := - Element_Keys.Index (R_Set, L_Node.Element.all); + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); - R_Node : Node_Access := R_Set.Buckets (R_Index); + --------- + -- "=" -- + --------- + function "=" (Left, Right : Set) return Boolean is begin + return Is_Equal (Left.HT, Right.HT); + end "="; - loop - - if R_Node = null then - return False; - end if; - - if L_Node.Element.all = R_Node.Element.all then - return True; - end if; - - R_Node := Next (R_Node); - - end loop; - - end Find_Equal_Key; - - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); + ------------ + -- Adjust -- + ------------ - function "=" (Left, Right : Set) return Boolean renames Is_Equal; + procedure Adjust (Container : in out Set) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + -------------- + -- Capacity -- + -------------- - function Length (Container : Set) return Count_Type is + function Capacity (Container : Set) return Count_Type is begin - return Container.Length; - end Length; + return HT_Ops.Capacity (Container.HT); + end Capacity; + ----------- + -- Clear -- + ----------- - function Is_Empty (Container : Set) return Boolean is + procedure Clear (Container : in out Set) is begin - return Container.Length = 0; - end Is_Empty; + HT_Ops.Clear (Container.HT); + end Clear; + -------------- + -- Contains -- + -------------- - procedure Clear (Container : in out Set) renames HT_Ops.Clear; + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + --------------- + -- Copy_Node -- + --------------- - function Element (Position : Cursor) return Element_Type is + function Copy_Node (Source : Node_Access) return Node_Access is + E : Element_Access := new Element_Type'(Source.Element.all); begin - return Position.Node.Element.all; - end Element; + return new Node_Type'(Element => E, Next => null); + exception + when others => + Free_Element (E); + raise; + end Copy_Node; + ------------ + -- Delete -- + ------------ - procedure Query_Element - (Position : in Cursor; - Process : not null access procedure (Element : in Element_Type)) is - begin - Process (Position.Node.Element.all); - end Query_Element; + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); --- TODO: --- procedure Replace_Element (Container : in out Set; --- Position : in Node_Access; --- By : in Element_Type); + if X = null then + raise Constraint_Error; + end if; --- procedure Replace_Element (Container : in out Set; --- Position : in Node_Access; --- By : in Element_Type) is + Free (X); + end Delete; --- Node : Node_Access := Position; + procedure Delete + (Container : in out Set; + Position : in out Cursor) + is + begin + if Position.Node = null then + raise Constraint_Error; + end if; --- begin + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; --- if Equivalent_Keys (Node.Element.all, By) then + if Container.HT.Busy > 0 then + raise Program_Error; + end if; --- declare --- X : Element_Access := Node.Element; --- begin --- Node.Element := new Element_Type'(By); --- -- --- -- NOTE: If there's an exception here, then just --- -- let it propagate. We haven't modified the --- -- state of the container, so there's nothing else --- -- we need to do. + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); --- Free_Element (X); --- end; + Free (Position.Node); --- return; + Position.Container := null; + end Delete; --- end if; + ---------------- + -- Difference -- + ---------------- --- HT_Ops.Delete_Node_Sans_Free (Container, Node); + procedure Difference + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; --- begin --- Free_Element (Node.Element); --- exception --- when others => --- Node.Element := null; -- don't attempt to dealloc X.E again --- Free (Node); --- raise; --- end; + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; --- begin --- Node.Element := new Element_Type'(By); --- exception --- when others => --- Free (Node); --- raise; --- end; + if Source.Length = 0 then + return; + end if; --- declare --- function New_Node (Next : Node_Access) return Node_Access; --- pragma Inline (New_Node); + if Target.HT.Busy > 0 then + raise Program_Error; + end if; --- function New_Node (Next : Node_Access) return Node_Access is --- begin --- Node.Next := Next; --- return Node; --- end New_Node; + -- TODO: This can be written in terms of a loop instead as + -- active-iterator style, sort of like a passive iterator. --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (New_Node); + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.HT, Tgt_Node) then + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; --- Result : Node_Access; --- Success : Boolean; --- begin --- Insert --- (HT => Container, --- Key => Node.Element.all, --- Node => Result, --- Success => Success); + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end Difference; --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; + function Difference (Left, Right : Set) return Set is + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; --- pragma Assert (Result = Node); --- end; + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; --- end Replace_Element; + if Left.Length = 0 then + return Empty_Set; + end if; + if Right.Length = 0 then + return Left; + end if; --- procedure Replace_Element (Container : in out Set; --- Position : in Cursor; --- By : in Element_Type) is --- begin + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; --- if Position.Container = null then --- raise Constraint_Error; --- end if; + Length := 0; --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; + Iterate_Left : declare + procedure Process (L_Node : Node_Access); --- Replace_Element (Container, Position.Node, By); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); --- end Replace_Element; + ------------- + -- Process -- + ------------- + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right.HT, L_Node) then + declare + Indx : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; - procedure Move (Target : in out Set; - Source : in out Set) renames HT_Ops.Move; + Bucket : Node_Access renames Buckets (Indx); + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; - procedure Insert (Container : in out Set; - New_Item : in Element_Type; - Position : out Cursor; - Inserted : out Boolean) is + Length := Length + 1; + end if; + end Process; - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + -- Start of processing for Iterate_Left - function New_Node (Next : Node_Access) return Node_Access is - Element : Element_Access := new Element_Type'(New_Item); begin - return new Node_Type'(Element, Next); + Iterate (Left.HT); exception when others => - Free_Element (Element); + HT_Ops.Free_Hash_Table (Buckets); raise; - end New_Node; + end Iterate_Left; - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Difference; + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is begin + return Position.Node.Element.all; + end Element; - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Insert (Container, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + --------------------- + -- Equivalent_Sets -- + --------------------- - end Insert; + function Equivalent_Sets (Left, Right : Set) return Boolean is + begin + return Is_Equivalent (Left.HT, Right.HT); + end Equivalent_Sets; + ------------------------- + -- Equivalent_Elements -- + ------------------------- - procedure Insert (Container : in out Set; - New_Item : in Element_Type) is + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + begin + return Equivalent_Elements + (Left.Node.Element.all, + Right.Node.Element.all); + end Equivalent_Elements; - Position : Cursor; - Inserted : Boolean; + function Equivalent_Elements (Left : Cursor; Right : Element_Type) + return Boolean is + begin + return Equivalent_Elements (Left.Node.Element.all, Right); + end Equivalent_Elements; + function Equivalent_Elements (Left : Element_Type; Right : Cursor) + return Boolean is begin + return Equivalent_Elements (Left, Right.Node.Element.all); + end Equivalent_Elements; - Insert (Container, New_Item, Position, Inserted); + --------------------- + -- Equivalent_Keys -- + --------------------- - if not Inserted then - raise Constraint_Error; - end if; + function Equivalent_Keys (Key : Element_Type; Node : Node_Access) + return Boolean is + begin + return Equivalent_Elements (Key, Node.Element.all); + end Equivalent_Keys; - end Insert; + ------------- + -- Exclude -- + ------------- + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + Free (X); + end Exclude; - procedure Replace (Container : in out Set; - New_Item : in Element_Type) is + -------------- + -- Finalize -- + -------------- - Node : constant Node_Access := - Element_Keys.Find (Container, New_Item); + procedure Finalize (Container : in out Set) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; - X : Element_Access; + ---------- + -- Find -- + ---------- - begin + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); + begin if Node = null then - raise Constraint_Error; + return No_Element; end if; - X := Node.Element; + return Cursor'(Container'Unrestricted_Access, Node); + end Find; - Node.Element := new Element_Type'(New_Item); + -------------------- + -- Find_Equal_Key -- + -------------------- - Free_Element (X); + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element.all); - end Replace; + R_Node : Node_Access := R_HT.Buckets (R_Index); + begin + loop + if R_Node = null then + return False; + end if; - procedure Include (Container : in out Set; - New_Item : in Element_Type) is + if L_Node.Element.all = R_Node.Element.all then + return True; + end if; - Position : Cursor; - Inserted : Boolean; + R_Node := Next (R_Node); + end loop; + end Find_Equal_Key; - X : Element_Access; + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- - begin + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element.all); - Insert (Container, New_Item, Position, Inserted); + R_Node : Node_Access := R_HT.Buckets (R_Index); - if not Inserted then + begin + loop + if R_Node = null then + return False; + end if; - X := Position.Node.Element; + if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then + return True; + end if; - Position.Node.Element := new Element_Type'(New_Item); + R_Node := Next (R_Node); + end loop; + end Find_Equivalent_Key; - Free_Element (X); + ----------- + -- First -- + ----------- - end if; + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); - end Include; + begin + if Node = null then + return No_Element; + end if; + return Cursor'(Container'Unrestricted_Access, Node); + end First; - procedure Delete (Container : in out Set; - Item : in Element_Type) is + ---------- + -- Free -- + ---------- - X : Node_Access; + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); begin - - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - if X = null then - raise Constraint_Error; + return; end if; - Free (X); + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; - end Delete; + Deallocate (X); + end Free; + ----------------- + -- Has_Element -- + ----------------- - procedure Exclude (Container : in out Set; - Item : in Element_Type) is + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; - X : Node_Access; + return True; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + function Hash_Node (Node : Node_Access) return Hash_Type is begin + return Hash (Node.Element.all); + end Hash_Node; - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - Free (X); + ------------- + -- Include -- + ------------- - end Exclude; + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + X : Element_Access; - procedure Delete (Container : in out Set; - Position : in out Cursor) is begin + Insert (Container, New_Item, Position, Inserted); - if Position = No_Element then - return; - end if; + if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; + X := Position.Node.Element; - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Position.Node); + Position.Node.Element := new Element_Type'(New_Item); - Position.Container := null; + Free_Element (X); + end if; + end Include; - end Delete; + ------------ + -- Insert -- + ------------ + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - procedure Union (Target : in out Set; - Source : in Set) is + -------------- + -- New_Node -- + -------------- - procedure Process (Src_Node : in Node_Access); + function New_Node (Next : Node_Access) return Node_Access is + Element : Element_Access := new Element_Type'(New_Item); - procedure Process (Src_Node : in Node_Access) is + begin + return new Node_Type'(Element, Next); + exception + when others => + Free_Element (Element); + raise; + end New_Node; - Src : Element_Type renames Src_Node.Element.all; + HT : Hash_Table_Type renames Container.HT; - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + -- Start of processing for Insert - function New_Node (Next : Node_Access) return Node_Access is - Tgt : Element_Access := new Element_Type'(Src); - begin - return new Node_Type'(Tgt, Next); - exception - when others => - Free_Element (Tgt); - raise; - end New_Node; + begin + if HT.Length >= HT_Ops.Capacity (HT) then + -- TODO: optimize this (see a-cohase.adb) + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); + Insert (HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; - Tgt_Node : Node_Access; - Success : Boolean; + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; - begin + begin + Insert (Container, New_Item, Position, Inserted); - Insert (Target, Src, Tgt_Node, Success); + if not Inserted then + raise Constraint_Error; + end if; + end Insert; - end Process; + ------------------ + -- Intersection -- + ------------------ - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + procedure Intersection + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; begin - if Target'Address = Source'Address then return; end if; - HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); - - Iterate (Source); + if Source.Length = 0 then + Clear (Target); + return; + end if; - end Union; + if Target.HT.Busy > 0 then + raise Program_Error; + end if; + -- TODO: optimize this to use an explicit + -- loop instead of an active iterator + -- (similar to how a passive iterator is + -- implemented). + -- + -- Another possibility is to test which + -- set is smaller, and iterate over the + -- smaller set. + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.HT, Tgt_Node) then + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - function Union (Left, Right : Set) return Set is + else + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + end if; + end loop; + end Intersection; + function Intersection (Left, Right : Set) return Set is Buckets : HT_Types.Buckets_Access; Length : Count_Type; begin - if Left'Address = Right'Address then return Left; end if; - if Right.Length = 0 then - return Left; - end if; + Length := Count_Type'Min (Left.Length, Right.Length); - if Left.Length = 0 then - return Right; + if Length = 0 then + return Empty_Set; end if; declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); begin Buckets := new Buckets_Type (0 .. Size - 1); end; - declare + Length := 0; + + Iterate_Left : declare procedure Process (L_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (L_Node : Node_Access) is - I : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + if Is_In (Right.HT, L_Node) then + declare + Indx : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; + + Bucket : Node_Access renames Buckets (Indx); + + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + + Length := Length + 1; + end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Left + begin - Iterate (Left); + Iterate (Left.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; + end Iterate_Left; - Length := Left.Length; + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Intersection; - declare - procedure Process (Src_Node : Node_Access); + -------------- + -- Is_Empty -- + -------------- - procedure Process (Src_Node : Node_Access) is + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; - Src : Element_Type renames Src_Node.Element.all; + ----------- + -- Is_In -- + ----------- - I : constant Hash_Type := - Hash (Src) mod Buckets'Length; + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element.all) /= null; + end Is_In; - Tgt_Node : Node_Access := Buckets (I); + --------------- + -- Is_Subset -- + --------------- - begin + function Is_Subset + (Subset : Set; + Of_Set : Set) return Boolean + is + Subset_Node : Node_Access; - while Tgt_Node /= null loop + begin + if Subset'Address = Of_Set'Address then + return True; + end if; - if Equivalent_Keys (Src, Tgt_Node.Element.all) then - return; - end if; + if Subset.Length > Of_Set.Length then + return False; + end if; - Tgt_Node := Next (Tgt_Node); + -- TODO: rewrite this to loop in the + -- style of a passive iterator. - end loop; + Subset_Node := HT_Ops.First (Subset.HT); + while Subset_Node /= null loop + if not Is_In (Of_Set.HT, Subset_Node) then + return False; + end if; - declare - Tgt : Element_Access := new Element_Type'(Src); - begin - Buckets (I) := new Node_Type'(Tgt, Buckets (I)); - exception - when others => - Free_Element (Tgt); - raise; - end; + Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); + end loop; - Length := Length + 1; + return True; + end Is_Subset; - end Process; + ------------- + -- Iterate -- + ------------- - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - begin - Iterate (Right); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end; + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); - return (Controlled with Buckets, Length); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); - end Union; + ------------------ + -- Process_Node -- + ------------------ + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; - function Is_In - (HT : Set; - Key : Node_Access) return Boolean; - pragma Inline (Is_In); + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; + + -- Start of processing for Iterate - function Is_In - (HT : Set; - Key : Node_Access) return Boolean is begin - return Element_Keys.Find (HT, Key.Element.all) /= null; - end Is_In; + B := B + 1; + begin + Iterate (HT); + exception + when others => + B := B - 1; + raise; + end; - procedure Intersection (Target : in out Set; - Source : in Set) is + B := B - 1; + end Iterate; - Tgt_Node : Node_Access; + ------------ + -- Length -- + ------------ + function Length (Container : Set) return Count_Type is begin + return Container.HT.Length; + end Length; - if Target'Address = Source'Address then - return; - end if; - - if Source.Length = 0 then - Clear (Target); - return; - end if; - - -- TODO: optimize this to use an explicit - -- loop instead of an active iterator - -- (similar to how a passive iterator is - -- implemented). - -- - -- Another possibility is to test which - -- set is smaller, and iterate over the - -- smaller set. - - Tgt_Node := HT_Ops.First (Target); + ---------- + -- Move -- + ---------- - while Tgt_Node /= null loop + procedure Move (Target : in out Set; Source : in out Set) is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; - if Is_In (Source, Tgt_Node) then + ---------- + -- Next -- + ---------- - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; - else + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + pragma Assert (Position.Container = null); + return No_Element; + end if; - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (X); - end; + declare + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); + begin + if Node = null then + return No_Element; end if; - end loop; - - end Intersection; + return Cursor'(Position.Container, Node); + end; + end Next; + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; - function Intersection (Left, Right : Set) return Set is + ------------- + -- Overlap -- + ------------- - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + function Overlap (Left, Right : Set) return Boolean is + Left_Node : Node_Access; begin + if Right.Length = 0 then + return False; + end if; if Left'Address = Right'Address then - return Left; + return True; end if; - Length := Count_Type'Min (Left.Length, Right.Length); - - if Length = 0 then - return Empty_Set; - end if; + Left_Node := HT_Ops.First (Left.HT); + while Left_Node /= null loop + if Is_In (Right.HT, Left_Node) then + return True; + end if; - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); - begin - Buckets := new Buckets_Type (0 .. Size - 1); - end; + Left_Node := HT_Ops.Next (Left.HT, Left_Node); + end loop; - Length := 0; + return False; + end Overlap; - declare - procedure Process (L_Node : Node_Access); + ------------------- + -- Query_Element -- + ------------------- - procedure Process (L_Node : Node_Access) is - begin - if Is_In (Right, L_Node) then + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + E : Element_Type renames Position.Node.Element.all; - declare - I : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; - begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); - end; + HT : Hash_Table_Type renames + Position.Container'Unrestricted_Access.all.HT; - Length := Length + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; - end if; - end Process; + begin + B := B + 1; + L := L + 1; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); begin - Iterate (Left); + Process (E); exception when others => - HT_Ops.Free_Hash_Table (Buckets); + L := L - 1; + B := B - 1; raise; end; - return (Controlled with Buckets, Length); - - end Intersection; + L := L - 1; + B := B - 1; + end Query_Element; + ---------- + -- Read -- + ---------- - procedure Difference (Target : in out Set; - Source : in Set) is + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + --------------- + -- Read_Node -- + --------------- - Tgt_Node : Node_Access; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is + X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); begin + return new Node_Type'(X, null); + exception + when others => + Free_Element (X); + raise; + end Read_Node; - if Target'Address = Source'Address then - Clear (Target); - return; - end if; + ------------- + -- Replace -- + ------------- - if Source.Length = 0 then - return; - end if; + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Node_Access := + Element_Keys.Find (Container.HT, New_Item); + + X : Element_Access; - -- TODO: As I noted above, this can be - -- written in terms of a loop instead as - -- active-iterator style, sort of like a - -- passive iterator. + begin + if Node = null then + raise Constraint_Error; + end if; - Tgt_Node := HT_Ops.First (Target); + if Container.HT.Lock > 0 then + raise Program_Error; + end if; - while Tgt_Node /= null loop + X := Node.Element; - if Is_In (Source, Tgt_Node) then + Node.Element := new Element_Type'(New_Item); - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (X); - end; + Free_Element (X); + end Replace; - else + --------------------- + -- Replace_Element -- + --------------------- - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + procedure Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Element : Element_Type) + is + begin + if Equivalent_Elements (Node.Element.all, Element) then + pragma Assert (Hash (Node.Element.all) = Hash (Element)); + if HT.Lock > 0 then + raise Program_Error; end if; - end loop; + declare + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Element); -- OK if fails + Free_Element (X); + end; - end Difference; + return; + end if; + if HT.Busy > 0 then + raise Program_Error; + end if; + HT_Ops.Delete_Node_Sans_Free (HT, Node); - function Difference (Left, Right : Set) return Set is + Insert_New_Element : declare + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - begin + ------------------------ + -- Insert_New_Element -- + ------------------------ - if Left'Address = Right'Address then - return Empty_Set; - end if; + function New_Node (Next : Node_Access) return Node_Access is + begin + Node.Element := new Element_Type'(Element); -- OK if fails + Node.Next := Next; + return Node; + end New_Node; - if Left.Length = 0 then - return Empty_Set; - end if; + Result : Node_Access; + Inserted : Boolean; - if Right.Length = 0 then - return Left; - end if; + X : Element_Access := Node.Element; + + -- Start of processing for Insert_New_Element - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); - end; + Attempt_Insert : begin + Insert + (HT => HT, + Key => Element, + Node => Result, + Inserted => Inserted); + exception + when others => + Inserted := False; -- Assignment failed + end Attempt_Insert; - Length := 0; + if Inserted then + pragma Assert (Result = Node); + Free_Element (X); -- Just propagate if fails + return; + end if; + end Insert_New_Element; + Reinsert_Old_Element : declare - procedure Process (L_Node : Node_Access); + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right, L_Node) then + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - declare - I : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; - begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); - end; + -------------- + -- New_Node -- + -------------- - Length := Length + 1; + function New_Node (Next : Node_Access) return Node_Access is + begin + Node.Next := Next; + return Node; + end New_Node; - end if; - end Process; + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Reinsert_Old_Element - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); begin - Iterate (Left); + Insert + (HT => HT, + Key => Node.Element.all, + Node => Result, + Inserted => Inserted); exception when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end; + null; + end Reinsert_Old_Element; - return (Controlled with Buckets, Length); + raise Program_Error; + end Replace_Element; - end Difference; + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + if Position.Container /= Set_Access'(Container'Unrestricted_Access) then + raise Program_Error; + end if; + Replace_Element (HT, Position.Node, By); + end Replace_Element; - procedure Symmetric_Difference (Target : in out Set; - Source : in Set) is + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + begin if Target'Address = Source'Address then Clear (Target); return; end if; - HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + if Target.HT.Busy > 0 then + raise Program_Error; + end if; - if Target.Length = 0 then + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); + end if; + end; - declare + if Target.Length = 0 then + Iterate_Source_When_Empty_Target : declare procedure Process (Src_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Target.Buckets.all; - I : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.Length; + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; + begin declare X : Element_Access := new Element_Type'(E); begin - B (I) := new Node_Type'(X, B (I)); + B (J) := new Node_Type'(X, B (J)); exception when others => Free_Element (X); @@ -897,29 +1233,35 @@ package body Ada.Containers.Indefinite_Hashed_Sets is N := N + 1; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Source_When_Empty_Target + begin - Iterate (Source); - end; + Iterate (Source.HT); + end Iterate_Source_When_Empty_Target; else - - declare + Iterate_Source : declare procedure Process (Src_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Target.Buckets.all; - I : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.Length; - begin - if B (I) = null then + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; + begin + if B (J) = null then declare X : Element_Access := new Element_Type'(E); begin - B (I) := new Node_Type'(X, null); + B (J) := new Node_Type'(X, null); exception when others => Free_Element (X); @@ -928,24 +1270,23 @@ package body Ada.Containers.Indefinite_Hashed_Sets is N := N + 1; - elsif Equivalent_Keys (E, B (I).Element.all) then - + elsif Equivalent_Elements (E, B (J).Element.all) then declare - X : Node_Access := B (I); + X : Node_Access := B (J); begin - B (I) := B (I).Next; + B (J) := B (J).Next; N := N - 1; Free (X); end; else - declare - Prev : Node_Access := B (I); + Prev : Node_Access := B (J); Curr : Node_Access := Prev.Next; + begin while Curr /= null loop - if Equivalent_Keys (E, Curr.Element.all) then + if Equivalent_Elements (E, Curr.Element.all) then Prev.Next := Curr.Next; N := N - 1; Free (Curr); @@ -959,7 +1300,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare X : Element_Access := new Element_Type'(E); begin - B (I) := new Node_Type'(X, B (I)); + B (J) := new Node_Type'(X, B (J)); exception when others => Free_Element (X); @@ -968,28 +1309,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is N := N + 1; end; - end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - begin - Iterate (Source); - end; + -- Start of processing for Iterate_Source + begin + Iterate (Source.HT); + end Iterate_Source; end if; - end Symmetric_Difference; - function Symmetric_Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; Length : Count_Type; begin - if Left'Address = Right'Address then return Empty_Set; end if; @@ -1004,28 +1339,35 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); + Prime_Numbers.To_Prime (Left.Length + Right.Length); begin Buckets := new Buckets_Type (0 .. Size - 1); end; Length := 0; - declare + Iterate_Left : declare procedure Process (L_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right, L_Node) then + if not Is_In (Right.HT, L_Node) then declare E : Element_Type renames L_Node.Element.all; - I : constant Hash_Type := Hash (E) mod Buckets'Length; - begin + J : constant Hash_Type := Hash (E) mod Buckets'Length; + begin declare X : Element_Access := new Element_Type'(E); begin - Buckets (I) := new Node_Type'(X, Buckets (I)); + Buckets (J) := new Node_Type'(X, Buckets (J)); exception when others => Free_Element (X); @@ -1037,31 +1379,38 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Left + begin - Iterate (Left); + Iterate (Left.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; + end Iterate_Left; - declare + Iterate_Right : declare procedure Process (R_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (R_Node : Node_Access) is begin - if not Is_In (Left, R_Node) then + if not Is_In (Left.HT, R_Node) then declare E : Element_Type renames R_Node.Element.all; - I : constant Hash_Type := Hash (E) mod Buckets'Length; - begin + J : constant Hash_Type := Hash (E) mod Buckets'Length; + begin declare X : Element_Access := new Element_Type'(E); begin - Buckets (I) := new Node_Type'(X, Buckets (I)); + Buckets (J) := new Node_Type'(X, Buckets (J)); exception when others => Free_Element (X); @@ -1069,406 +1418,396 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end; Length := Length + 1; - end; end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Right + begin - Iterate (Right); + Iterate (Right.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; - - return (Controlled with Buckets, Length); + end Iterate_Right; + return (Controlled with HT => (Buckets, Length, 0, 0)); end Symmetric_Difference; + ----------- + -- Union -- + ----------- - function Is_Subset (Subset : Set; - Of_Set : Set) return Boolean is + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Node_Access); - Subset_Node : Node_Access; - - begin + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); - if Subset'Address = Of_Set'Address then - return True; - end if; + ------------- + -- Process -- + ------------- - if Subset.Length > Of_Set.Length then - return False; - end if; + procedure Process (Src_Node : Node_Access) is + Src : Element_Type renames Src_Node.Element.all; - -- TODO: rewrite this to loop in the - -- style of a passive iterator. + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - Subset_Node := HT_Ops.First (Subset); + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - while Subset_Node /= null loop - if not Is_In (Of_Set, Subset_Node) then - return False; - end if; + -------------- + -- New_Node -- + -------------- - Subset_Node := HT_Ops.Next (Subset, Subset_Node); - end loop; + function New_Node (Next : Node_Access) return Node_Access is + Tgt : Element_Access := new Element_Type'(Src); - return True; + begin + return new Node_Type'(Tgt, Next); + exception + when others => + Free_Element (Tgt); + raise; + end New_Node; - end Is_Subset; + Tgt_Node : Node_Access; + Success : Boolean; + -- Start of processing for Process - function Overlap (Left, Right : Set) return Boolean is + begin + Insert (Target.HT, Src, Tgt_Node, Success); + end Process; - Left_Node : Node_Access; + -- Start of processing for Union begin - - if Right.Length = 0 then - return False; + if Target'Address = Source'Address then + return; end if; - if Left'Address = Right'Address then - return True; + if Target.HT.Busy > 0 then + raise Program_Error; end if; - Left_Node := HT_Ops.First (Left); - - while Left_Node /= null loop - if Is_In (Right, Left_Node) then - return True; + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); end if; + end; - Left_Node := HT_Ops.Next (Left, Left_Node); - end loop; - - return False; - - end Overlap; - - - function Find (Container : Set; - Item : Element_Type) return Cursor is + Iterate (Source.HT); + end Union; - Node : constant Node_Access := Element_Keys.Find (Container, Item); + function Union (Left, Right : Set) return Set is + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin - - if Node = null then - return No_Element; + if Left'Address = Right'Address then + return Left; end if; - return Cursor'(Container'Unchecked_Access, Node); - - end Find; - - - function Contains (Container : Set; - Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - - - function First (Container : Set) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container); - begin - if Node = null then - return No_Element; + if Right.Length = 0 then + return Left; end if; - return Cursor'(Container'Unchecked_Access, Node); - end First; - - --- function First_Element (Container : Set) return Element_Type is --- Node : constant Node_Access := HT_Ops.First (Container); --- begin --- return Node.Element; --- end First_Element; - - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null - or else Position.Node = null - then - return No_Element; + if Left.Length = 0 then + return Right; end if; declare - S : Set renames Position.Container.all; - Node : constant Node_Access := HT_Ops.Next (S, Position.Node); + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); + Buckets := new Buckets_Type (0 .. Size - 1); end; - end Next; + Iterate_Left : declare + procedure Process (L_Node : Node_Access); - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + ------------- + -- Process -- + ------------- - function Has_Element (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - end if; + procedure Process (L_Node : Node_Access) is + J : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; - if Position.Node = null then - return False; - end if; + Bucket : Node_Access renames Buckets (J); - return True; - end Has_Element; + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end Process; + -- Start of processing for Process - function Equivalent_Keys (Left, Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all); - end Equivalent_Keys; + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + Length := Left.Length; - function Equivalent_Keys (Left : Cursor; - Right : Element_Type) - return Boolean is - begin - return Equivalent_Keys (Left.Node.Element.all, Right); - end Equivalent_Keys; + Iterate_Right : declare + procedure Process (Src_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); - function Equivalent_Keys (Left : Element_Type; - Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left, Right.Node.Element.all); - end Equivalent_Keys; + ------------- + -- Process -- + ------------- + procedure Process (Src_Node : Node_Access) is + Src : Element_Type renames Src_Node.Element.all; + Idx : constant Hash_Type := Hash (Src) mod Buckets'Length; - procedure Iterate - (Container : in Set; - Process : not null access procedure (Position : in Cursor)) is + Tgt_Node : Node_Access := Buckets (Idx); - procedure Process_Node (Node : in Node_Access); - pragma Inline (Process_Node); + begin + while Tgt_Node /= null loop + if Equivalent_Elements (Src, Tgt_Node.Element.all) then + return; + end if; + Tgt_Node := Next (Tgt_Node); + end loop; - procedure Process_Node (Node : in Node_Access) is - begin - Process (Cursor'(Container'Unchecked_Access, Node)); - end Process_Node; + declare + Tgt : Element_Access := new Element_Type'(Src); + begin + Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx)); + exception + when others => + Free_Element (Tgt); + raise; + end; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - begin - Iterate (Container); - end Iterate; + Length := Length + 1; + end Process; + -- Start of processing for Iterate_Right - function Capacity (Container : Set) return Count_Type - renames HT_Ops.Capacity; + begin + Iterate (Right.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; - procedure Reserve_Capacity - (Container : in out Set; - Capacity : in Count_Type) - renames HT_Ops.Ensure_Capacity; + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Union; + ----------- + -- Write -- + ----------- - procedure Write_Node - (Stream : access Root_Stream_Type'Class; - Node : in Node_Access); - pragma Inline (Write_Node); + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + ---------------- + -- Write_Node -- + ---------------- procedure Write_Node (Stream : access Root_Stream_Type'Class; - Node : in Node_Access) is + Node : Node_Access) + is begin Element_Type'Output (Stream, Node.Element.all); end Write_Node; - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - procedure Write - (Stream : access Root_Stream_Type'Class; - Container : in Set) renames Write_Nodes; - - - function Read_Node (Stream : access Root_Stream_Type'Class) - return Node_Access; - pragma Inline (Read_Node); - - function Read_Node (Stream : access Root_Stream_Type'Class) - return Node_Access is - - X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); - begin - return new Node_Type'(X, null); - exception - when others => - Free_Element (X); - raise; - end Read_Node; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - procedure Read - (Stream : access Root_Stream_Type'Class; - Container : out Set) renames Read_Nodes; - - package body Generic_Keys is - function Equivalent_Keys (Left : Cursor; - Right : Key_Type) - return Boolean is - begin - return Equivalent_Keys (Right, Left.Node.Element.all); - end Equivalent_Keys; - - function Equivalent_Keys (Left : Key_Type; - Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left, Right.Node.Element.all); - end Equivalent_Keys; + ----------------------- + -- Local Subprograms -- + ----------------------- - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + pragma Inline (Equivalent_Key_Node); - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Node.Element.all); - end Equivalent_Keys; + -------------------------- + -- Local Instantiations -- + -------------------------- package Key_Keys is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Set, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Key_Type, Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + Equivalent_Keys => Equivalent_Key_Node); + -------------- + -- Contains -- + -------------- - function Find (Container : Set; - Key : Key_Type) - return Cursor is - - Node : constant Node_Access := - Key_Keys.Find (Container, Key); - + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is begin + return Find (Container, Key) /= No_Element; + end Contains; - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unchecked_Access, Node); - - end Find; + ------------ + -- Delete -- + ------------ + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; - function Contains (Container : Set; - Key : Key_Type) return Boolean is begin - return Find (Container, Key) /= No_Element; - end Contains; + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + if X = null then + raise Constraint_Error; + end if; + + Free (X); + end Delete; - function Element (Container : Set; - Key : Key_Type) - return Element_Type is + ------------- + -- Element -- + ------------- - Node : constant Node_Access := Key_Keys.Find (Container, Key); + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin return Node.Element.all; end Element; + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- - function Key (Position : Cursor) return Key_Type is + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean is begin - return Key (Position.Node.Element.all); - end Key; - - --- TODO: --- procedure Replace (Container : in out Set; --- Key : in Key_Type; --- New_Item : in Element_Type) is - --- Node : constant Node_Access := --- Key_Keys.Find (Container, Key); - --- begin - --- if Node = null then --- raise Constraint_Error; --- end if; + return Equivalent_Keys (Key, Node.Element.all); + end Equivalent_Key_Node; --- Replace_Element (Container, Node, New_Item); + --------------------- + -- Equivalent_Keys -- + --------------------- --- end Replace; + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean + is + begin + return Equivalent_Keys (Right, Left.Node.Element.all); + end Equivalent_Keys; + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean + is + begin + return Equivalent_Keys (Left, Right.Node.Element.all); + end Equivalent_Keys; - procedure Delete (Container : in out Set; - Key : in Key_Type) is + ------------- + -- Exclude -- + ------------- + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is X : Node_Access; - begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + ---------- + -- Find -- + ---------- - if X = null then - raise Constraint_Error; + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; end if; - Free (X); + return Cursor'(Container'Unrestricted_Access, Node); + end Find; - end Delete; + --------- + -- Key -- + --------- + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element.all); + end Key; - procedure Exclude (Container : in out Set; - Key : in Key_Type) is + ------------- + -- Replace -- + ------------- - X : Node_Access; + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); begin + if Node = null then + raise Constraint_Error; + end if; - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - Free (X); - - end Exclude; - + Replace_Element (Container.HT, Node, New_Item); + end Replace; - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : in Cursor; Process : not null access - procedure (Element : in out Element_Type)) is + procedure (Element : in out Element_Type)) + is + HT : Hash_Table_Type renames Container.HT; begin - - if Position.Container = null then + if Position.Node = null then raise Constraint_Error; end if; @@ -1477,55 +1816,44 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end if; declare - Old_Key : Key_Type renames Key (Position.Node.Element.all); - begin - Process (Position.Node.Element.all); - - if Equivalent_Keys (Old_Key, Position.Node.Element.all) then - return; - end if; - end; - - declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + E : Element_Type renames Position.Node.Element.all; + K : Key_Type renames Key (E); - function New_Node (Next : Node_Access) return Node_Access is - begin - Position.Node.Next := Next; - return Position.Node; - end New_Node; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; - procedure Insert is - new Key_Keys.Generic_Conditional_Insert (New_Node); - - Result : Node_Access; - Success : Boolean; begin - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + B := B + 1; + L := L + 1; - Insert - (HT => Container, - Key => Key (Position.Node.Element.all), - Node => Result, - Success => Success); + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; - if not Success then - declare - X : Node_Access := Position.Node; - begin - Free (X); - end; + L := L - 1; + B := B - 1; - raise Program_Error; + if Equivalent_Keys (K, E) then + pragma Assert (Hash (K) = Hash (E)); + return; end if; + end; - pragma Assert (Result = Position.Node); + declare + X : Node_Access := Position.Node; + begin + HT_Ops.Delete_Node_Sans_Free (HT, X); + Free (X); end; - end Checked_Update_Element; + raise Program_Error; + end Update_Element_Preserving_Key; end Generic_Keys; end Ada.Containers.Indefinite_Hashed_Sets; - diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 1886d3d..a145bd0 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ M A P S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -41,24 +42,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); -with System; use type System.Address; - package body Ada.Containers.Indefinite_Ordered_Maps is - use Red_Black_Trees; - - type Key_Access is access Key_Type; - type Element_Access is access Element_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Key : Key_Access; - Element : Element_Access; - end record; - ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -97,10 +82,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - procedure Free (X : in out Node_Access); function Is_Equal_Node_Node @@ -122,9 +103,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -------------------------- package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); use Tree_Operations; @@ -169,10 +154,6 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "=" (Left, Right : Map) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; @@ -199,24 +180,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- Adjust -- ------------ - procedure Adjust (Container : in out Map) is - Tree : Tree_Type renames Container.Tree; - - N : constant Count_Type := Tree.Length; - X : constant Node_Access := Tree.Root; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Map) is begin - if N = 0 then - pragma Assert (X = null); - return; - end if; - - Tree := (Length => 0, others => null); - - Tree.Root := Copy_Tree (X); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; + Adjust (Container.Tree); end Adjust; ------------- @@ -229,7 +198,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is if Node = null then return No_Element; else - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; end Ceiling; @@ -237,12 +206,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Map) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -268,59 +237,23 @@ package body Ada.Containers.Indefinite_Ordered_Maps is --------------- function Copy_Node (Source : Node_Access) return Node_Access is - Target : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Key => Source.Key, - Element => Source.Element); - begin - return Target; - end Copy_Node; - - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - - P, X : Node_Access; - + K : Key_Access := new Key_Type'(Source.Key.all); + E : Element_Access; begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - + E := new Element_Type'(Source.Element.all); + + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Key => K, + Element => E); exception when others => - Delete_Tree (Target_Root); + Free_Key (K); + Free_Element (E); raise; - end Copy_Tree; + end Copy_Node; ------------ -- Delete -- @@ -331,11 +264,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Map_Access'(Container'Unchecked_Access) then + if Position.Container /= Map_Access'(Container'Unrestricted_Access) then raise Program_Error; end if; @@ -361,9 +294,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ------------------ procedure Delete_First (Container : in out Map) is - Position : Cursor := First (Container); + X : Node_Access := Container.Tree.First; begin - Delete (Container, Position); + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; end Delete_First; ----------------- @@ -371,26 +307,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ----------------- procedure Delete_Last (Container : in out Map) is - Position : Cursor := Last (Container); - begin - Delete (Container, Position); - end Delete_Last; - - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; + X : Node_Access := Container.Tree.Last; begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); - X := Y; - end loop; - end Delete_Tree; + end if; + end Delete_Last; ------------- -- Element -- @@ -431,7 +354,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is if Node = null then return No_Element; else - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; end Find; @@ -444,7 +367,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is if Container.Tree.First = null then return No_Element; else - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end if; end First; @@ -476,7 +399,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is if Node = null then return No_Element; else - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; end Floor; @@ -488,11 +411,38 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); begin - if X /= null then + if X = null then + return; + end if; + + begin Free_Key (X.Key); + exception + when others => + X.Key := null; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + end; + + Deallocate (X); + raise; + end; + + begin Free_Element (X.Element); - Deallocate (X); - end if; + exception + when others => + X.Element := null; + + Deallocate (X); + raise; + end; + + Deallocate (X); end Free; ----------------- @@ -523,11 +473,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + K := Position.Node.Key; E := Position.Node.Element; Position.Node.Key := new Key_Type'(Key); - Position.Node.Element := new Element_Type'(New_Item); + + begin + Position.Node.Element := new Element_Type'(New_Item); + exception + when others => + Free_Key (K); + raise; + end; Free_Key (K); Free_Element (E); @@ -571,7 +532,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- On exception, deallocate key and elem - Free (Node); + Free (Node); -- Note that Free deallocates key and elem too raise; end New_Node; @@ -584,7 +545,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -620,7 +581,15 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is begin - return L.Element.all = R.Element.all; + if L.Key.all < R.Key.all then + return False; + + elsif R.Key.all < L.Key.all then + return False; + + else + return L.Element.all = R.Element.all; + end if; end Is_Equal_Node_Node; ------------------------- @@ -668,13 +637,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is 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.Tree'Unrestricted_Access.all.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- @@ -695,7 +676,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is if Container.Tree.Last = null then return No_Element; else - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end if; end Last; @@ -739,12 +720,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Map; Source : in out Map) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -816,10 +796,32 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Query_Element (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) is + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Key.all, Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -830,43 +832,35 @@ package body Ada.Containers.Indefinite_Ordered_Maps is (Stream : access Root_Stream_Type'Class; Container : out Map) is - N : Count_Type'Base; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); - function New_Node return Node_Access; - pragma Inline (New_Node); + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); - procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + --------------- + -- Read_Node -- + --------------- - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; - begin Node.Key := new Key_Type'(Key_Type'Input (Stream)); Node.Element := new Element_Type'(Element_Type'Input (Stream)); return Node; - exception when others => - - -- Deallocate key and elem too on exception - - Free (Node); + Free (Node); -- Note that Free deallocates key and elem too raise; - end New_Node; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - Local_Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -889,11 +883,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is raise Constraint_Error; end if; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + K := Node.Key; E := Node.Element; Node.Key := new Key_Type'(Key); - Node.Element := new Element_Type'(New_Item); + + begin + Node.Element := new Element_Type'(New_Item); + exception + when others => + Free_Key (K); + raise; + end; Free_Key (K); Free_Element (E); @@ -906,6 +911,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Replace_Element (Position : Cursor; By : Element_Type) is X : Element_Access := Position.Node.Element; begin + if Position.Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Element := new Element_Type'(By); Free_Element (X); end Replace_Element; @@ -930,13 +939,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is 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.Tree'Unrestricted_Access.all.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -990,10 +1011,32 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Key.all, Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; ----------- @@ -1004,28 +1047,31 @@ package body Ada.Containers.Indefinite_Ordered_Maps is (Stream : access Root_Stream_Type'Class; Container : Map) is - procedure Process (Node : Node_Access); - pragma Inline (Process); - - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Key_Type'Output (Stream, Node.Key.all); Element_Type'Output (Stream, Node.Element.all); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; end Ada.Containers.Indefinite_Ordered_Maps; - diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 8bfe327..f6ae76f 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ M A P S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -110,10 +111,6 @@ pragma Preelaborate (Indefinite_Ordered_Maps); (Container : in out Map; Key : Key_Type); - procedure Exclude - (Container : in out Map; - Key : Key_Type); - procedure Delete (Container : in out Map; Position : in out Cursor); @@ -122,6 +119,10 @@ pragma Preelaborate (Indefinite_Ordered_Maps); procedure Delete_Last (Container : in out Map); + procedure Exclude + (Container : in out Map; + Key : Key_Type); + function Contains (Container : Map; Key : Key_Type) return Boolean; @@ -156,10 +157,10 @@ pragma Preelaborate (Indefinite_Ordered_Maps); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -189,21 +190,35 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Key_Access is access Key_Type; + type Element_Access is access Element_Type; - use Tree_Types; - use Ada.Finalization; + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Access; + Element : Element_Access; + end record; - type Map is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); + + type Map is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Map); procedure Finalize (Container : in out Map) renames Clear; - type Map_Access is access constant Map; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Map_Access is access Map; for Map_Access'Storage_Size use 0; type Cursor is record @@ -228,7 +243,11 @@ private for Map'Read use Read; Empty_Map : constant Map := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Indefinite_Ordered_Maps; - diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 1d608b0..c836913 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -44,22 +45,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); -with System; use type System.Address; - package body Ada.Containers.Indefinite_Ordered_Multisets is - use Red_Black_Trees; - - type Element_Access is access Element_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Element : Element_Access; - end record; - ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -98,10 +85,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - procedure Free (X : in out Node_Access); procedure Insert_With_Hint @@ -126,14 +109,23 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Is_Less_Node_Node (L, R : Node_Access) return Boolean; pragma Inline (Is_Less_Node_Node); + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + -------------------------- -- Local Instantiations -- -------------------------- package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); use Tree_Operations; @@ -182,11 +174,8 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- "=" -- --------- - function "=" (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - + function "=" (Left, Right : Set) return Boolean is + begin return Is_Equal (Left.Tree, Right.Tree); end "="; @@ -215,24 +204,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- Adjust -- ------------ - procedure Adjust (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - - N : constant Count_Type := Tree.Length; - X : constant Node_Access := Tree.Root; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Set) is begin - if N = 0 then - pragma Assert (X = null); - return; - end if; - - Tree := (Length => 0, others => null); - - Tree.Root := Copy_Tree (X); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; + Adjust (Container.Tree); end Adjust; ------------- @@ -248,19 +225,19 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -301,49 +278,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise; end Copy_Node; - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - - P, X : Node_Access; - - begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - - exception - when others => - Delete_Tree (Target_Root); - raise; - end Copy_Tree; - ------------ -- Delete -- ------------ @@ -371,15 +305,15 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -419,48 +353,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Free (X); end Delete_Last; - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; - begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; - Free (X); - X := Y; - end loop; - end Delete_Tree; - ---------------- -- Difference -- ---------------- procedure Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Difference (Target.Tree, Source.Tree); end Difference; function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Difference; ------------- @@ -472,6 +378,39 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Position.Node.Element.all; end Element; + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element.all < R.Element.all then + return False; + elsif R.Element.all < L.Element.all then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + ------------- -- Exclude -- ------------- @@ -503,7 +442,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -516,7 +455,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -541,7 +480,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ---------- @@ -552,10 +491,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); begin - if X /= null then - Free_Element (X.Element); - Deallocate (X); + if X = null then + return; end if; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); end Free; ------------------ @@ -630,77 +579,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; - ---------------------------- - -- Checked_Update_Element -- - ---------------------------- - - procedure Checked_Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error; - end if; - - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - declare - Old_Key : Key_Type renames Key (Position.Node.Element.all); - - begin - Process (Position.Node.Element.all); - - if Old_Key < Position.Node.Element.all - or else Old_Key > Position.Node.Element.all - then - null; - else - return; - end if; - end; - - Delete_Node_Sans_Free (Container.Tree, Position.Node); - - Do_Insert : declare - Result : Node_Access; - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Keys.Generic_Insert_Post (New_Node); - - procedure Insert is - new Key_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - -- Start of processing for Do_Insert - - begin - Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element.all), - Node => Result); - - pragma Assert (Result = Position.Node); - end Do_Insert; - end Checked_Update_Element; - -------------- -- Contains -- -------------- @@ -776,7 +657,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -791,7 +672,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -837,13 +718,26 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree, Key); + B := B + 1; + + begin + Local_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- @@ -855,27 +749,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Key (Position.Node.Element.all); end Key; - ------------- - -- Replace -- - ------------- - - -- In post-madision api: ??? - --- procedure Replace --- (Container : in out Set; --- Key : Key_Type; --- New_Item : Element_Type) --- is --- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); - --- begin --- if Node = null then --- raise Constraint_Error; --- end if; - --- Replace_Node (Container, Node, New_Item); --- end Replace; - --------------------- -- Reverse_Iterate -- --------------------- @@ -901,15 +774,90 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree, Key); + B := B + 1; + + begin + Local_Reverse_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + declare + E : Element_Type renames Position.Node.Element.all; + K : Key_Type renames Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if K < E + or else K > E + then + null; + else + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error; + end Update_Element_Preserving_Key; + end Generic_Keys; ----------------- @@ -973,7 +921,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is New_Item, Position.Node); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; ---------------------- @@ -1036,25 +984,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Intersection (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Intersection (Target.Tree, Source.Tree); end Intersection; function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Intersection; -------------- @@ -1116,10 +1053,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is begin - if Subset'Address = Of_Set'Address then - return True; - end if; - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); end Is_Subset; @@ -1144,13 +1077,26 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree, Item); + B := B + 1; + + begin + Local_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; procedure Iterate @@ -1169,13 +1115,26 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -1188,7 +1147,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -1222,12 +1181,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Set; Source : in out Set) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -1265,10 +1223,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Overlap (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return Left.Tree.Length /= 0; - end if; - return Set_Ops.Overlap (Left.Tree, Right.Tree); end Overlap; @@ -1317,8 +1271,29 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + E : Element_Type renames Position.Node.Element.all; + + S : Set renames Position.Container.all; + T : Tree_Type renames S.Tree'Unrestricted_Access.all; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -1329,150 +1304,122 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is (Stream : access Root_Stream_Type'Class; Container : out Set) is - N : Count_Type'Base; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); - function New_Node return Node_Access; - pragma Inline (New_Node); + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); - procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + --------------- + -- Read_Node -- + --------------- - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; - begin - begin - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - exception - when others => - Free (Node); - raise; - end; - + Node.Element := new Element_Type'(Element_Type'Input (Stream)); return Node; - end New_Node; + exception + when others => + Free (Node); -- Note that Free deallocates elem too + raise; + end Read_Node; -- Start of processing for Read begin - Clear (Container); + Read (Stream, Container.Tree); + end Read; - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); + --------------------- + -- Replace_Element -- + --------------------- - Local_Read (Container.Tree, N); - end Read; + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element.all + or else Node.Element.all < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; - ------------- - -- Replace -- - ------------- + declare + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; - -- NOTE: from post-madison api??? + return; + end if; --- procedure Replace --- (Container : in out Set; --- Position : Cursor; --- By : Element_Type) --- is --- begin --- if Position.Container = null then --- raise Constraint_Error; --- end if; + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); --- Replace_Node (Container, Position.Node, By); --- end Replace; + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); - ------------------ - -- Replace_Node -- - ------------------ + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := new Element_Type'(Item); -- OK if fails + return Node; + end New_Node; + + Result : Node_Access; + + X : Element_Access := Node.Element; - -- NOTE: from post-madison api??? - --- procedure Replace_Node --- (Container : in out Set; --- Position : Node_Access; --- By : Element_Type); --- is --- Tree : Tree_Type renames Container.Tree; --- Node : Node_Access := Position; - --- begin --- if By < Node.Element --- or else Node.Element < By --- then --- null; - --- else --- begin --- Node.Element := By; - --- exception --- when others => --- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); --- Free (Node); --- raise; --- end; - --- return; --- end if; - --- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); - --- begin --- Node.Element := By; - --- exception --- when others => --- Free (Node); --- raise; --- end; - --- declare --- Result : Node_Access; --- Success : Boolean; - --- function New_Node return Node_Access; --- pragma Inline (New_Node); - --- procedure Insert_Post is --- new Element_Keys.Generic_Insert_Post (New_Node); - --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (Insert_Post); - --- -------------- --- -- New_Node -- --- -------------- --- --- function New_Node return Node_Access is --- begin --- return Node; --- end New_Node; - --- -- Start of processing for Replace_Node - --- begin --- Insert --- (Tree => Tree, --- Key => Node.Element, --- Node => Result, --- Success => Success); - --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; - --- pragma Assert (Result = Node); --- end; --- end Replace_Node; + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Item, + Node => Result); + pragma Assert (Result = Node); + + Free_Element (X); -- OK if fails + end Insert_New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Tree, Position.Node, By); + end Replace_Element; --------------------- -- Reverse_Iterate -- @@ -1495,13 +1442,26 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree, Item); + B := B + 1; + + begin + Local_Reverse_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; procedure Reverse_Iterate @@ -1520,13 +1480,26 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -1580,26 +1553,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Symmetric_Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Symmetric_Difference; ----------- @@ -1608,23 +1569,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Union (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Union (Target.Tree, Source.Tree); end Union; - function Union (Left, Right : Set) return Set is begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); end Union; ----------- @@ -1635,25 +1587,30 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is (Stream : access Root_Stream_Type'Class; Container : Set) is - procedure Process (Node : Node_Access); - pragma Inline (Process); + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); - procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); - ------------- - -- Process -- - ------------- + ---------------- + -- Write_Node -- + ---------------- - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Element_Type'Output (Stream, Node.Element.all); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index 328d0dd..4bf4857 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ M U L T I S E T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -56,6 +57,8 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); function "=" (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -68,6 +71,11 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type); + procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -79,22 +87,13 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); procedure Delete (Container : in out Set; Item : Element_Type); - procedure Exclude (Container : in out Set; Item : Element_Type); - procedure Delete (Container : in out Set; Position : in out Cursor); procedure Delete_First (Container : in out Set); procedure Delete_Last (Container : in out Set); - - -- NOTE: The following operation is named Replace in the Madison API. - -- However, it should be named Replace_Element ??? - -- - -- procedure Replace - -- (Container : in out Set; - -- Position : Cursor; - -- By : Element_Type); + procedure Exclude (Container : in out Set; Item : Element_Type); procedure Union (Target : in out Set; Source : Set); @@ -143,10 +142,10 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -207,12 +206,6 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); function Element (Container : Set; Key : Key_Type) return Element_Type; - -- NOTE: in post-madison api ??? - -- procedure Replace - -- (Container : in out Set; - -- Key : Key_Type; - -- New_Item : Element_Type); - procedure Delete (Container : in out Set; Key : Key_Type); procedure Exclude (Container : in out Set; Key : Key_Type); @@ -225,7 +218,7 @@ pragma Preelaborate (Indefinite_Ordered_Multisets); function ">" (Left : Key_Type; Right : Cursor) return Boolean; - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; Process : not null access @@ -248,21 +241,33 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Element_Access is access Element_Type; - use Tree_Types; - use Ada.Finalization; + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Access; + end record; - type Set is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); + + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Set); procedure Finalize (Container : in out Set) renames Clear; - type Set_Access is access constant Set; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Set_Access is access all Set; for Set_Access'Storage_Size use 0; type Cursor is record @@ -285,6 +290,11 @@ private for Set'Read use Read; Empty_Set : constant Set := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 9cd5e14..0f9615c 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -44,22 +45,8 @@ 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 Element_Access is access Element_Type; - - use Red_Black_Trees; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Element : Element_Access; - end record; - ----------------------- -- Local Subprograms -- ----------------------- @@ -70,10 +57,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - procedure Free (X : in out Node_Access); procedure Insert_With_Hint @@ -101,6 +84,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Parent (Node : Node_Access) return Node_Access; pragma Inline (Parent); + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + function Right (Node : Node_Access) return Node_Access; pragma Inline (Right); @@ -124,9 +112,13 @@ package body Ada.Containers.Indefinite_Ordered_Sets is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); use Tree_Operations; @@ -189,14 +181,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Start of processing for "=" begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; - --------- -- ">" -- --------- @@ -222,25 +209,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Adjust -- ------------ - procedure Adjust (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Set) is begin - if Tree.Length = 0 then - pragma Assert (Tree.Root = null); - return; - end if; - - begin - Tree.Root := Copy_Tree (Tree.Root); - exception - when others => - Tree := (Length => 0, others => null); - raise; - end; - - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); + Adjust (Container.Tree); end Adjust; ------------- @@ -256,19 +230,19 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -295,6 +269,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Copy_Node (Source : Node_Access) return Node_Access is Element : Element_Access := new Element_Type'(Source.Element.all); + begin return new Node_Type'(Parent => null, Left => null, @@ -307,66 +282,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise; end Copy_Node; - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - P, X : Node_Access; - - begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - - exception - when others => - Delete_Tree (Target_Root); - raise; - end Copy_Tree; - ------------ -- Delete -- ------------ procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); - Position.Container := null; end Delete; @@ -388,9 +319,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ------------------ procedure Delete_First (Container : in out Set) is - C : Cursor := First (Container); + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + begin - Delete (Container, C); + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; end Delete_First; ----------------- @@ -398,26 +334,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ----------------- procedure Delete_Last (Container : in out Set) is - C : Cursor := Last (Container); - begin - Delete (Container, C); - end Delete_Last; - - ----------------- - -- Delete_Tree -- - ----------------- + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); Free (X); - X := Y; - end loop; - end Delete_Tree; + end if; + end Delete_Last; ---------------- -- Difference -- @@ -425,26 +350,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Difference (Target.Tree, Source.Tree); end Difference; function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Difference; ------------- @@ -456,6 +369,39 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Position.Node.Element.all; end Element; + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element.all < R.Element.all then + return False; + elsif R.Element.all < L.Element.all then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + ------------- -- Exclude -- ------------- @@ -463,9 +409,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Exclude (Container : in out Set; Item : Element_Type) is X : Node_Access := Element_Keys.Find (Container.Tree, Item); + begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -483,7 +430,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -496,7 +443,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -521,7 +468,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ---------- @@ -529,13 +476,25 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ---------- procedure Free (X : in out Node_Access) is + procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin - if X /= null then - Free_Element (X.Element); - Deallocate (X); + if X = null then + return; end if; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); end Free; ------------------ @@ -610,90 +569,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; - ---------------------------- - -- Checked_Update_Element -- - ---------------------------- - - procedure Checked_Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error; - end if; - - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - declare - Old_Key : Key_Type renames Key (Position.Node.Element.all); - - begin - Process (Position.Node.Element.all); - - if Old_Key < Position.Node.Element.all - or else Old_Key > Position.Node.Element.all - then - null; - else - return; - end if; - end; - - declare - Result : Node_Access; - Success : Boolean; - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Keys.Generic_Insert_Post (New_Node); - - procedure Insert is - new Key_Keys.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - -- Start of processing for Checked_Update_Element - - begin - Delete_Node_Sans_Free (Container.Tree, Position.Node); - - Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element.all), - Node => Result, - Success => Success); - - if not Success then - declare - X : Node_Access := Position.Node; - begin - Free (X); - end; - - raise Program_Error; - end if; - - pragma Assert (Result = Position.Node); - end; - end Checked_Update_Element; - -------------- -- Contains -- -------------- @@ -715,7 +593,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end Delete; @@ -724,9 +602,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ------------- function Element (Container : Set; Key : Key_Type) return Element_Type is - C : constant Cursor := Find (Container, Key); + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + begin - return C.Node.Element.all; + return Node.Element.all; end Element; ------------- @@ -738,7 +618,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -756,7 +636,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -772,7 +652,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -806,6 +686,88 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Key (Position.Node.Element.all); end Key; + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error; + end if; + + Replace_Element (Container.Tree, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + declare + E : Element_Type renames Position.Node.Element.all; + K : Key_Type renames Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if K < E + or else K > E + then + null; + else + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error; + end Update_Element_Preserving_Key; + end Generic_Keys; ----------------- @@ -831,6 +793,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + X := Position.Node.Element; Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); @@ -883,7 +849,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert (Container : in out Set; New_Item : Element_Type) is @@ -961,25 +927,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Intersection (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Intersection (Target.Tree, Source.Tree); end Intersection; function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Intersection; -------------- @@ -988,7 +943,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Length (Container) = 0; + return Container.Tree.Length = 0; end Is_Empty; ----------------------------- @@ -1004,7 +959,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Right.Element.all < Left; end Is_Greater_Element_Node; - -------------------------- -- Is_Less_Element_Node -- -------------------------- @@ -1031,10 +985,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is begin - if Subset'Address = Of_Set'Address then - return True; - end if; - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); end Is_Subset; @@ -1058,13 +1008,26 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - -- Start of processing for Iterate + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + + -- Start of prccessing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -1077,7 +1040,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -1111,12 +1074,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Set; Source : in out Set) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -1137,7 +1099,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Node : constant Node_Access := - Tree_Operations.Next (Position.Node); + Tree_Operations.Next (Position.Node); + begin if Node = null then return No_Element; @@ -1153,10 +1116,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Overlap (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return Left.Tree.Length /= 0; - end if; - return Set_Ops.Overlap (Left.Tree, Right.Tree); end Overlap; @@ -1186,7 +1145,8 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); + Tree_Operations.Previous (Position.Node); + begin if Node = null then return No_Element; @@ -1204,8 +1164,29 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + E : Element_Type renames Position.Node.Element.all; + + S : Set renames Position.Container.all; + T : Tree_Type renames S.Tree'Unrestricted_Access.all; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Element.all); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -1213,21 +1194,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ---------- procedure Read - (Stream : access Ada.Streams.Root_Stream_Type'Class; + (Stream : access Root_Stream_Type'Class; Container : out Set) is - N : Count_Type'Base; - - function New_Node return Node_Access; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); procedure Read is - new Tree_Operations.Generic_Read (New_Node); + new Tree_Operations.Generic_Read (Clear, Read_Node); - -------------- - -- New_Node -- - -------------- + --------------- + -- Read_Node -- + --------------- - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; begin @@ -1236,17 +1219,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is exception when others => - Free (Node); + Free (Node); -- Note that Free deallocates elem too raise; - end New_Node; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -1269,129 +1249,139 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Free_Element (X); end Replace; --- TODO ??? --- procedure Replace --- (Container : in out Set; --- Key : Key_Type; --- New_Item : Element_Type) --- is --- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); - --- begin --- if Node = null then --- raise Constraint_Error; --- end if; - --- Replace_Element (Container, Node, New_Item); --- end Replace; - --------------------- -- Replace_Element -- --------------------- --- TODO: ??? --- procedure Replace_Element --- (Container : in out Set; --- Position : Node_Access; --- By : Element_Type) --- is - --- Node : Node_Access := Position; - --- begin --- if By < Node.Element.all --- or else Node.Element.all < By --- then --- null; - --- else --- declare --- X : Element_Access := Node.Element; - --- begin --- Node.Element := new Element_Type'(By); - --- -- NOTE: If there's an exception here, then just --- -- let it propagate. We haven't modified the --- -- state of the container, so there's nothing else --- -- we need to do. - --- Free_Element (X); --- end; - --- return; --- end if; - --- Delete_Node_Sans_Free (Container.Tree, Node); - --- begin --- Free_Element (Node.Element); --- exception --- when others => --- Node.Element := null; -- don't attempt to dealloc X.E again --- Free (Node); --- raise; --- end; - --- begin --- Node.Element := new Element_Type'(By); --- exception --- when others => --- Free (Node); --- raise; --- end; - --- declare --- function New_Node return Node_Access; --- pragma Inline (New_Node); - --- function New_Node return Node_Access is --- begin --- return Node; --- end New_Node; - --- procedure Insert_Post is --- new Element_Keys.Generic_Insert_Post (New_Node); - --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (Insert_Post); - --- Result : Node_Access; --- Success : Boolean; - --- begin --- Insert --- (Tree => Container.Tree, --- Key => Node.Element.all, --- Node => Result, --- Success => Success); - --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; - --- pragma Assert (Result = Node); --- end; --- end Replace_Element; - - --- procedure Replace_Element --- (Container : in out Set; --- Position : Cursor; --- By : Element_Type) --- is --- begin --- if Position.Container = null then --- raise Constraint_Error; --- end if; - --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; - --- Replace_Element (Container, Position.Node, By); --- end Replace_Element; + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element.all + or else Node.Element.all < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; + + declare + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; + + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := new Element_Type'(Item); -- OK if fails + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + X : Element_Access := Node.Element; + + -- Start of processing for Insert_New_Item + + begin + Attempt_Insert : begin + Insert + (Tree => Tree, + Key => Item, + Node => Result, + Success => Inserted); -- TODO: change name of formal param + exception + when others => + Inserted := False; + end Attempt_Insert; + + if Inserted then + pragma Assert (Result = Node); + Free_Element (X); -- OK if fails + return; + end if; + end Insert_New_Item; + + Reinsert_Old_Element : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Reinsert_Old_Element + + begin + Insert + (Tree => Tree, + Key => Node.Element.all, + Node => Result, + Success => Inserted); -- TODO: change name of formal param + exception + when others => + null; + end Reinsert_Old_Element; + + raise Program_Error; + end Replace_Element; + + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Tree, Position.Node, By); + end Replace_Element; --------------------- -- Reverse_Iterate -- @@ -1413,13 +1403,26 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -1473,26 +1476,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Symmetric_Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Symmetric_Difference; ----------- @@ -1501,25 +1492,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Union (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Union (Target.Tree, Source.Tree); end Union; function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Union (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Union; ----------- @@ -1527,31 +1507,33 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ----------- procedure Write - (Stream : access Ada.Streams.Root_Stream_Type'Class; + (Stream : access Root_Stream_Type'Class; Container : Set) is - procedure Process (Node : Node_Access); - pragma Inline (Process); + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); - ------------- - -- Process -- - ------------- + ---------------- + -- Write_Node -- + ---------------- - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Element_Type'Output (Stream, Node.Element.all); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; end Ada.Containers.Indefinite_Ordered_Sets; - - diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index e05dc1a..0841bc7 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- A D A . C O N T A I N E R S . -- +-- I N D E F I N I T E _ O R D E R E D _ S E T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -56,6 +57,8 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function "=" (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -68,11 +71,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets); (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - -- TODO: resolve in Atlanta??? - -- procedure Replace_Element - -- (Container : in out Set; - -- Position : Cursor; - -- By : Element_Type); + procedure Replace_Element + (Container : Set; -- TODO: need ruling from ARG + Position : Cursor; + By : Element_Type); procedure Move (Target : in out Set; Source : in out Set); @@ -98,10 +100,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets); (Container : in out Set; Item : Element_Type); - procedure Exclude - (Container : in out Set; - Item : Element_Type); - procedure Delete (Container : in out Set; Position : in out Cursor); @@ -110,6 +108,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets); procedure Delete_Last (Container : in out Set); + procedure Exclude + (Container : in out Set; + Item : Element_Type); + procedure Union (Target : in out Set; Source : Set); function Union (Left, Right : Set) return Set; @@ -157,10 +159,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -220,11 +222,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets); (Container : Set; Key : Key_Type) return Element_Type; - -- TODO: resolve in Atlanta??? - -- procedure Replace - -- (Container : in out Set; - -- Key : Key_Type; - -- New_Item : Element_Type); + procedure Replace + (Container : in out Set; -- TODO: need ruling from ARG + Key : Key_Type; + New_Item : Element_Type); procedure Delete (Container : in out Set; Key : Key_Type); @@ -238,8 +239,7 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function ">" (Left : Key_Type; Right : Cursor) return Boolean; - -- TODO: resolve name in Atlanta??? - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; Process : not null access @@ -252,21 +252,33 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Element_Access is access Element_Type; - use Tree_Types; - use Ada.Finalization; + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Access; + end record; + + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); - type Set is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Set); procedure Finalize (Container : in out Set) renames Clear; - type Set_Access is access constant Set; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Set_Access is access all Set; for Set_Access'Storage_Size use 0; type Cursor is record @@ -291,6 +303,11 @@ private for Set'Read use Read; Empty_Set : constant Set := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index e1120c1..97d2723 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASHED_MAPS -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -43,12 +43,6 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); package body Ada.Containers.Hashed_Maps is - type Node_Type is limited record - Key : Key_Type; - Element : Element_Type; - Next : Node_Access; - end record; - ----------------------- -- Local Subprograms -- ----------------------- @@ -57,13 +51,15 @@ package body Ada.Containers.Hashed_Maps is (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + pragma Inline (Equivalent_Key_Node); + + procedure Free (X : in out Node_Access); function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean; function Hash_Node (Node : Node_Access) return Hash_Type; @@ -79,6 +75,8 @@ package body Ada.Containers.Hashed_Maps is procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); + function Vet (Position : Cursor) return Boolean; + procedure Write_Node (Stream : access Root_Stream_Type'Class; Node : Node_Access); @@ -88,14 +86,9 @@ package body Ada.Containers.Hashed_Maps is -- Local Instantiations -- -------------------------- - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package HT_Ops is new Hash_Tables.Generic_Operations (HT_Types => HT_Types, - Hash_Table_Type => Map, - Null_Node => null, Hash_Node => Hash_Node, Next => Next, Set_Next => Set_Next, @@ -105,13 +98,11 @@ package body Ada.Containers.Hashed_Maps is package Key_Ops is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Map, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Key_Type, Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + Equivalent_Keys => Equivalent_Key_Node); function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); @@ -122,26 +113,37 @@ package body Ada.Containers.Hashed_Maps is -- "=" -- --------- - function "=" (Left, Right : Map) return Boolean renames Is_Equal; + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; ------------ -- Adjust -- ------------ - procedure Adjust (Container : in out Map) renames HT_Ops.Adjust; + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; -------------- -- Capacity -- -------------- - function Capacity (Container : Map) return Count_Type - renames HT_Ops.Capacity; + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; ----------- -- Clear -- ----------- - procedure Clear (Container : in out Map) renames HT_Ops.Clear; + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; -------------- -- Contains -- @@ -175,7 +177,7 @@ package body Ada.Containers.Hashed_Maps is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then raise Constraint_Error; @@ -186,17 +188,23 @@ package body Ada.Containers.Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; if Position.Container /= Map_Access'(Container'Unchecked_Access) then raise Program_Error; end if; - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Position.Node); + pragma Assert (Position.Node.Next /= Position.Node); + + if Container.HT.Busy > 0 then + raise Program_Error; + end if; + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); Position.Container := null; end Delete; @@ -212,19 +220,20 @@ package body Ada.Containers.Hashed_Maps is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Element; end Element; - --------------------- - -- Equivalent_Keys -- - --------------------- + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean is begin return Equivalent_Keys (Key, Node.Key); - end Equivalent_Keys; + end Equivalent_Key_Node; --------------------- -- Equivalent_Keys -- @@ -233,16 +242,20 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin + pragma Assert (Vet (Left)); + pragma Assert (Vet (Right)); return Equivalent_Keys (Left.Node.Key, Right.Node.Key); end Equivalent_Keys; function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin + pragma Assert (Vet (Left)); return Equivalent_Keys (Left.Node.Key, Right); end Equivalent_Keys; function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin + pragma Assert (Vet (Right)); return Equivalent_Keys (Left, Right.Node.Key); end Equivalent_Keys; @@ -253,7 +266,7 @@ package body Ada.Containers.Hashed_Maps is procedure Exclude (Container : in out Map; Key : Key_Type) is X : Node_Access; begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); Free (X); end Exclude; @@ -261,14 +274,17 @@ package body Ada.Containers.Hashed_Maps is -- Finalize -- -------------- - procedure Finalize (Container : in out Map) renames HT_Ops.Finalize; + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; ---------- -- Find -- ---------- function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin if Node = null then @@ -283,11 +299,11 @@ package body Ada.Containers.Hashed_Maps is -------------------- function Find_Equal_Key - (R_Map : Map; + (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean is - R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key); - R_Node : Node_Access := R_Map.Buckets (R_Index); + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); + R_Node : Node_Access := R_HT.Buckets (R_Index); begin while R_Node /= null loop @@ -306,7 +322,7 @@ package body Ada.Containers.Hashed_Maps is ----------- function First (Container : Map) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container); + Node : constant Node_Access := HT_Ops.First (Container.HT); begin if Node = null then @@ -316,13 +332,33 @@ package body Ada.Containers.Hashed_Maps is return Cursor'(Container'Unchecked_Access, Node); end First; + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + ----------------- -- Has_Element -- ----------------- function Has_Element (Position : Cursor) return Boolean is begin - return Position /= No_Element; + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; + + pragma Assert (Vet (Position)); + return True; end Has_Element; --------------- @@ -350,6 +386,10 @@ package body Ada.Containers.Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Key := Key; Position.Node.Element := New_Item; end if; @@ -390,11 +430,30 @@ package body Ada.Containers.Hashed_Maps is raise; end New_Node; + HT : Hash_Table_Type renames Container.HT; + -- Start of processing for Insert begin - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Local_Insert (Container, Key, Position.Node, Inserted); + if HT.Length >= HT_Ops.Capacity (HT) then + + -- TODO: 17 Apr 2005 + -- We should defer the expansion until we're sure that the + -- element was successfully inserted. We can do that by + -- first performing the insertion attempt, and allowing the + -- invariant len <= cap to be violated temporarily. After + -- the insertion we can restore the invariant. The + -- worst that can happen is that the insertion succeeds + -- (new element is added to the map), but the + -- invariant is broken (len > cap). But it's only + -- broken by a little (since len = cap + 1), so the + -- effect is benign. + -- END TODO. + + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -421,11 +480,17 @@ package body Ada.Containers.Hashed_Maps is return Node; end New_Node; + HT : Hash_Table_Type renames Container.HT; + -- Start of processing for Insert begin - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Local_Insert (Container, Key, Position.Node, Inserted); + if HT.Length >= HT_Ops.Capacity (HT) then + -- TODO: see note above. + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -451,7 +516,7 @@ package body Ada.Containers.Hashed_Maps is function Is_Empty (Container : Map) return Boolean is begin - return Container.Length = 0; + return Container.HT.Length = 0; end Is_Empty; ------------- @@ -479,7 +544,7 @@ package body Ada.Containers.Hashed_Maps is -- Start of processing for Iterate begin - Local_Iterate (Container); + Local_Iterate (Container.HT); end Iterate; --------- @@ -488,6 +553,7 @@ package body Ada.Containers.Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin + pragma Assert (Vet (Position)); return Position.Node.Key; end Key; @@ -497,7 +563,7 @@ package body Ada.Containers.Hashed_Maps is function Length (Container : Map) return Count_Type is begin - return Container.Length; + return Container.HT.Length; end Length; ---------- @@ -506,7 +572,11 @@ package body Ada.Containers.Hashed_Maps is procedure Move (Target : in out Map; - Source : in out Map) renames HT_Ops.Move; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; ---------- -- Next -- @@ -519,13 +589,15 @@ package body Ada.Containers.Hashed_Maps is function Next (Position : Cursor) return Cursor is begin - if Position = No_Element then + if Position.Node = null then + pragma Assert (Position.Container = null); return No_Element; end if; declare - M : Map renames Position.Container.all; - Node : constant Node_Access := HT_Ops.Next (M, Position.Node); + pragma Assert (Vet (Position)); + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); begin if Node = null then @@ -547,10 +619,36 @@ package body Ada.Containers.Hashed_Maps is procedure Query_Element (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -559,7 +657,11 @@ package body Ada.Containers.Hashed_Maps is procedure Read (Stream : access Root_Stream_Type'Class; - Container : out Map) renames Read_Nodes; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; --------------- -- Read_Node -- @@ -590,13 +692,17 @@ package body Ada.Containers.Hashed_Maps is Key : Key_Type; New_Item : Element_Type) is - Node : constant Node_Access := Key_Ops.Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); begin if Node = null then raise Constraint_Error; end if; + if Container.HT.Lock > 0 then + raise Program_Error; + end if; + Node.Key := Key; Node.Element := New_Item; end Replace; @@ -606,8 +712,15 @@ package body Ada.Containers.Hashed_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is + pragma Assert (Vet (Position)); + E : Element_Type renames Position.Node.Element; + begin - Position.Node.Element := By; + if Position.Container.HT.Lock > 0 then + raise Program_Error; + end if; + + E := By; end Replace_Element; ---------------------- @@ -616,7 +729,11 @@ package body Ada.Containers.Hashed_Maps is procedure Reserve_Capacity (Container : in out Map; - Capacity : Count_Type) renames HT_Ops.Ensure_Capacity; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; -------------- -- Set_Next -- @@ -633,19 +750,105 @@ package body Ada.Containers.Hashed_Maps is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is + pragma Assert (Vet (Position)); + + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Container = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null then + return False; + end if; + +-- NOTE: see notes in Insert. +-- if HT.Length > HT.Buckets'Length then +-- return False; +-- end if; + + X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- weird + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + ----------- -- Write -- ----------- procedure Write (Stream : access Root_Stream_Type'Class; - Container : Map) renames Write_Nodes; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; ---------------- -- Write_Node -- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 72dd1c2b1..ceb845b 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASHED_MAPS -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,6 +35,7 @@ with Ada.Containers.Hash_Tables; with Ada.Streams; +with Ada.Finalization; generic type Key_Type is private; @@ -66,8 +67,9 @@ pragma Preelaborate (Hashed_Maps); procedure Clear (Container : in out Map); - function Element (Position : Cursor) - return Element_Type; + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; procedure Query_Element (Position : Cursor; @@ -93,41 +95,36 @@ pragma Preelaborate (Hashed_Maps); procedure Insert (Container : in out Map; Key : Key_Type; - New_Item : Element_Type); + Position : out Cursor; + Inserted : out Boolean); - procedure Include + procedure Insert (Container : in out Map; Key : Key_Type; New_Item : Element_Type); - procedure Replace + procedure Include (Container : in out Map; Key : Key_Type; New_Item : Element_Type); - procedure Insert + procedure Replace (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); + New_Item : Element_Type); procedure Delete (Container : in out Map; Key : Key_Type); - procedure Exclude (Container : in out Map; Key : Key_Type); - procedure Delete (Container : in out Map; Position : in out Cursor); + procedure Exclude (Container : in out Map; Key : Key_Type); + function Contains (Container : Map; Key : Key_Type) return Boolean; function Find (Container : Map; Key : Key_Type) return Cursor; function Element (Container : Map; Key : Key_Type) return Element_Type; - function Capacity (Container : Map) return Count_Type; - - procedure Reserve_Capacity (Container : in out Map; - Capacity : Count_Type); - function First (Container : Map) return Cursor; function Next (Position : Cursor) return Cursor; @@ -136,8 +133,6 @@ pragma Preelaborate (Hashed_Maps); function Has_Element (Position : Cursor) return Boolean; - function Key (Position : Cursor) return Key_Type; - function Equivalent_Keys (Left, Right : Cursor) return Boolean; function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; @@ -148,16 +143,44 @@ pragma Preelaborate (Hashed_Maps); (Container : Map; Process : not null access procedure (Position : Cursor)); + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity (Container : in out Map; + Capacity : Count_Type); + private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); type Node_Type; type Node_Access is access Node_Type; - package HT_Types is new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + type Node_Type is limited record + Key : Key_Type; + Element : Element_Type; + Next : Node_Access; + end record; - use HT_Types; + package HT_Types is new Hash_Tables.Generic_Hash_Table_Types + (Node_Type, + Node_Access); - type Map is new Hash_Table_Type with null record; + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + use HT_Types; + use Ada.Finalization; procedure Adjust (Container : in out Map); @@ -177,7 +200,7 @@ private for Map'Read use Read; - Empty_Map : constant Map := (Hash_Table_Type with null record); + Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); type Map_Access is access constant Map; for Map_Access'Storage_Size use 0; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 58d04fe..7684ace 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASHED_SETS -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -41,828 +41,1173 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); -with System; use type System.Address; - with Ada.Containers.Prime_Numbers; -with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Hashed_Sets is - type Node_Type is - limited record - Element : Element_Type; - Next : Node_Access; - end record; + ----------------------- + -- Local Subprograms -- + ----------------------- - function Hash_Node - (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); - function Hash_Node - (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); - function Next - (Node : Node_Access) return Node_Access; - pragma Inline (Next); + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; - function Next - (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; - procedure Set_Next - (Node : Node_Access; - Next : Node_Access); - pragma Inline (Set_Next); + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); - procedure Set_Next - (Node : Node_Access; - Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; + function Is_In + (HT : Hash_Table_Type; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Node.Element); - end Equivalent_Keys; + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); - function Copy_Node - (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); + procedure Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Element : Element_Type); - function Copy_Node - (Source : Node_Access) return Node_Access is + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); - Target : constant Node_Access := - new Node_Type'(Element => Source.Element, - Next => null); - begin - return Target; - end Copy_Node; + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + -------------------------- + -- Local Instantiations -- + -------------------------- procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); package HT_Ops is new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Table_Type => Set, - Null_Node => null, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); package Element_Keys is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Set, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Element_Type, Hash => Hash, Equivalent_Keys => Equivalent_Keys); + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); - procedure Adjust (Container : in out Set) renames HT_Ops.Adjust; - - procedure Finalize (Container : in out Set) renames HT_Ops.Finalize; - - - function Find_Equal_Key - (R_Set : Set; - L_Node : Node_Access) return Boolean; + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); - function Find_Equal_Key - (R_Set : Set; - L_Node : Node_Access) return Boolean is + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); - R_Index : constant Hash_Type := - Element_Keys.Index (R_Set, L_Node.Element); + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); - R_Node : Node_Access := R_Set.Buckets (R_Index); + --------- + -- "=" -- + --------- + function "=" (Left, Right : Set) return Boolean is begin + return Is_Equal (Left.HT, Right.HT); + end "="; - loop + ------------ + -- Adjust -- + ------------ - if R_Node = null then - return False; - end if; + procedure Adjust (Container : in out Set) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; - if L_Node.Element = R_Node.Element then - -- pragma Assert (Is_Equal_Key (L_Node.Element, R_Node.Element)); - return True; - end if; + -------------- + -- Capacity -- + -------------- - R_Node := Next (R_Node); + function Capacity (Container : Set) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; - end loop; + ----------- + -- Clear -- + ----------- - end Find_Equal_Key; + procedure Clear (Container : in out Set) is + begin + HT_Ops.Clear (Container.HT); + end Clear; - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); + -------------- + -- Contains -- + -------------- - function "=" (Left, Right : Set) return Boolean renames Is_Equal; + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + --------------- + -- Copy_Node -- + --------------- - function Length (Container : Set) return Count_Type is + function Copy_Node (Source : Node_Access) return Node_Access is begin - return Container.Length; - end Length; + return new Node_Type'(Element => Source.Element, Next => null); + end Copy_Node; + ------------ + -- Delete -- + ------------ - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - procedure Clear (Container : in out Set) renames HT_Ops.Clear; + if X = null then + raise Constraint_Error; + end if; + Free (X); + end Delete; - function Element (Position : Cursor) return Element_Type is + procedure Delete + (Container : in out Set; + Position : in out Cursor) + is begin - return Position.Node.Element; - end Element; + if Position.Node = null then + raise Constraint_Error; + end if; + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; - procedure Query_Element - (Position : in Cursor; - Process : not null access procedure (Element : in Element_Type)) is - begin - Process (Position.Node.Element); - end Query_Element; + if Container.HT.Busy > 0 then + raise Program_Error; + end if; + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); --- TODO: --- procedure Replace_Element (Container : in out Set; --- Position : in Node_Access; --- By : in Element_Type) is + Free (Position.Node); --- Node : Node_Access := Position; + Position.Container := null; + end Delete; --- begin + ---------------- + -- Difference -- + ---------------- --- if Equivalent_Keys (Node.Element, By) then + procedure Difference + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; --- begin --- Node.Element := By; --- exception --- when others => --- HT_Ops.Delete_Node_Sans_Free (Container, Node); --- Free (Node); --- raise; --- end; + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; --- return; + if Source.Length = 0 then + return; + end if; --- end if; + if Target.HT.Busy > 0 then + raise Program_Error; + end if; --- HT_Ops.Delete_Node_Sans_Free (Container, Node); + -- TODO: This can be written in terms of a loop instead as + -- active-iterator style, sort of like a passive iterator. --- begin --- Node.Element := By; --- exception --- when others => --- Free (Node); --- raise; --- end; + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.HT, Tgt_Node) then + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; --- declare --- function New_Node (Next : Node_Access) return Node_Access; --- pragma Inline (New_Node); + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end Difference; --- function New_Node (Next : Node_Access) return Node_Access is --- begin --- Node.Next := Next; --- return Node; --- end New_Node; + function Difference (Left, Right : Set) return Set is + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (New_Node); + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; --- Result : Node_Access; --- Success : Boolean; --- begin --- Insert --- (HT => Container, --- Key => Node.Element, --- Node => Result, --- Success => Success); + if Left.Length = 0 then + return Empty_Set; + end if; --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; + if Right.Length = 0 then + return Left; + end if; --- pragma Assert (Result = Node); --- end; + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; --- end Replace_Element; + Length := 0; + Iterate_Left : declare + procedure Process (L_Node : Node_Access); --- procedure Replace_Element (Container : in out Set; --- Position : in Cursor; --- By : in Element_Type) is --- begin + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); --- if Position.Container = null then --- raise Constraint_Error; --- end if; + ------------- + -- Process -- + ------------- --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right.HT, L_Node) then + declare + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; --- Replace_Element (Container, Position.Node, By); + Bucket : Node_Access renames Buckets (J); --- end Replace_Element; + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + Length := Length + 1; + end if; + end Process; - procedure Move (Target : in out Set; - Source : in out Set) renames HT_Ops.Move; + -- Start of processing for Iterate_Left + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; - procedure Insert (Container : in out Set; - New_Item : in Element_Type; - Position : out Cursor; - Inserted : out Boolean) is + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Difference; - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + ------------- + -- Element -- + ------------- - function New_Node (Next : Node_Access) return Node_Access is - Node : constant Node_Access := new Node_Type'(New_Item, Next); - begin - return Node; - end New_Node; + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); + --------------------- + -- Equivalent_Sets -- + --------------------- + function Equivalent_Sets (Left, Right : Set) return Boolean is begin + return Is_Equivalent (Left.HT, Right.HT); + end Equivalent_Sets; - HT_Ops.Ensure_Capacity (Container, Container.Length + 1); - Insert (Container, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + ------------------------- + -- Equivalent_Elements -- + ------------------------- - end Insert; + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + begin + return Equivalent_Elements (Left.Node.Element, Right.Node.Element); + end Equivalent_Elements; + function Equivalent_Elements (Left : Cursor; Right : Element_Type) + return Boolean is + begin + return Equivalent_Elements (Left.Node.Element, Right); + end Equivalent_Elements; - procedure Insert (Container : in out Set; - New_Item : in Element_Type) is + function Equivalent_Elements (Left : Element_Type; Right : Cursor) + return Boolean is + begin + return Equivalent_Elements (Left, Right.Node.Element); + end Equivalent_Elements; - Position : Cursor; - Inserted : Boolean; + --------------------- + -- Equivalent_Keys -- + --------------------- + function Equivalent_Keys (Key : Element_Type; Node : Node_Access) + return Boolean is begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; - Insert (Container, New_Item, Position, Inserted); + ------------- + -- Exclude -- + ------------- - if not Inserted then - raise Constraint_Error; - end if; + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + Free (X); + end Exclude; - end Insert; + -------------- + -- Finalize -- + -------------- + procedure Finalize (Container : in out Set) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; - procedure Replace (Container : in out Set; - New_Item : in Element_Type) is + ---------- + -- Find -- + ---------- - X : Node_Access := Element_Keys.Find (Container, New_Item); + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Node_Access := Element_Keys.Find (Container.HT, Item); begin - - if X = null then - raise Constraint_Error; + if Node = null then + return No_Element; end if; - X.Element := New_Item; + return Cursor'(Container'Unrestricted_Access, Node); + end Find; - end Replace; + -------------------- + -- Find_Equal_Key -- + -------------------- + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); - procedure Include (Container : in out Set; - New_Item : in Element_Type) is - - Position : Cursor; - Inserted : Boolean; + R_Node : Node_Access := R_HT.Buckets (R_Index); begin + loop + if R_Node = null then + return False; + end if; - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - Position.Node.Element := New_Item; - end if; + if L_Node.Element = R_Node.Element then + return True; + end if; - end Include; + R_Node := Next (R_Node); + end loop; + end Find_Equal_Key; + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- - procedure Delete (Container : in out Set; - Item : in Element_Type) is + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); - X : Node_Access; + R_Node : Node_Access := R_HT.Buckets (R_Index); begin + loop + if R_Node = null then + return False; + end if; - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + if Equivalent_Elements (L_Node.Element, R_Node.Element) then + return True; + end if; - if X = null then - raise Constraint_Error; - end if; + R_Node := Next (R_Node); + end loop; + end Find_Equivalent_Key; - Free (X); + ----------- + -- First -- + ----------- - end Delete; + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); + begin + if Node = null then + return No_Element; + end if; - procedure Exclude (Container : in out Set; - Item : in Element_Type) is + return Cursor'(Container'Unrestricted_Access, Node); + end First; - X : Node_Access; + ----------------- + -- Has_Element -- + ----------------- + function Has_Element (Position : Cursor) return Boolean is begin + if Position.Node = null then + pragma Assert (Position.Container = null); + return False; + end if; - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - Free (X); + return True; + end Has_Element; - end Exclude; + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; - procedure Delete (Container : in out Set; - Position : in out Cursor) is begin + Insert (Container, New_Item, Position, Inserted); - if Position = No_Element then - return; - end if; + if not Inserted then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; + Position.Node.Element := New_Item; end if; + end Include; - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Position.Node); + ------------ + -- Insert -- + ------------ - Position.Container := null; + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - end Delete; + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + -------------- + -- New_Node -- + -------------- + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := new Node_Type'(New_Item, Next); + begin + return Node; + end New_Node; - procedure Union (Target : in out Set; - Source : in Set) is + HT : Hash_Table_Type renames Container.HT; - procedure Process (Src_Node : in Node_Access); + -- Start of processing for Insert - procedure Process (Src_Node : in Node_Access) is + begin + if HT.Length >= HT_Ops.Capacity (HT) then - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + -- TODO: + -- Perform the insertion first, and then reserve + -- capacity, but only if the insertion succeeds and + -- the (new) length is greater then current capacity. + -- END TODO. - function New_Node (Next : Node_Access) return Node_Access is - Node : constant Node_Access := - new Node_Type'(Src_Node.Element, Next); - begin - return Node; - end New_Node; + HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + end if; - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); + Local_Insert (HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; - Tgt_Node : Node_Access; - Success : Boolean; + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; - begin + begin + Insert (Container, New_Item, Position, Inserted); - Insert (Target, Src_Node.Element, Tgt_Node, Success); + if not Inserted then + raise Constraint_Error; + end if; + end Insert; - end Process; + ------------------ + -- Intersection -- + ------------------ - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + procedure Intersection + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; begin - if Target'Address = Source'Address then return; end if; - HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); - - Iterate (Source); + if Source.Length = 0 then + Clear (Target); + return; + end if; - end Union; + if Target.HT.Busy > 0 then + raise Program_Error; + end if; + -- TODO: optimize this to use an explicit + -- loop instead of an active iterator + -- (similar to how a passive iterator is + -- implemented). + -- + -- Another possibility is to test which + -- set is smaller, and iterate over the + -- smaller set. + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Source.HT, Tgt_Node) then + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - function Union (Left, Right : Set) return Set is + else + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + end if; + end loop; + end Intersection; + function Intersection (Left, Right : Set) return Set is Buckets : HT_Types.Buckets_Access; Length : Count_Type; begin - if Left'Address = Right'Address then return Left; end if; - if Right.Length = 0 then - return Left; - end if; + Length := Count_Type'Min (Left.Length, Right.Length); - if Left.Length = 0 then - return Right; + if Length = 0 then + return Empty_Set; end if; declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); begin Buckets := new Buckets_Type (0 .. Size - 1); end; - declare - procedure Process (L_Node : Node_Access); + Length := 0; - procedure Process (L_Node : Node_Access) is - I : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; - begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); - end Process; + Iterate_Left : declare + procedure Process (L_Node : Node_Access); procedure Iterate is new HT_Ops.Generic_Iteration (Process); - begin - Iterate (Left); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end; - Length := Left.Length; - - declare - procedure Process (Src_Node : Node_Access); - - procedure Process (Src_Node : Node_Access) is - - I : constant Hash_Type := - Hash (Src_Node.Element) mod Buckets'Length; - - Tgt_Node : Node_Access := Buckets (I); + ------------- + -- Process -- + ------------- + procedure Process (L_Node : Node_Access) is begin + if Is_In (Right.HT, L_Node) then + declare + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; - while Tgt_Node /= null loop - - if Equivalent_Keys (Src_Node.Element, Tgt_Node.Element) then - return; - end if; - - Tgt_Node := Next (Tgt_Node); - - end loop; + Bucket : Node_Access renames Buckets (J); - Buckets (I) := new Node_Type'(Src_Node.Element, Buckets (I)); - Length := Length + 1; + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + Length := Length + 1; + end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Left + begin - Iterate (Right); + Iterate (Left.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; + end Iterate_Left; - return (Controlled with Buckets, Length); + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Intersection; - end Union; + -------------- + -- Is_Empty -- + -------------- + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; - function Is_In - (HT : Set; - Key : Node_Access) return Boolean; - pragma Inline (Is_In); + ----------- + -- Is_In -- + ----------- - function Is_In - (HT : Set; - Key : Node_Access) return Boolean is + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean is begin return Element_Keys.Find (HT, Key.Element) /= null; end Is_In; + --------------- + -- Is_Subset -- + --------------- - procedure Intersection (Target : in out Set; - Source : in Set) is - - Tgt_Node : Node_Access; + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_Node : Node_Access; begin - - if Target'Address = Source'Address then - return; + if Subset'Address = Of_Set'Address then + return True; end if; - if Source.Length = 0 then - Clear (Target); - return; + if Subset.Length > Of_Set.Length then + return False; end if; - -- TODO: optimize this to use an explicit - -- loop instead of an active iterator - -- (similar to how a passive iterator is - -- implemented). - -- - -- Another possibility is to test which - -- set is smaller, and iterate over the - -- smaller set. + -- TODO: rewrite this to loop in the + -- style of a passive iterator. - Tgt_Node := HT_Ops.First (Target); + Subset_Node := HT_Ops.First (Subset.HT); + while Subset_Node /= null loop + if not Is_In (Of_Set.HT, Subset_Node) then + return False; + end if; + Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node); + end loop; - while Tgt_Node /= null loop + return True; + end Is_Subset; - if Is_In (Source, Tgt_Node) then + ------------- + -- Iterate -- + ------------- - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); - else + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (X); - end; + ------------------ + -- Process_Node -- + ------------------ - end if; + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; - end loop; + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames HT.Busy; - end Intersection; + -- Start of processing for Iterate + begin + B := B + 1; - function Intersection (Left, Right : Set) return Set is + begin + Iterate (HT); + exception + when others => + B := B - 1; + raise; + end; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + B := B - 1; + end Iterate; + + ------------ + -- Length -- + ------------ + function Length (Container : Set) return Count_Type is begin + return Container.HT.Length; + end Length; - if Left'Address = Right'Address then - return Left; - end if; + ---------- + -- Move -- + ---------- - Length := Count_Type'Min (Left.Length, Right.Length); + procedure Move (Target : in out Set; Source : in out Set) is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; - if Length = 0 then - return Empty_Set; + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + pragma Assert (Position.Container = null); + return No_Element; end if; declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); + begin - Buckets := new Buckets_Type (0 .. Size - 1); + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); end; + end Next; - Length := 0; + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; - declare - procedure Process (L_Node : Node_Access); + ------------- + -- Overlap -- + ------------- - procedure Process (L_Node : Node_Access) is - begin - if Is_In (Right, L_Node) then + function Overlap (Left, Right : Set) return Boolean is + Left_Node : Node_Access; - declare - I : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; - begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); - end; + begin + if Right.Length = 0 then + return False; + end if; - Length := Length + 1; + if Left'Address = Right'Address then + return True; + end if; - end if; - end Process; + Left_Node := HT_Ops.First (Left.HT); + while Left_Node /= null loop + if Is_In (Right.HT, Left_Node) then + return True; + end if; + Left_Node := HT_Ops.Next (Left.HT, Left_Node); + end loop; + + return False; + end Overlap; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + E : Element_Type renames Position.Node.Element; + + HT : Hash_Table_Type renames Position.Container.HT; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + + begin + B := B + 1; + L := L + 1; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); begin - Iterate (Left); + Process (E); exception when others => - HT_Ops.Free_Hash_Table (Buckets); + L := L - 1; + B := B - 1; raise; end; - return (Controlled with Buckets, Length); - - end Intersection; + L := L - 1; + B := B - 1; + end Query_Element; + ---------- + -- Read -- + ---------- - procedure Difference (Target : in out Set; - Source : in Set) is + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + --------------- + -- Read_Node -- + --------------- - Tgt_Node : Node_Access; + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access + is + Node : Node_Access := new Node_Type; begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - -- TODO: As I noted above, this can be - -- written in terms of a loop instead as - -- active-iterator style, sort of like a - -- passive iterator. + ------------- + -- Replace -- + ------------- - Tgt_Node := HT_Ops.First (Target); + procedure Replace + (Container : in out Set; -- TODO: need ruling from ARG + New_Item : Element_Type) + is + Node : constant Node_Access := + Element_Keys.Find (Container.HT, New_Item); - while Tgt_Node /= null loop + begin + if Node = null then + raise Constraint_Error; + end if; - if Is_In (Source, Tgt_Node) then + if Container.HT.Lock > 0 then + raise Program_Error; + end if; - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (X); - end; + Node.Element := New_Item; + end Replace; - else + --------------------- + -- Replace_Element -- + --------------------- - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + procedure Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Element : Element_Type) + is + begin + if Equivalent_Elements (Node.Element, Element) then + pragma Assert (Hash (Node.Element) = Hash (Element)); + if HT.Lock > 0 then + raise Program_Error; end if; - end loop; + Node.Element := Element; -- Note that this assignment can fail + return; + end if; - end Difference; + if HT.Busy > 0 then + raise Program_Error; + end if; + HT_Ops.Delete_Node_Sans_Free (HT, Node); + Insert_New_Element : declare + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - function Difference (Left, Right : Set) return Set is + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; + -------------- + -- New_Node -- + -------------- - begin + function New_Node (Next : Node_Access) return Node_Access is + begin + Node.Element := Element; -- Note that this assignment can fail + Node.Next := Next; + return Node; + end New_Node; - if Left'Address = Right'Address then - return Empty_Set; - end if; + Result : Node_Access; + Inserted : Boolean; - if Left.Length = 0 then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; + -- Start of processing for Insert_New_Element - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); begin - Buckets := new Buckets_Type (0 .. Size - 1); - end; + Local_Insert + (HT => HT, + Key => Element, + Node => Result, + Inserted => Inserted); + + if Inserted then + pragma Assert (Result = Node); + return; + end if; + exception + when others => + null; -- Assignment must have failed + end Insert_New_Element; - Length := 0; + Reinsert_Old_Element : declare + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - declare - procedure Process (L_Node : Node_Access); + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right, L_Node) then + -------------- + -- New_Node -- + -------------- - declare - I : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; - begin - Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); - end; + function New_Node (Next : Node_Access) return Node_Access is + begin + Node.Next := Next; + return Node; + end New_Node; - Length := Length + 1; + Result : Node_Access; + Inserted : Boolean; - end if; - end Process; + -- Start of processing for Reinsert_Old_Element - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); begin - Iterate (Left); + Local_Insert + (HT => HT, + Key => Node.Element, + Node => Result, + Inserted => Inserted); exception when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end; + null; + end Reinsert_Old_Element; - return (Controlled with Buckets, Length); + raise Program_Error; + end Replace_Element; - end Difference; + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unrestricted_Access) then + raise Program_Error; + end if; + + Replace_Element (HT, Position.Node, By); + end Replace_Element; + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + -------------- + -- Set_Next -- + -------------- - procedure Symmetric_Difference (Target : in out Set; - Source : in Set) is + procedure Set_Next (Node : Node_Access; Next : Node_Access) is begin + Node.Next := Next; + end Set_Next; + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + begin if Target'Address = Source'Address then Clear (Target); return; end if; - HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + if Target.HT.Busy > 0 then + raise Program_Error; + end if; + + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); + end if; + end; if Target.Length = 0 then - - declare + Iterate_Source_When_Empty_Target : declare procedure Process (Src_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Target.Buckets.all; - I : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.Length; + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; + begin - B (I) := new Node_Type'(E, B (I)); + B (J) := new Node_Type'(E, B (J)); N := N + 1; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Source_When_Empty_Target + begin - Iterate (Source); - end; + Iterate (Source.HT); + end Iterate_Source_When_Empty_Target; else - - declare + Iterate_Source : declare procedure Process (Src_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (Src_Node : Node_Access) is E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Target.Buckets.all; - I : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Target.Length; - begin - if B (I) = null then + B : Buckets_Type renames Target.HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.HT.Length; - B (I) := new Node_Type'(E, null); + begin + if B (J) = null then + B (J) := new Node_Type'(E, null); N := N + 1; - elsif Equivalent_Keys (E, B (I).Element) then - + elsif Equivalent_Elements (E, B (J).Element) then declare - X : Node_Access := B (I); + X : Node_Access := B (J); begin - B (I) := B (I).Next; + B (J) := B (J).Next; N := N - 1; Free (X); end; else - declare - Prev : Node_Access := B (I); + Prev : Node_Access := B (J); Curr : Node_Access := Prev.Next; + begin while Curr /= null loop - if Equivalent_Keys (E, Curr.Element) then + if Equivalent_Elements (E, Curr.Element) then Prev.Next := Curr.Next; N := N - 1; Free (Curr); @@ -873,31 +1218,25 @@ package body Ada.Containers.Hashed_Sets is Curr := Prev.Next; end loop; - B (I) := new Node_Type'(E, B (I)); + B (J) := new Node_Type'(E, B (J)); N := N + 1; end; - end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - begin - Iterate (Source); - end; + -- Start of processing for Iterate_Source + begin + Iterate (Source.HT); + end Iterate_Source; end if; - end Symmetric_Difference; - function Symmetric_Difference (Left, Right : Set) return Set is - Buckets : HT_Types.Buckets_Access; Length : Count_Type; begin - if Left'Address = Right'Address then return Empty_Set; end if; @@ -912,451 +1251,446 @@ package body Ada.Containers.Hashed_Sets is declare Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); + Prime_Numbers.To_Prime (Left.Length + Right.Length); begin Buckets := new Buckets_Type (0 .. Size - 1); end; Length := 0; - declare + Iterate_Left : declare procedure Process (L_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (L_Node : Node_Access) is begin - if not Is_In (Right, L_Node) then + if not Is_In (Right.HT, L_Node) then declare E : Element_Type renames L_Node.Element; - I : constant Hash_Type := Hash (E) mod Buckets'Length; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + begin - Buckets (I) := new Node_Type'(E, Buckets (I)); + Buckets (J) := new Node_Type'(E, Buckets (J)); Length := Length + 1; end; end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Left + begin - Iterate (Left); + Iterate (Left.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; + end Iterate_Left; - declare + Iterate_Right : declare procedure Process (R_Node : Node_Access); + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + procedure Process (R_Node : Node_Access) is begin - if not Is_In (Left, R_Node) then + if not Is_In (Left.HT, R_Node) then declare E : Element_Type renames R_Node.Element; - I : constant Hash_Type := Hash (E) mod Buckets'Length; + J : constant Hash_Type := Hash (E) mod Buckets'Length; + begin - Buckets (I) := new Node_Type'(E, Buckets (I)); + Buckets (J) := new Node_Type'(E, Buckets (J)); Length := Length + 1; end; end if; end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); + -- Start of processing for Iterate_Right + begin - Iterate (Right); + Iterate (Right.HT); exception when others => HT_Ops.Free_Hash_Table (Buckets); raise; - end; - - return (Controlled with Buckets, Length); + end Iterate_Right; + return (Controlled with HT => (Buckets, Length, 0, 0)); end Symmetric_Difference; + ----------- + -- Union -- + ----------- - function Is_Subset (Subset : Set; - Of_Set : Set) return Boolean is - - Subset_Node : Node_Access; - - begin + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Node_Access); - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); - -- TODO: rewrite this to loop in the - -- style of a passive iterator. + ------------- + -- Process -- + ------------- - Subset_Node := HT_Ops.First (Subset); + procedure Process (Src_Node : Node_Access) is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); - while Subset_Node /= null loop - if not Is_In (Of_Set, Subset_Node) then - return False; - end if; + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); - Subset_Node := HT_Ops.Next (Subset, Subset_Node); - end loop; + -------------- + -- New_Node -- + -------------- - return True; + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := + new Node_Type'(Src_Node.Element, Next); + begin + return Node; + end New_Node; - end Is_Subset; + Tgt_Node : Node_Access; + Success : Boolean; + -- Start of processing for Process - function Overlap (Left, Right : Set) return Boolean is + begin + Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); + end Process; - Left_Node : Node_Access; + -- Start of processing for Union begin - - if Right.Length = 0 then - return False; + if Target'Address = Source'Address then + return; end if; - if Left'Address = Right'Address then - return True; + if Target.HT.Busy > 0 then + raise Program_Error; end if; - Left_Node := HT_Ops.First (Left); - - while Left_Node /= null loop - if Is_In (Right, Left_Node) then - return True; + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); end if; + end; - Left_Node := HT_Ops.Next (Left, Left_Node); - end loop; - - return False; - - end Overlap; - - - function Find (Container : Set; - Item : Element_Type) return Cursor is + Iterate (Source.HT); + end Union; - Node : constant Node_Access := Element_Keys.Find (Container, Item); + function Union (Left, Right : Set) return Set is + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; begin - - if Node = null then - return No_Element; + if Left'Address = Right'Address then + return Left; end if; - return Cursor'(Container'Unchecked_Access, Node); - - end Find; - - - function Contains (Container : Set; - Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - - - function First (Container : Set) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container); - begin - if Node = null then - return No_Element; + if Right.Length = 0 then + return Left; end if; - return Cursor'(Container'Unchecked_Access, Node); - end First; - - --- function First_Element (Container : Set) return Element_Type is --- Node : constant Node_Access := HT_Ops.First (Container); --- begin --- return Node.Element; --- end First_Element; - - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null - or else Position.Node = null - then - return No_Element; + if Left.Length = 0 then + return Right; end if; declare - S : Set renames Position.Container.all; - Node : constant Node_Access := HT_Ops.Next (S, Position.Node); + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); + Buckets := new Buckets_Type (0 .. Size - 1); end; - end Next; + Iterate_Left : declare + procedure Process (L_Node : Node_Access); - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + ------------- + -- Process -- + ------------- - function Has_Element (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - end if; + procedure Process (L_Node : Node_Access) is + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; - if Position.Node = null then - return False; - end if; + begin + Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); + end Process; - return True; - end Has_Element; + -- Start of processing for Iterate_Left + begin + Iterate (Left.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; - function Equivalent_Keys (Left, Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left.Node.Element, Right.Node.Element); - end Equivalent_Keys; + Length := Left.Length; + Iterate_Right : declare + procedure Process (Src_Node : Node_Access); - function Equivalent_Keys (Left : Cursor; - Right : Element_Type) - return Boolean is - begin - return Equivalent_Keys (Left.Node.Element, Right); - end Equivalent_Keys; + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + ------------- + -- Process -- + ------------- - function Equivalent_Keys (Left : Element_Type; - Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left, Right.Node.Element); - end Equivalent_Keys; + procedure Process (Src_Node : Node_Access) is + J : constant Hash_Type := + Hash (Src_Node.Element) mod Buckets'Length; + Tgt_Node : Node_Access := Buckets (J); - procedure Iterate - (Container : in Set; - Process : not null access procedure (Position : in Cursor)) is + begin + while Tgt_Node /= null loop + if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then + return; + end if; - procedure Process_Node (Node : in Node_Access); - pragma Inline (Process_Node); + Tgt_Node := Next (Tgt_Node); + end loop; - procedure Process_Node (Node : in Node_Access) is - begin - Process (Cursor'(Container'Unchecked_Access, Node)); - end Process_Node; + Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); + Length := Length + 1; + end Process; - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - begin - Iterate (Container); - end Iterate; + -- Start of processing for Iterate_Right + begin + Iterate (Right.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; - function Capacity (Container : Set) return Count_Type - renames HT_Ops.Capacity; + return (Controlled with HT => (Buckets, Length, 0, 0)); + end Union; - procedure Reserve_Capacity - (Container : in out Set; - Capacity : in Count_Type) - renames HT_Ops.Ensure_Capacity; + ----------- + -- Write -- + ----------- + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; - procedure Write_Node - (Stream : access Root_Stream_Type'Class; - Node : in Node_Access); - pragma Inline (Write_Node); + ---------------- + -- Write_Node -- + ---------------- procedure Write_Node (Stream : access Root_Stream_Type'Class; - Node : in Node_Access) is + Node : Node_Access) + is begin Element_Type'Write (Stream, Node.Element); end Write_Node; - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - procedure Write - (Stream : access Root_Stream_Type'Class; - Container : in Set) renames Write_Nodes; - - - function Read_Node (Stream : access Root_Stream_Type'Class) - return Node_Access; - pragma Inline (Read_Node); - - function Read_Node (Stream : access Root_Stream_Type'Class) - return Node_Access is - - Node : Node_Access := new Node_Type; - begin - Element_Type'Read (Stream, Node.Element); - return Node; - exception - when others => - Free (Node); - raise; - end Read_Node; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - procedure Read - (Stream : access Root_Stream_Type'Class; - Container : out Set) renames Read_Nodes; - - package body Generic_Keys is - function Equivalent_Keys (Left : Cursor; - Right : Key_Type) - return Boolean is - begin - return Equivalent_Keys (Right, Left.Node.Element); - end Equivalent_Keys; + ----------------------- + -- Local Subprograms -- + ----------------------- - function Equivalent_Keys (Left : Key_Type; - Right : Cursor) - return Boolean is - begin - return Equivalent_Keys (Left, Right.Node.Element); - end Equivalent_Keys; - - function Equivalent_Keys + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); + pragma Inline (Equivalent_Key_Node); - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Node.Element); - end Equivalent_Keys; + -------------------------- + -- Local Instantiations -- + -------------------------- package Key_Keys is new Hash_Tables.Generic_Keys (HT_Types => HT_Types, - HT_Type => Set, - Null_Node => null, Next => Next, Set_Next => Set_Next, Key_Type => Key_Type, Hash => Hash, - Equivalent_Keys => Equivalent_Keys); + Equivalent_Keys => Equivalent_Key_Node); + -------------- + -- Contains -- + -------------- - function Find (Container : Set; - Key : Key_Type) - return Cursor is - - Node : constant Node_Access := - Key_Keys.Find (Container, Key); - + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is begin + return Find (Container, Key) /= No_Element; + end Contains; - if Node = null then - return No_Element; - end if; + ------------ + -- Delete -- + ------------ - return Cursor'(Container'Unchecked_Access, Node); + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; - end Find; + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + if X = null then + raise Constraint_Error; + end if; - function Contains (Container : Set; - Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; + Free (X); + end Delete; + ------------- + -- Element -- + ------------- - function Element (Container : Set; - Key : Key_Type) - return Element_Type is + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); - Node : constant Node_Access := Key_Keys.Find (Container, Key); begin return Node.Element; end Element; + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- - function Key (Position : Cursor) return Key_Type is + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean + is begin - return Key (Position.Node.Element); - end Key; - - --- TODO: --- procedure Replace (Container : in out Set; --- Key : in Key_Type; --- New_Item : in Element_Type) is - --- Node : constant Node_Access := --- Key_Keys.Find (Container, Key); - --- begin - --- if Node = null then --- raise Constraint_Error; --- end if; + return Equivalent_Keys (Key, Node.Element); + end Equivalent_Key_Node; --- Replace_Element (Container, Node, New_Item); + --------------------- + -- Equivalent_Keys -- + --------------------- --- end Replace; + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean is + begin + return Equivalent_Keys (Right, Left.Node.Element); + end Equivalent_Keys; + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Element); + end Equivalent_Keys; - procedure Delete (Container : in out Set; - Key : in Key_Type) is + ------------- + -- Exclude -- + ------------- + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is X : Node_Access; - begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + ---------- + -- Find -- + ---------- - if X = null then - raise Constraint_Error; + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); + + begin + if Node = null then + return No_Element; end if; - Free (X); + return Cursor'(Container'Unrestricted_Access, Node); + end Find; - end Delete; + --------- + -- Key -- + --------- + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element); + end Key; - procedure Exclude (Container : in out Set; - Key : in Key_Type) is + ------------- + -- Replace -- + ------------- - X : Node_Access; + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := + Key_Keys.Find (Container.HT, Key); begin + if Node = null then + raise Constraint_Error; + end if; - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - Free (X); - - end Exclude; + Replace_Element (Container.HT, Node, New_Item); + end Replace; + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; - Position : in Cursor; + Position : Cursor; Process : not null access - procedure (Element : in out Element_Type)) is + procedure (Element : in out Element_Type)) + is + HT : Hash_Table_Type renames Container.HT; begin - - if Position.Container = null then + if Position.Node = null then raise Constraint_Error; end if; @@ -1365,53 +1699,43 @@ package body Ada.Containers.Hashed_Sets is end if; declare - Old_Key : Key_Type renames Key (Position.Node.Element); - begin - Process (Position.Node.Element); + E : Element_Type renames Position.Node.Element; + K : Key_Type renames Key (E); - if Equivalent_Keys (Old_Key, Position.Node.Element) then - return; - end if; - end; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; - declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); + begin + B := B + 1; + L := L + 1; - function New_Node (Next : Node_Access) return Node_Access is begin - Position.Node.Next := Next; - return Position.Node; - end New_Node; - - procedure Insert is - new Key_Keys.Generic_Conditional_Insert (New_Node); - - Result : Node_Access; - Success : Boolean; - begin - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; - Insert - (HT => Container, - Key => Key (Position.Node.Element), - Node => Result, - Success => Success); + L := L - 1; + B := B - 1; - if not Success then - declare - X : Node_Access := Position.Node; - begin - Free (X); - end; - - raise Program_Error; + if Equivalent_Keys (K, E) then + pragma Assert (Hash (K) = Hash (E)); + return; end if; + end; - pragma Assert (Result = Position.Node); + declare + X : Node_Access := Position.Node; + begin + HT_Ops.Delete_Node_Sans_Free (HT, X); + Free (X); end; - end Checked_Update_Element; + raise Program_Error; + end Update_Element_Preserving_Key; end Generic_Keys; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 9f0cdc3..16aaf5d 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASHED_SETS -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,16 +35,15 @@ with Ada.Containers.Hash_Tables; with Ada.Streams; +with Ada.Finalization; generic type Element_Type is private; with function Hash (Element : Element_Type) return Hash_Type; - -- TODO: get a ruling from ARG in Atlanta re the name and - -- order of these declarations. ??? - -- - with function Equivalent_Keys (Left, Right : Element_Type) return Boolean; + with function Equivalent_Elements (Left, Right : Element_Type) + return Boolean; with function "=" (Left, Right : Element_Type) return Boolean is <>; @@ -61,6 +60,8 @@ pragma Preelaborate (Hashed_Sets); function "=" (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -73,11 +74,10 @@ pragma Preelaborate (Hashed_Sets); (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - -- TODO: resolve in atlanta - -- procedure Replace_Element - -- (Container : in out Set; - -- Position : Cursor; - -- By : Element_Type); + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type); procedure Move (Target : in out Set; Source : in out Set); @@ -95,9 +95,37 @@ pragma Preelaborate (Hashed_Sets); procedure Delete (Container : in out Set; Item : Element_Type); + procedure Delete (Container : in out Set; Position : in out Cursor); + procedure Exclude (Container : in out Set; Item : Element_Type); - procedure Delete (Container : in out Set; Position : in out Cursor); + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + + function First (Container : Set) return Cursor; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); procedure Union (Target : in out Set; Source : Set); @@ -128,40 +156,12 @@ pragma Preelaborate (Hashed_Sets); function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function Find - (Container : Set; - Item : Element_Type) return Cursor; - function Capacity (Container : Set) return Count_Type; procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); - function First (Container : Set) return Cursor; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Has_Element (Position : Cursor) return Boolean; - - function Equivalent_Keys (Left, Right : Cursor) return Boolean; - - function Equivalent_Keys - (Left : Cursor; - Right : Element_Type) return Boolean; - - function Equivalent_Keys - (Left : Element_Type; - Right : Cursor) return Boolean; - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - generic type Key_Type (<>) is limited private; @@ -183,18 +183,16 @@ pragma Preelaborate (Hashed_Sets); function Element (Container : Set; Key : Key_Type) return Element_Type; - -- TODO: resolve in atlanta - -- procedure Replace - -- (Container : in out Set; - -- Key : Key_Type; - -- New_Item : Element_Type); + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); procedure Delete (Container : in out Set; Key : Key_Type); procedure Exclude (Container : in out Set; Key : Key_Type); - -- TODO: resolve name in atlanta: ??? - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; Process : not null access @@ -215,24 +213,35 @@ private type Node_Type; type Node_Access is access Node_Type; - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + type Node_Type is + limited record + Element : Element_Type; + Next : Node_Access; + end record; - use HT_Types; + package HT_Types is new Hash_Tables.Generic_Hash_Table_Types + (Node_Type, + Node_Access); - type Set is new Hash_Table_Type with null record; + type Set is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; procedure Adjust (Container : in out Set); procedure Finalize (Container : in out Set); - type Set_Access is access constant Set; + use HT_Types; + use Ada.Finalization; + + type Set_Access is access all Set; for Set_Access'Storage_Size use 0; - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; + type Cursor is + record + Container : Set_Access; + Node : Node_Access; + end record; No_Element : constant Cursor := (Container => null, Node => null); @@ -250,6 +259,6 @@ private for Set'Read use Read; - Empty_Set : constant Set := (Hash_Table_Type with null record); + Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads index 068efc6..08d0532 100644 --- a/gcc/ada/a-cohata.ads +++ b/gcc/ada/a-cohata.ads @@ -2,33 +2,55 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.HASH_TABLES -- +-- A D A . C O N T A I N E R S . H A S H _ T A B L E S -- -- -- -- S p e c -- -- -- --- This specification is adapted from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Finalization; - package Ada.Containers.Hash_Tables is pragma Preelaborate; generic - type Node_Access is private; + type Node_Type (<>) is limited private; + + type Node_Access is access Node_Type; package Generic_Hash_Table_Types is type Buckets_Type is array (Hash_Type range <>) of Node_Access; type Buckets_Access is access Buckets_Type; - type Hash_Table_Type is new Ada.Finalization.Controlled with record + type Hash_Table_Type is tagged record Buckets : Buckets_Access; Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; end record; end Generic_Hash_Table_Types; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index c997430..39ef4e5 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_VECTORS -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -39,209 +39,272 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is - type Int is range System.Min_Int .. System.Max_Int; procedure Free is - new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - - procedure Adjust (Container : in out Vector) is - begin - - if Container.Elements = null then - return; - end if; + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - if Container.Elements'Length = 0 - or else Container.Last < Index_Type'First - then - Container.Elements := null; - return; - end if; + --------- + -- "&" -- + --------- - declare - E : Elements_Type renames Container.Elements.all; - L : constant Index_Type := Container.Last; - begin - - Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); - - Container.Elements := new Elements_Type (Index_Type'First .. L); - - for I in Container.Elements'Range loop - - if E (I) /= null then - Container.Elements (I) := new Element_Type'(E (I).all); - end if; + function "&" (Left, Right : Vector) return Vector is + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); - Container.Last := I; + begin + if LN = 0 then + if RN = 0 then + return Empty_Vector; + end if; - end loop; + declare + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); - end; + Elements : Elements_Access := + new Elements_Type (RE'Range); - end Adjust; + begin + for I in Elements'Range loop + begin + if RE (I) /= null then + Elements (I) := new Element_Type'(RE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + Free (Elements); + raise; + end; + end loop; - procedure Finalize (Container : in out Vector) is + return (Controlled with Elements, Right.Last, 0, 0); + end; - E : Elements_Access := Container.Elements; - L : constant Index_Type'Base := Container.Last; + end if; - begin + if RN = 0 then + declare + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); + Elements : Elements_Access := + new Elements_Type (LE'Range); - for I in Index_Type'First .. L loop - Free (E (I)); - end loop; + begin + for I in Elements'Range loop + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - Free (E); + Free (Elements); + raise; + end; + end loop; - end Finalize; + return (Controlled with Elements, Left.Last, 0, 0); + end; + end if; + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN) + Int (RN) - 1; - procedure Write - (Stream : access Root_Stream_Type'Class; - Container : in Vector) is + Last : constant Index_Type := Index_Type (Last_As_Int); - N : constant Count_Type := Length (Container); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - begin + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); - Count_Type'Base'Write (Stream, N); + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); - if N = 0 then - return; - end if; + I : Index_Type'Base := Index_Type'Pred (Index_Type'First); - declare - E : Elements_Type renames Container.Elements.all; begin - for I in Index_Type'First .. Container.Last loop - - -- There's another way to do this. Instead a separate - -- Boolean for each element, you could write a Boolean - -- followed by a count of how many nulls or non-nulls - -- follow in the array. Alternately you could use a - -- signed integer, and use the sign as the indicator - -- or null-ness. + for LI in LE'Range loop + I := Index_Type'Succ (I); - if E (I) = null then - Boolean'Write (Stream, False); - else - Boolean'Write (Stream, True); - Element_Type'Output (Stream, E (I).all); - end if; + begin + if LE (LI) /= null then + Elements (I) := new Element_Type'(LE (LI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + Free (Elements); + raise; + end; end loop; - end; - end Write; + for RI in RE'Range loop + I := Index_Type'Succ (I); + begin + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - procedure Read - (Stream : access Root_Stream_Type'Class; - Container : out Vector) is + Free (Elements); + raise; + end; + end loop; - Length : Count_Type'Base; - Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; - B : Boolean; + function "&" (Left : Vector; Right : Element_Type) return Vector is + LN : constant Count_Type := Length (Left); begin + if LN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - for I in Count_Type range 1 .. Length loop - - Last := Index_Type'Succ (Last); - - Boolean'Read (Stream, B); - - if B then - Container.Elements (Last) := - new Element_Type'(Element_Type'Input (Stream)); - end if; - - Container.Last := Last; - - end loop; - - end Read; - + Elements : Elements_Access := new Elements_Subtype; - function To_Vector (Length : Count_Type) return Vector is - begin + begin + begin + Elements (Elements'First) := new Element_Type'(Right); + exception + when others => + Free (Elements); + raise; + end; - if Length = 0 then - return Empty_Vector; + return (Controlled with Elements, Index_Type'First, 0, 0); + end; end if; declare - - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := - First + Int (Length) - 1; + Int (Index_Type'First) + Int (LN); - Last : constant Index_Type := - Index_Type (Last_As_Int); + Last : constant Index_Type := Index_Type (Last_As_Int); - Elements : constant Elements_Access := - new Elements_Type (Index_Type'First .. Last); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - begin + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); - return (Controlled with Elements, Last); + begin + for I in LE'Range loop + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; - end; + Free (Elements); + raise; + end; + end loop; - end To_Vector; + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + declare + subtype J_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Elements'Last); + begin + for J in J_Subtype loop + Free (Elements (J)); + end loop; + end; + Free (Elements); + raise; + end; + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector is + function "&" (Left : Element_Type; Right : Vector) return Vector is + RN : constant Count_Type := Length (Right); begin + if RN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); - if Length = 0 then - return Empty_Vector; - end if; + Elements : Elements_Access := new Elements_Subtype; - declare + begin + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; - First : constant Int := Int (Index_Type'First); + return (Controlled with Elements, Index_Type'First, 0, 0); + end; + end if; + declare Last_As_Int : constant Int'Base := - First + Int (Length) - 1; + Int (Index_Type'First) + Int (RN); + + Last : constant Index_Type := Index_Type (Last_As_Int); - Last : constant Index_Type := - Index_Type (Last_As_Int); + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + new Elements_Type (Index_Type'First .. Last); + + I : Index_Type'Base := Index_Type'First; begin + begin + Elements (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; - for I in Elements'Range loop + for RI in RE'Range loop + I := Index_Type'Succ (I); begin - Elements (I) := new Element_Type'(New_Item); + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; exception when others => for J in Index_Type'First .. Index_Type'Pred (I) loop @@ -251,19 +314,45 @@ package body Ada.Containers.Indefinite_Vectors is Free (Elements); raise; end; - end loop; - return (Controlled with Elements, Last); + return (Controlled with Elements, Last, 0, 0); + end; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + subtype IT is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Index_Type'First); + Elements : Elements_Access := new Elements_Type (IT); + + begin + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; end; - end To_Vector; + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + Free (Elements (Elements'First)); + Free (Elements); + raise; + end; + return (Controlled with Elements, Elements'Last, 0, 0); + end "&"; + + --------- + -- "=" -- + --------- function "=" (Left, Right : Vector) return Boolean is begin - if Left'Address = Right'Address then return True; end if; @@ -272,8 +361,7 @@ package body Ada.Containers.Indefinite_Vectors is return False; end if; - for I in Index_Type'First .. Left.Last loop - + for J in Index_Type'First .. Left.Last loop -- NOTE: -- I think it's a bounded error to read or otherwise manipulate -- an "empty" element, which here means that it has the value @@ -285,396 +373,719 @@ package body Ada.Containers.Indefinite_Vectors is -- you have a contrary argument then let me know. -- END NOTE. - if Left.Elements (I) = null then - - if Right.Elements (I) /= null then + if Left.Elements (J) = null then + if Right.Elements (J) /= null then return False; end if; - elsif Right.Elements (I) = null then - + elsif Right.Elements (J) = null then return False; - elsif Left.Elements (I).all /= Right.Elements (I).all then - + elsif Left.Elements (J).all /= Right.Elements (J).all then return False; end if; - end loop; return True; - end "="; + ------------ + -- Adjust -- + ------------ - function Length (Container : Vector) return Count_Type is - - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - - N : constant Int'Base := L - F + 1; + procedure Adjust (Container : in out Vector) is begin - return Count_Type (N); - end Length; + if Container.Elements = null then + return; + end if; + if Container.Elements'Length = 0 + or else Container.Last < Index_Type'First + then + Container.Elements := null; + return; + end if; - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; + declare + E : Elements_Type renames Container.Elements.all; + L : constant Index_Type := Container.Last; + begin + Container.Elements := null; + Container.Last := No_Index; + Container.Busy := 0; + Container.Lock := 0; + Container.Elements := new Elements_Type (Index_Type'First .. L); - procedure Set_Length - (Container : in out Vector; - Length : in Count_Type) is + for I in Container.Elements'Range loop + if E (I) /= null then + Container.Elements (I) := new Element_Type'(E (I).all); + end if; - N : constant Count_Type := Indefinite_Vectors.Length (Container); + Container.Last := I; + end loop; + end; + end Adjust; - begin + ------------ + -- Append -- + ------------ - if Length = N then + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then return; end if; - if Length = 0 then - Clear (Container); + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then return; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item, + Count); + end Append; - Last : constant Index_Type := - Index_Type (Last_As_Int); - begin + ------------ + -- Assign -- + ------------ - if Length > N then + procedure Assign + (Target : in out Vector; + Source : Vector) + is + N : constant Count_Type := Length (Source); - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; + begin + if Target'Address = Source'Address then + return; + end if; - Container.Last := Last; + Clear (Target); - return; + if N = 0 then + return; + end if; - end if; + if N > Capacity (Target) then + Reserve_Capacity (Target, Capacity => N); + end if; - for I in reverse Index_Type'Succ (Last) .. Container.Last loop + for J in Index_Type'First .. Source.Last loop + declare + EA : constant Element_Access := Source.Elements (J); + begin + if EA /= null then + Target.Elements (J) := new Element_Type'(EA.all); + end if; + end; - declare - X : Element_Access := Container.Elements (I); - begin - Container.Elements (I) := null; - Container.Last := Index_Type'Pred (Container.Last); - Free (X); - end; + Target.Last := J; + end loop; + end Assign; - end loop; + -------------- + -- Capacity -- + -------------- - end; + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; - end Set_Length; + return Container.Elements'Length; + end Capacity; + ----------- + -- Clear -- + ----------- procedure Clear (Container : in out Vector) is begin + if Container.Busy > 0 then + raise Program_Error; + end if; - for I in reverse Index_Type'First .. Container.Last loop - + for J in reverse Index_Type'First .. Container.Last loop declare - X : Element_Access := Container.Elements (I); + X : Element_Access := Container.Elements (J); begin - Container.Elements (I) := null; - Container.Last := Index_Type'Pred (I); + Container.Elements (J) := null; + Container.Last := Index_Type'Pred (J); Free (X); end; - end loop; - end Clear; + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ------------ + -- Delete -- + ------------ - procedure Append (Container : in out Vector; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is begin + if Index < Index_Type'First then + raise Constraint_Error; + end if; + + if Index > Container.Last then + if Index > Container.Last + 1 then + raise Constraint_Error; + end if; + + return; + end if; + if Count = 0 then return; end if; - Insert - (Container, - Index_Type'Succ (Container.Last), - New_Item, - Count); - end Append; + if Container.Busy > 0 then + raise Program_Error; + end if; + declare + I_As_Int : constant Int := Int (Index); - procedure Insert - (Container : in out Vector; - Before : in Extended_Index; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + Old_Last_As_Int : constant Int := Int (Container.Last); - Old_Last_As_Int : constant Int := Int (Container.Last); + Count1 : constant Int'Base := Int (Count); + Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - N : constant Int := Int (Count); + N : constant Int'Base := Int'Min (Count1, Count2); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + J_As_Int : constant Int'Base := I_As_Int + N; + J : constant Index_Type'Base := Index_Type'Base (J_As_Int); - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + E : Elements_Type renames Container.Elements.all; - Index : Index_Type; + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - Dst_Last : Index_Type; - Dst : Elements_Access; + New_Last : constant Extended_Index := + Extended_Index (New_Last_As_Int); + + begin + for K in Index .. Index_Type'Pred (J) loop + declare + X : Element_Access := E (K); + begin + E (K) := null; + Free (X); + end; + end loop; + + E (Index .. New_Last) := E (J .. Container.Last); + Container.Last := New_Last; + end; + end Delete; + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is begin + if Position.Container = null then + raise Constraint_Error; + end if; - if Count = 0 then - return; + if Position.Container /= + Vector_Access'(Container'Unchecked_Access) + or else Position.Index > Container.Last + then + raise Program_Error; end if; - declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Delete (Container, Position.Index, Count); - Old_First : constant Before_Subtype := Before; + if Position.Index <= Container.Last then + Position := (Container'Unchecked_Access, Position.Index); + else + Position := No_Element; + end if; + end Delete; - Old_First_As_Int : constant Int := Int (Old_First); + ------------------ + -- Delete_First -- + ------------------ - New_First_As_Int : constant Int'Base := Old_First_As_Int + N; - begin - Index := Index_Type (New_First_As_Int); - end; + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; - if Container.Elements = null then + if Count >= Length (Container) then + Clear (Container); + return; + end if; - declare - subtype Elements_Subtype is - Elements_Type (Index_Type'First .. New_Last); - begin - Container.Elements := new Elements_Subtype; - Container.Last := Index_Type'Pred (Index_Type'First); + Delete (Container, Index_Type'First, Count); + end Delete_First; - for I in Container.Elements'Range loop - Container.Elements (I) := new Element_Type'(New_Item); - Container.Last := I; - end loop; - end; + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + Index : Int'Base; + begin + if Count = 0 then return; + end if; + if Count >= Length (Container) then + Clear (Container); + return; end if; - if New_Last <= Container.Elements'Last then + Index := Int'Base (Container.Last) - Int'Base (Count) + 1; - declare - E : Elements_Type renames Container.Elements.all; - begin - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; + Delete (Container, Index_Type'Base (Index), Count); + end Delete_Last; - -- NOTE: - -- Now we do the allocation. If it fails, we can propagate the - -- exception and invariants are more or less satisfied. The - -- issue is that we have some slots still null, and the client - -- has no way of detecting whether the slot is null (unless we - -- give him a way). - -- - -- Another way is to allocate a subarray on the stack, do the - -- allocation into that array, and if that success then do - -- the insertion proper. The issue there is that you have to - -- allocate the subarray on the stack, and that may fail if the - -- subarray is long. - -- - -- Or we could try to roll-back the changes: deallocate the - -- elements we have successfully deallocated, and then copy - -- the elements ptrs back to their original posns. - -- END NOTE. + ------------- + -- Element -- + ------------- - -- NOTE: I have written the loop manually here. I could - -- have done it this way too: - -- E (Before .. Index_Type'Pred (Index)) := - -- (others => new Element_Type'New_Item); - -- END NOTE. + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + return Container.Elements (T'(Index)).all; + end Element; - for I in Before .. Index_Type'Pred (Index) loop + function Element (Position : Cursor) return Element_Type is + begin + return Element (Position.Container.all, Position.Index); + end Element; - begin - E (I) := new Element_Type'(New_Item); - exception - when others => - E (I .. Index_Type'Pred (Index)) := (others => null); - raise; - end; + -------------- + -- Finalize -- + -------------- - end loop; - end; + procedure Finalize (Container : in out Vector) is + begin + Clear (Container); - return; + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Free (X); + end; + end Finalize; + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor is + + begin + if Position.Container /= null + and then (Position.Container /= + Vector_Access'(Container'Unchecked_Access) + or else Position.Index > Container.Last) + then + raise Program_Error; end if; - declare + for J in Position.Index .. Container.Last loop + if Container.Elements (J) /= null + and then Container.Elements (J).all = Item + then + return (Container'Unchecked_Access, J); + end if; + end loop; - First : constant Int := Int (Index_Type'First); + return No_Element; + end Find; - New_Size : constant Int'Base := - New_Last_As_Int - First + 1; + ---------------- + -- Find_Index -- + ---------------- - Max_Size : constant Int'Base := - Int (Index_Type'Last) - First + 1; + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index is + begin + for Indx in Index .. Container.Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item + then + return Indx; + end if; + end loop; - Size, Dst_Last_As_Int : Int'Base; + return No_Index; + end Find_Index; - begin + ----------- + -- First -- + ----------- - if New_Size >= Max_Size / 2 then + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; - Dst_Last := Index_Type'Last; + return (Container'Unchecked_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + function First_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Index_Type'First); + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Less (L, R : Element_Access) return Boolean; + pragma Inline (Is_Less); + + ------------- + -- Is_Less -- + ------------- + + function Is_Less (L, R : Element_Access) return Boolean is + begin + if L = null then + return R /= null; + elsif R = null then + return False; else + return L.all < R.all; + end if; + end Is_Less; - Size := Container.Elements'Length; + --------------- + -- Is_Sorted -- + --------------- - if Size = 0 then - Size := 1; - end if; + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; - while Size < New_Size loop - Size := 2 * Size; + declare + E : Elements_Type renames Container.Elements.all; + begin + for I in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (I + 1), E (I)) then + return False; + end if; end loop; + end; - Dst_Last_As_Int := First + Size - 1; - Dst_Last := Index_Type (Dst_Last_As_Int); + return True; + end Is_Sorted; + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I : Index_Type'Base := Target.Last; + J : Index_Type'Base; + + begin + if Target.Last < Index_Type'First then + Move (Target => Target, Source => Source); + return; end if; - end; + if Target'Address = Source'Address then + return; + end if; - Dst := new Elements_Type (Index_Type'First .. Dst_Last); + if Source.Last < Index_Type'First then + return; + end if; - declare - Src : Elements_Type renames Container.Elements.all; - begin - Dst (Index_Type'First .. Index_Type'Pred (Before)) := - Src (Index_Type'First .. Index_Type'Pred (Before)); + if Source.Busy > 0 then + raise Program_Error; + end if; - Dst (Index .. New_Last) := Src (Before .. Container.Last); - end; + Target.Set_Length (Length (Target) + Length (Source)); + + J := Target.Last; + while Source.Last >= Index_Type'First loop + if I < Index_Type'First then + declare + Src : Elements_Type renames + Source.Elements (Index_Type'First .. Source.Last); + + begin + Target.Elements (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + return; + end if; + + declare + Src : Element_Access renames Source.Elements (Source.Last); + Tgt : Element_Access renames Target.Elements (I); + + begin + if Is_Less (Src, Tgt) then + Target.Elements (J) := Tgt; + Tgt := null; + I := I - 1; + + else + Target.Elements (J) := Src; + Src := null; + Source.Last := Source.Last - 1; + end if; + end; + + J := J - 1; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Access, + Array_Type => Elements_Type, + "<" => Is_Less); + + -- Start of processing for Sort - declare - X : Elements_Access := Container.Elements; begin - Container.Elements := Dst; - Container.Last := New_Last; + if Container.Last <= Index_Type'First then + return; + end if; - Free (X); - end; + if Container.Lock > 0 then + raise Program_Error; + end if; - -- NOTE: - -- Now do the allocation. If the allocation fails, - -- then the worst thing is that we have a few null slots. - -- Our invariants are otherwise satisfied. - -- END NOTE. + Sort (Container.Elements (Index_Type'First .. Container.Last)); + end Sort; - for I in Before .. Index_Type'Pred (Index) loop - Dst (I) := new Element_Type'(New_Item); - end loop; + end Generic_Sorting; - end Insert; + ----------------- + -- Has_Element -- + ----------------- + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; - procedure Insert_Space - (Container : in out Vector; - Before : in Extended_Index; - Count : in Count_Type := 1) is + return Position.Index <= Position.Container.Last; + end Has_Element; - Old_Last_As_Int : constant Int := Int (Container.Last); + ------------ + -- Insert -- + ------------ + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is N : constant Int := Int (Count); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; - - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - Index : Index_Type; + Index : Extended_Index; -- TODO: see note in a-convec.adb. Dst_Last : Index_Type; Dst : Elements_Access; begin + if Before < Index_Type'First then + raise Constraint_Error; + end if; + + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; + end if; if Count = 0 then return; end if; declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Old_Last_As_Int : constant Int := Int (Container.Last); - Old_First : constant Before_Subtype := Before; + begin + New_Last_As_Int := Old_Last_As_Int + N; + New_Last := Index_Type (New_Last_As_Int); + end; - Old_First_As_Int : constant Int := Int (Old_First); + if Container.Busy > 0 then + raise Program_Error; + end if; + + declare + Old_First_As_Int : constant Int := Int (Before); New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + begin - Index := Index_Type (New_First_As_Int); + Index := Extended_Index (New_First_As_Int); -- TODO end; if Container.Elements = null then - declare subtype Elements_Subtype is Elements_Type (Index_Type'First .. New_Last); begin Container.Elements := new Elements_Subtype; - Container.Last := New_Last; + Container.Last := Index_Type'Pred (Index_Type'First); + + for J in Container.Elements'Range loop + Container.Elements (J) := new Element_Type'(New_Item); + Container.Last := J; + end loop; end; return; - end if; if New_Last <= Container.Elements'Last then - declare E : Elements_Type renames Container.Elements.all; begin E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index_Type'Pred (Index)) := (others => null); - Container.Last := New_Last; + + -- NOTE: + -- Now we do the allocation. If it fails, we can propagate the + -- exception and invariants are more or less satisfied. The + -- issue is that we have some slots still null, and the client + -- has no way of detecting whether the slot is null (unless we + -- give him a way). + -- + -- Another way is to allocate a subarray on the stack, do the + -- allocation into that array, and if that success then do + -- the insertion proper. The issue there is that you have to + -- allocate the subarray on the stack, and that may fail if the + -- subarray is long. + -- + -- Or we could try to roll-back the changes: deallocate the + -- elements we have successfully deallocated, and then copy + -- the elements ptrs back to their original posns. + -- END NOTE. + + -- NOTE: I have written the loop manually here. I could + -- have done it this way too: + -- E (Before .. Index_Type'Pred (Index)) := + -- (others => new Element_Type'New_Item); + -- END NOTE. + + for J in Before .. Index_Type'Pred (Index) loop + begin + E (J) := new Element_Type'(New_Item); + exception + when others => + E (J .. Index_Type'Pred (Index)) := (others => null); + raise; + end; + end loop; end; return; - end if; declare - First : constant Int := Int (Index_Type'First); - New_Size : constant Int'Base := - Int (New_Last_As_Int) - First + 1; - - Max_Size : constant Int'Base := - Int (Index_Type'Last) - First + 1; + New_Size : constant Int'Base := New_Last_As_Int - First + 1; + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; Size, Dst_Last_As_Int : Int'Base; begin - if New_Size >= Max_Size / 2 then - Dst_Last := Index_Type'Last; else - Size := Container.Elements'Length; if Size = 0 then @@ -687,15 +1098,14 @@ package body Ada.Containers.Indefinite_Vectors is Dst_Last_As_Int := First + Size - 1; Dst_Last := Index_Type (Dst_Last_As_Int); - end if; - end; Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare Src : Elements_Type renames Container.Elements.all; + begin Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); @@ -712,900 +1122,564 @@ package body Ada.Containers.Indefinite_Vectors is Free (X); end; - end Insert_Space; - - - procedure Delete_First (Container : in out Vector; - Count : in Count_Type := 1) is - begin - - if Count = 0 then - return; - end if; - - if Count >= Length (Container) then - Clear (Container); - return; - end if; - - Delete (Container, Index_Type'First, Count); - - end Delete_First; - + -- NOTE: + -- Now do the allocation. If the allocation fails, + -- then the worst thing is that we have a few null slots. + -- Our invariants are otherwise satisfied. + -- END NOTE. - procedure Delete_Last (Container : in out Vector; - Count : in Count_Type := 1) is + for J in Before .. Index_Type'Pred (Index) loop + Dst (J) := new Element_Type'(New_Item); + end loop; + end Insert; - Index : Int'Base; + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); begin - - if Count = 0 then - return; + if Before < Index_Type'First then + raise Constraint_Error; end if; - if Count >= Length (Container) then - Clear (Container); - return; + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; end if; - Index := Int'Base (Container.Last) - Int'Base (Count) + 1; - - Delete (Container, Index_Type'Base (Index), Count); - - end Delete_Last; - - - procedure Delete - (Container : in out Vector; - Index : in Extended_Index; -- TODO: verify in Atlanta - Count : in Count_Type := 1) is - - begin - - if Count = 0 then + if N = 0 then return; end if; - declare - - subtype I_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - I : constant I_Subtype := Index; - I_As_Int : constant Int := Int (I); - - Old_Last_As_Int : constant Int := Int (Container.Last); - - Count1 : constant Int'Base := Int (Count); - Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - - N : constant Int'Base := Int'Min (Count1, Count2); + Insert_Space (Container, Before, Count => N); - J_As_Int : constant Int'Base := I_As_Int + N; - J : constant Index_Type'Base := Index_Type'Base (J_As_Int); + if Container'Address = New_Item'Address then + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; - E : Elements_Type renames Container.Elements.all; + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); - New_Last : constant Extended_Index := - Extended_Index (New_Last_As_Int); + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); - begin + begin + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Before); - for K in I .. Index_Type'Pred (J) loop + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); begin - Free (E (K)); - exception - when others => - E (K) := null; - raise; - end; - - end loop; - - E (I .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; - - end; - - end Delete; - - - function Capacity (Container : Vector) return Count_Type is - begin - if Container.Elements = null then - return 0; - end if; - - return Container.Elements'Length; - end Capacity; - - - procedure Reserve_Capacity (Container : in out Vector; - Capacity : in Count_Type) is - - N : constant Count_Type := Length (Container); - - begin - - if Capacity = 0 then - - if N = 0 then + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := null; - Free (X); + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; end; - elsif N < Container.Elements'Length then - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'Succ (Dst_Last) .. Container.Last; Src : Elements_Type renames - Container.Elements (Array_Index_Subtype); + Container.Elements (Src_Index_Subtype); - subtype Array_Subtype is - Elements_Type (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; begin - Container.Elements := new Array_Subtype'(Src); - Free (X); - end; - - end if; + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - return; + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + end; - end if; + else + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; - if Container.Elements = null then + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); - Last : constant Index_Type := - Index_Type (Last_As_Int); + Src : Elements_Type renames + New_Item.Elements (Index_Type'First .. New_Item.Last); - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); begin - Container.Elements := new Array_Subtype; - end; + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); - return; + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; end if; + end Insert; - if Capacity <= N then - - if N < Container.Elements'Length then - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Type renames - Container.Elements (Array_Index_Subtype); - - subtype Array_Subtype is - Elements_Type (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - begin - Container.Elements := new Array_Subtype'(Src); - Free (X); - end; - - end if; - - return; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; end if; - if Capacity = Container.Elements'Length then + if Is_Empty (New_Item) then return; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; - - Last : constant Index_Type := - Index_Type (Last_As_Int); - - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); - - X : Elements_Access := Container.Elements; - begin - Container.Elements := new Array_Subtype; - - declare - Src : Elements_Type renames - X (Index_Type'First .. Container.Last); - - Tgt : Elements_Type renames - Container.Elements (Index_Type'First .. Container.Last); - begin - Tgt := Src; - end; - - Free (X); - end; - - end Reserve_Capacity; - - - function First_Index (Container : Vector) return Index_Type is - pragma Warnings (Off, Container); - begin - return Index_Type'First; - end First_Index; - - - function First_Element (Container : Vector) return Element_Type is - begin - return Element (Container, Index_Type'First); - end First_Element; - - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - - function Last_Element (Container : Vector) return Element_Type is - begin - return Element (Container, Container.Last); - end Last_Element; - - - function Element (Container : Vector; - Index : Index_Type) - return Element_Type is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - return Container.Elements (T'(Index)).all; - end Element; - + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - procedure Replace_Element (Container : in Vector; - Index : in Index_Type; - By : in Element_Type) is + Insert (Container, Index, New_Item); + end Insert; - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; - X : Element_Access := Container.Elements (T'(Index)); begin - Container.Elements (T'(Index)) := new Element_Type'(By); - Free (X); - end Replace_Element; - - - procedure Generic_Sort (Container : in Vector) is - - function Is_Less (L, R : Element_Access) return Boolean; - pragma Inline (Is_Less); + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; - function Is_Less (L, R : Element_Access) return Boolean is - begin - if L = null then - return R /= null; - elsif R = null then - return False; + if Is_Empty (New_Item) then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; else - return L.all < R.all; + Position := (Container'Unchecked_Access, Before.Index); end if; - end Is_Less; - - procedure Sort is - new Generic_Array_Sort - (Index_Type, - Element_Access, - Elements_Type, - "<" => Is_Less); - begin - - if Container.Elements = null then return; end if; - Sort (Container.Elements (Index_Type'First .. Container.Last)); - - end Generic_Sort; - - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) - return Extended_Index is - - begin - - for I in Index .. Container.Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return I; - end if; - end loop; - - return No_Index; - - end Find_Index; - - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) - return Extended_Index is - - Last : Index_Type'Base; - - begin - - if Index > Container.Last then - Last := Container.Last; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); else - Last := Index; + Index := Before.Index; end if; - for I in reverse Index_Type'First .. Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return I; - end if; - end loop; - - return No_Index; + Insert (Container, Index, New_Item); - end Reverse_Find_Index; + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; - function Contains (Container : Vector; - Item : Element_Type) return Boolean is begin - return Find_Index (Container, Item) /= No_Index; - end Contains; + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + if Count = 0 then + return; + end if; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - procedure Assign - (Target : in out Vector; - Source : in Vector) is + Insert (Container, Index, New_Item, Count); + end Insert; - N : constant Count_Type := Length (Source); + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; begin - - if Target'Address = Source'Address then - return; + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; end if; - Clear (Target); + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; - if N = 0 then return; end if; - if N > Capacity (Target) then - Reserve_Capacity (Target, Capacity => N); + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; end if; - for I in Index_Type'First .. Source.Last loop - - declare - EA : constant Element_Access := Source.Elements (I); - begin - if EA /= null then - Target.Elements (I) := new Element_Type'(EA.all); - end if; - end; + Insert (Container, Index, New_Item, Count); - Target.Last := I; + Position := (Container'Unchecked_Access, Index); + end Insert; - end loop; + ------------------ + -- Insert_Space -- + ------------------ - end Assign; + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + N : constant Int := Int (Count); + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - procedure Move - (Target : in out Vector; - Source : in out Vector) is + Index : Extended_Index; -- TODO: see a-convec.adb. - X : Elements_Access := Target.Elements; + Dst_Last : Index_Type; + Dst : Elements_Access; begin - - if Target'Address = Source'Address then - return; + if Before < Index_Type'First then + raise Constraint_Error; end if; - if Target.Last >= Index_Type'First then + if Before > Container.Last + and then Before > Container.Last + 1 + then raise Constraint_Error; end if; - Target.Elements := null; - Free (X); -- shouldn't fail - - Target.Elements := Source.Elements; - Target.Last := Source.Last; - - Source.Elements := null; - Source.Last := Index_Type'Pred (Index_Type'First); - - end Move; - - - procedure Query_Element - (Container : in Vector; - Index : in Index_Type; - Process : not null access procedure (Element : in Element_Type)) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - Process (Container.Elements (T'(Index)).all); - end Query_Element; - - - procedure Update_Element - (Container : in Vector; - Index : in Index_Type; - Process : not null access procedure (Element : in out Element_Type)) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - Process (Container.Elements (T'(Index)).all); - end Update_Element; - - - procedure Prepend (Container : in out Vector; - New_Item : in Element_Type; - Count : in Count_Type := 1) is - begin - Insert (Container, - Index_Type'First, - New_Item, - Count); - end Prepend; - - - procedure Swap - (Container : in Vector; - I, J : in Index_Type) is - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - - EI : constant Element_Access := Container.Elements (T'(I)); - - begin - - Container.Elements (T'(I)) := Container.Elements (T'(J)); - Container.Elements (T'(J)) := EI; - - end Swap; + if Count = 0 then + return; + end if; + declare + Old_Last_As_Int : constant Int := Int (Container.Last); - function "&" (Left, Right : Vector) return Vector is + begin + New_Last_As_Int := Old_Last_As_Int + N; + New_Last := Index_Type (New_Last_As_Int); + end; - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + if Container.Busy > 0 then + raise Program_Error; + end if; - begin + declare + Old_First_As_Int : constant Int := Int (Before); - if LN = 0 then + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; - if RN = 0 then - return Empty_Vector; - end if; + begin + Index := Extended_Index (New_First_As_Int); -- TODO + end; + if Container.Elements = null then declare - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); - - Elements : Elements_Access := - new Elements_Type (RE'Range); + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. New_Last); begin - for I in Elements'Range loop - begin - if RE (I) /= null then - Elements (I) := new Element_Type'(RE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; - - return (Controlled with Elements, Right.Last); + Container.Elements := new Elements_Subtype; + Container.Last := New_Last; end; + return; end if; - if RN = 0 then - + if New_Last <= Container.Elements'Last then declare - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - Elements : Elements_Access := - new Elements_Type (LE'Range); + E : Elements_Type renames Container.Elements.all; begin - for I in Elements'Range loop - begin - if LE (I) /= null then - Elements (I) := new Element_Type'(LE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - end loop; + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index_Type'Pred (Index)) := (others => null); - return (Controlled with Elements, Left.Last); + Container.Last := New_Last; end; + return; end if; declare + First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (LN) + Int (RN) - 1; - - Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); + New_Size : constant Int'Base := + Int (New_Last_As_Int) - First + 1; - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + Max_Size : constant Int'Base := + Int (Index_Type'Last) - First + 1; - I : Index_Type'Base := Index_Type'Pred (Index_Type'First); + Size, Dst_Last_As_Int : Int'Base; begin + if New_Size >= Max_Size / 2 then + Dst_Last := Index_Type'Last; - for LI in LE'Range loop - - I := Index_Type'Succ (I); - - begin - if LE (LI) /= null then - Elements (I) := new Element_Type'(LE (LI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - - end loop; - - for RI in RE'Range loop - - I := Index_Type'Succ (I); - - begin - if RE (RI) /= null then - Elements (I) := new Element_Type'(RE (RI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; + else + Size := Container.Elements'Length; - Free (Elements); - raise; - end; + if Size = 0 then + Size := 1; + end if; - end loop; + while Size < New_Size loop + Size := 2 * Size; + end loop; - return (Controlled with Elements, Last); + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + end if; end; - end "&"; - - - function "&" (Left : Vector; - Right : Element_Type) return Vector is - - LN : constant Count_Type := Length (Left); - - begin - - if LN = 0 then - - declare - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Index_Type'First); - begin - - begin - Elements (Elements'First) := new Element_Type'(Right); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First); - - end; - - end if; + Dst := new Elements_Type (Index_Type'First .. Dst_Last); declare - - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (LN); - - Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); - - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); + Src : Elements_Type renames Container.Elements.all; begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); - for I in LE'Range loop - - begin - if LE (I) /= null then - Elements (I) := new Element_Type'(LE (I).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; - - Free (Elements); - raise; - end; - - end loop; - - begin - Elements (Elements'Last) := new Element_Type'(Right); - exception - when others => - - declare - subtype J_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Pred (Elements'Last); - begin - for J in J_Subtype loop - Free (Elements (J)); - end loop; - end; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last); + Dst (Index .. New_Last) := Src (Before .. Container.Last); end; - end "&"; - - - - function "&" (Left : Element_Type; - Right : Vector) return Vector is - - RN : constant Count_Type := Length (Right); - - begin - - if RN = 0 then - - declare - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Index_Type'First); - begin - - begin - Elements (Elements'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - return (Controlled with Elements, Index_Type'First); - - end; - - end if; - declare - - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (RN); - - Last : constant Index_Type := Index_Type (Last_As_Int); - - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); - - Elements : Elements_Access := - new Elements_Type (Index_Type'First .. Last); - - I : Index_Type'Base := Index_Type'First; - + X : Elements_Access := Container.Elements; begin + Container.Elements := Dst; + Container.Last := New_Last; - begin - Elements (I) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; + Free (X); + end; + end Insert_Space; - for RI in RE'Range loop + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; - I := Index_Type'Succ (I); + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; - begin - if RE (RI) /= null then - Elements (I) := new Element_Type'(RE (RI).all); - end if; - exception - when others => - for J in Index_Type'First .. Index_Type'Pred (I) loop - Free (Elements (J)); - end loop; + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; - Free (Elements); - raise; - end; + return; + end if; - end loop; + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; - return (Controlled with Elements, Last); - end; + Insert_Space (Container, Index, Count); - end "&"; + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert_Space; + -------------- + -- Is_Empty -- + -------------- - function "&" (Left, Right : Element_Type) return Vector is + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; - subtype IT is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Index_Type'First); + ------------- + -- Iterate -- + ------------- - Elements : Elements_Access := new Elements_Type (IT); + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : in Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; begin + B := B + 1; begin - Elements (Elements'First) := new Element_Type'(Left); - exception - when others => - Free (Elements); - raise; - end; - - begin - Elements (Elements'Last) := new Element_Type'(Right); + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; exception when others => - Free (Elements (Elements'First)); - Free (Elements); + B := B - 1; raise; end; - return (Controlled with Elements, Elements'Last); - - end "&"; + B := B - 1; + end Iterate; + ---------- + -- Last -- + ---------- - function To_Cursor (Container : Vector; - Index : Extended_Index) - return Cursor is + function Last (Container : Vector) return Cursor is begin - if Index not in Index_Type'First .. Container.Last then + if Is_Empty (Container) then return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Index); - end To_Cursor; + return (Container'Unchecked_Access, Container.Last); + end Last; + ------------------ + -- Last_Element -- + ------------------ - function To_Index (Position : Cursor) return Extended_Index is + function Last_Element (Container : Vector) return Element_Type is begin - if Position.Container = null then - return No_Index; - end if; + return Element (Container, Container.Last); + end Last_Element; - if Position.Index <= Position.Container.Last then - return Position.Index; - end if; + ---------------- + -- Last_Index -- + ---------------- - return No_Index; - end To_Index; + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + ------------ + -- Length -- + ------------ - function Element (Position : Cursor) return Element_Type is + function Length (Container : Vector) return Count_Type is + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; begin - return Element (Position.Container.all, Position.Index); - end Element; + return Count_Type (N); + end Length; + ---------- + -- Move -- + ---------- - function Next (Position : Cursor) return Cursor is + procedure Move + (Target : in out Vector; + Source : in out Vector) + is begin - - if Position.Container = null then - return No_Element; + if Target'Address = Source'Address then + return; end if; - if Position.Index < Position.Container.Last then - return (Position.Container, Index_Type'Succ (Position.Index)); + if Source.Busy > 0 then + raise Program_Error; end if; - return No_Element; + Clear (Target); - end Next; + declare + X : Elements_Access := Target.Elements; + begin + Target.Elements := null; + Free (X); + end; + Target.Elements := Source.Elements; + Target.Last := Source.Last; - function Previous (Position : Cursor) return Cursor is - begin + Source.Elements := null; + Source.Last := No_Index; + end Move; + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin if Position.Container = null then return No_Element; end if; - if Position.Index > Index_Type'First then - return (Position.Container, Index_Type'Pred (Position.Index)); + if Position.Index < Position.Container.Last then + return (Position.Container, Index_Type'Succ (Position.Index)); end if; return No_Element; + end Next; - end Previous; - + ---------- + -- Next -- + ---------- procedure Next (Position : in out Cursor) is begin - if Position.Container = null then return; end if; @@ -1615,13 +1689,35 @@ package body Ada.Containers.Indefinite_Vectors is else Position := No_Element; end if; - end Next; + ------------- + -- Prepend -- + ------------- - procedure Previous (Position : in out Cursor) is + procedure Prepend (Container : in out Vector; New_Item : Vector) is begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin if Position.Container = null then return; end if; @@ -1631,541 +1727,618 @@ package body Ada.Containers.Indefinite_Vectors is else Position := No_Element; end if; - end Previous; - - function Has_Element (Position : Cursor) return Boolean is + function Previous (Position : Cursor) return Cursor is begin - if Position.Container = null then - return False; + return No_Element; end if; - return Position.Index <= Position.Container.Last; - - end Has_Element; + if Position.Index > Index_Type'First then + return (Position.Container, Index_Type'Pred (Position.Index)); + end if; + return No_Element; + end Previous; - procedure Iterate - (Container : in Vector; - Process : not null access procedure (Position : in Cursor)) is - begin + ------------------- + -- Query_Element -- + ------------------- - for I in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, I)); - end loop; + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; - end Iterate; + E : Element_Type renames Container.Elements (T'(Index)).all; + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; - procedure Reverse_Iterate - (Container : in Vector; - Process : not null access procedure (Position : in Cursor)) is begin + B := B + 1; + L := L + 1; - for I in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, I)); - end loop; - - end Reverse_Iterate; + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + L := L - 1; + B := B - 1; + end Query_Element; procedure Query_Element - (Position : in Cursor; - Process : not null access procedure (Element : in Element_Type)) is - - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; - - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; + (Position : Cursor; + Process : not null access procedure (Element : in Element_Type)) + is begin - Process (E (T'(Position.Index)).all); + Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; + ---------- + -- Read -- + ---------- - procedure Update_Element - (Position : in Cursor; - Process : not null access procedure (Element : in out Element_Type)) is + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; + B : Boolean; - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; begin - Process (E (T'(Position.Index)).all); - end Update_Element; + Clear (Container); + Count_Type'Base'Read (Stream, Length); - procedure Replace_Element (Position : in Cursor; - By : in Element_Type) is + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; - C : Vector renames Position.Container.all; - E : Elements_Type renames C.Elements.all; + for J in Count_Type range 1 .. Length loop + Last := Index_Type'Succ (Last); - subtype T is Index_Type'Base range - Index_Type'First .. C.Last; + Boolean'Read (Stream, B); - X : Element_Access := E (T'(Position.Index)); - begin - E (T'(Position.Index)) := new Element_Type'(By); - Free (X); - end Replace_Element; + if B then + Container.Elements (Last) := + new Element_Type'(Element_Type'Input (Stream)); + end if; + Container.Last := Last; + end loop; + end Read; - procedure Insert (Container : in out Vector; - Before : in Extended_Index; - New_Item : in Vector) is + --------------------- + -- Replace_Element -- + --------------------- - N : constant Count_Type := Length (New_Item); + procedure Replace_Element + (Container : Vector; + Index : Index_Type; + By : Element_Type) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; - begin + X : Element_Access := Container.Elements (T'(Index)); - if N = 0 then - return; + begin + if Container.Lock > 0 then + raise Program_Error; end if; - Insert_Space (Container, Before, Count => N); - - if Container'Address = New_Item'Address then - - declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; + Container.Elements (T'(Index)) := new Element_Type'(By); + Free (X); + end Replace_Element; - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + procedure Replace_Element (Position : Cursor; By : Element_Type) is + begin + Replace_Element (Position.Container.all, Position.Index, By); + end Replace_Element; - Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + ---------------------- + -- Reserve_Capacity -- + ---------------------- - Dst : Elements_Type renames - Container.Elements (Before .. Dst_Last); - begin + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + N : constant Count_Type := Length (Container); + begin + if Capacity = 0 then + if N = 0 then declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Pred (Before); - - Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); + X : Elements_Access := Container.Elements; begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + Container.Elements := null; + Free (X); end; + elsif N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'Succ (Dst_Last) .. Container.Last; + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); - begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); + Container.Elements (Array_Index_Subtype); - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); end; - end; + end if; - else + return; + end if; + if Container.Elements = null then declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; - - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; - Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + Last : constant Index_Type := + Index_Type (Last_As_Int); - Src : Elements_Type renames - New_Item.Elements (Index_Type'First .. New_Item.Last); + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); - Dst : Elements_Type renames - Container.Elements (Before .. Dst_Last); begin - for Src_Index in Src'Range loop - Dst_Index := Index_Type'Succ (Dst_Index); - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; + Container.Elements := new Array_Subtype; end; + return; end if; - end Insert; + if Capacity <= N then + if N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Vector) is + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); - Index : Index_Type'Base; + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); - begin + X : Elements_Access := Container.Elements; - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + + end if; - if Is_Empty (New_Item) then return; end if; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; + if Capacity = Container.Elements'Length then + return; end if; - Insert (Container, Index, New_Item); - - end Insert; - - - - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Vector; - Position : out Cursor) is - - Index : Index_Type'Base; - - begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then + if Container.Busy > 0 then raise Program_Error; end if; - if Is_Empty (New_Item) then + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; + Last : constant Index_Type := Index_Type (Last_As_Int); - return; + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); - end if; + X : Elements_Access := Container.Elements; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + begin + Container.Elements := new Array_Subtype; - Insert (Container, Index, New_Item); + declare + Src : Elements_Type renames + X (Index_Type'First .. Container.Last); - Position := (Container'Unchecked_Access, Index); + Tgt : Elements_Type renames + Container.Elements (Index_Type'First .. Container.Last); - end Insert; + begin + Tgt := Src; + end; + Free (X); + end; + end Reserve_Capacity; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Element_Type; - Count : in Count_Type := 1) is + ------------------ + -- Reverse_Find -- + ------------------ - Index : Index_Type'Base; + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) then raise Program_Error; end if; - if Count = 0 then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last + if Position.Container = null + or else Position.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + Last := Container.Last; else - Index := Before.Index; + Last := Position.Index; end if; - Insert (Container, Index, New_Item, Count); - - end Insert; + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item + then + return (Container'Unchecked_Access, Indx); + end if; + end loop; + return No_Element; + end Reverse_Find; - procedure Insert (Container : in out Vector; - Before : in Cursor; - New_Item : in Element_Type; - Position : out Cursor; - Count : in Count_Type := 1) is + ------------------------ + -- Reverse_Find_Index -- + ------------------------ - Index : Index_Type'Base; + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; begin - - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Index > Container.Last then + Last := Container.Last; + else + Last := Index; end if; - if Count = 0 then - - if Before.Container = null - or else Before.Index > Container.Last + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) /= null + and then Container.Elements (Indx).all = Item then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); + return Indx; end if; + end loop; - return; - - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + return No_Index; + end Reverse_Find_Index; - Insert (Container, Index, New_Item, Count); + --------------------- + -- Reverse_Iterate -- + --------------------- - Position := (Container'Unchecked_Access, Index); + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : in Cursor)) + is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; - end Insert; + begin + B := B + 1; + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + B := B - 1; + end Reverse_Iterate; - procedure Prepend (Container : in out Vector; - New_Item : in Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; + ---------------- + -- Set_Length -- + ---------------- + procedure Set_Length + (Container : in out Vector; + Length : Count_Type) + is + N : constant Count_Type := Indefinite_Vectors.Length (Container); - procedure Append (Container : in out Vector; - New_Item : in Vector) is begin - if Is_Empty (New_Item) then + if Length = N then return; end if; - Insert - (Container, - Index_Type'Succ (Container.Last), - New_Item); - end Append; - - - - procedure Insert_Space (Container : in out Vector; - Before : in Cursor; - Position : out Cursor; - Count : in Count_Type := 1) is - - Index : Index_Type'Base; - - begin + if Length = 0 then + Clear (Container); + return; + end if; - if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) - then + if Container.Busy > 0 then raise Program_Error; end if; - if Count = 0 then + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Length) - 1; - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; + Last : constant Index_Type := + Index_Type (Last_As_Int); - return; + begin + if Length > N then + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; - end if; + Container.Last := Last; + return; + end if; - if Before.Container = null - or else Before.Index > Container.Last - then - Index := Index_Type'Succ (Container.Last); - else - Index := Before.Index; - end if; + for Indx in reverse Index_Type'Succ (Last) .. Container.Last loop + declare + X : Element_Access := Container.Elements (Indx); - Insert_Space (Container, Index, Count); + begin + Container.Elements (Indx) := null; + Container.Last := Index_Type'Pred (Container.Last); + Free (X); + end; + end loop; + end; + end Set_Length; - Position := (Container'Unchecked_Access, Index); + ---------- + -- Swap -- + ---------- - end Insert_Space; + procedure Swap + (Container : Vector; + I, J : Index_Type) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + EI : Element_Type renames Container.Elements (T'(I)).all; + EJ : Element_Type renames Container.Elements (T'(J)).all; - procedure Delete (Container : in out Vector; - Position : in out Cursor; - Count : in Count_Type := 1) is begin - - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then + if Container.Lock > 0 then raise Program_Error; end if; - if Position.Container = null - or else Position.Index > Container.Last + declare + EI_Copy : constant Element_Type := EI; + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + procedure Swap (I, J : Cursor) + is + begin + if I.Container = null + or else J.Container = null then - Position := No_Element; - return; + raise Constraint_Error; end if; - Delete (Container, Position.Index, Count); - - if Position.Index <= Container.Last then - Position := (Container'Unchecked_Access, Position.Index); - else - Position := No_Element; + if I.Container /= J.Container then + raise Program_Error; end if; - end Delete; + Swap (I.Container.all, I.Index, J.Index); + end Swap; + --------------- + -- To_Cursor -- + --------------- - function First (Container : Vector) return Cursor is + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is begin - if Is_Empty (Container) then + if Index not in Index_Type'First .. Container.Last then return No_Element; end if; - return (Container'Unchecked_Access, Index_Type'First); - end First; + return Cursor'(Container'Unchecked_Access, Index); + end To_Cursor; + -------------- + -- To_Index -- + -------------- - function Last (Container : Vector) return Cursor is + function To_Index (Position : Cursor) return Extended_Index is begin - if Is_Empty (Container) then - return No_Element; + if Position.Container = null then + return No_Index; end if; - return (Container'Unchecked_Access, Container.Last); - end Last; + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + return No_Index; + end To_Index; - procedure Swap (I, J : in Cursor) is + --------------- + -- To_Vector -- + --------------- - -- NOTE: I've liberalized the behavior here, to - -- allow I and J to designate different containers. - -- TODO: I think this is suppose to raise P_E. + function To_Vector (Length : Count_Type) return Vector is + begin + if Length = 0 then + return Empty_Vector; + end if; - subtype TI is Index_Type'Base range - Index_Type'First .. I.Container.Last; + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : constant Elements_Access := + new Elements_Type (Index_Type'First .. Last); + begin + return (Controlled with Elements, Last, 0, 0); + end; + end To_Vector; - EI : Element_Access renames - I.Container.Elements (TI'(I.Index)); + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; - EI_Copy : constant Element_Access := EI; + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + begin + for Indx in Elements'Range loop + begin + Elements (Indx) := new Element_Type'(New_Item); + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (Indx) loop + Free (Elements (J)); + end loop; - subtype TJ is Index_Type'Base range - Index_Type'First .. J.Container.Last; + Free (Elements); + raise; + end; - EJ : Element_Access renames - J.Container.Elements (TJ'(J.Index)); + end loop; - begin + return (Controlled with Elements, Last, 0, 0); + end; + end To_Vector; - EI := EJ; - EJ := EI_Copy; + -------------------- + -- Update_Element -- + -------------------- - end Swap; + procedure Update_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + E : Element_Type renames Container.Elements (T'(Index)).all; - function Find (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; begin + B := B + 1; + L := L + 1; - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; - - for I in Position.Index .. Container.Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return (Container'Unchecked_Access, I); - end if; - end loop; - - return No_Element; + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; - end Find; + L := L - 1; + B := B - 1; + end Update_Element; + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Update_Element (Position.Container.all, Position.Index, Process); + end Update_Element; - function Reverse_Find (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor is + ----------- + -- Write -- + ----------- - Last : Index_Type'Base; + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Vector) + is + N : constant Count_Type := Length (Container); begin + Count_Type'Base'Write (Stream, N); - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; - end if; - - if Position.Container = null - or else Position.Index > Container.Last - then - Last := Container.Last; - else - Last := Position.Index; + if N = 0 then + return; end if; - for I in reverse Index_Type'First .. Last loop - if Container.Elements (I) /= null - and then Container.Elements (I).all = Item - then - return (Container'Unchecked_Access, I); - end if; - end loop; + declare + E : Elements_Type renames Container.Elements.all; - return No_Element; + begin + for Indx in Index_Type'First .. Container.Last loop - end Reverse_Find; + -- There's another way to do this. Instead a separate + -- Boolean for each element, you could write a Boolean + -- followed by a count of how many nulls or non-nulls + -- follow in the array. Alternately you could use a + -- signed integer, and use the sign as the indicator + -- of null-ness. + if E (Indx) = null then + Boolean'Write (Stream, False); + else + Boolean'Write (Stream, True); + Element_Type'Output (Stream, E (Indx).all); + end if; + end loop; + end; + end Write; end Ada.Containers.Indefinite_Vectors; - diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 6aa79a4..964247e 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.INDEFINITE_VECTORS -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -204,7 +204,7 @@ pragma Preelaborate (Indefinite_Vectors); procedure Delete (Container : in out Vector; - Index : Extended_Index; -- TODO: verify + Index : Extended_Index; Count : Count_Type := 1); procedure Delete @@ -238,7 +238,15 @@ pragma Preelaborate (Indefinite_Vectors); generic with function "<" (Left, Right : Element_Type) return Boolean is <>; - procedure Generic_Sort (Container : Vector); + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target, Source : in out Vector); + + end Generic_Sorting; function Find_Index (Container : Vector; @@ -307,6 +315,8 @@ private type Vector is new Controlled with record Elements : Elements_Access; Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; end record; procedure Adjust (Container : in out Vector); @@ -327,7 +337,7 @@ private for Vector'Read use Read; - Empty_Vector : constant Vector := Vector'(Controlled with null, No_Index); + Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); type Vector_Access is access constant Vector; for Vector_Access'Storage_Size use 0; @@ -340,4 +350,3 @@ private No_Element : constant Cursor := Cursor'(null, Index_Type'First); end Ada.Containers.Indefinite_Vectors; - diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index c98c58a..77d1124 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.VECTORS -- +-- A D A . C O N T A I N E R S . V E C T O R S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -67,7 +67,7 @@ package body Ada.Containers.Vectors is new Elements_Type'(RE); begin - return (Controlled with Elements, Right.Last); + return (Controlled with Elements, Right.Last, 0, 0); end; end if; @@ -80,28 +80,35 @@ package body Ada.Containers.Vectors is new Elements_Type'(LE); begin - return (Controlled with Elements, Left.Last); + return (Controlled with Elements, Left.Last, 0, 0); end; end if; declare - Last_As_Int : constant Int'Base := + Last_As_Int : constant Int'Base := -- TODO: handle overflow Int (Index_Type'First) + Int (LN) + Int (RN) - 1; - Last : constant Index_Type := Index_Type (Last_As_Int); + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); + declare + Last : constant Index_Type := Index_Type (Last_As_Int); - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := new Elements_Type'(LE & RE); - begin - return (Controlled with Elements, Last); + begin + return (Controlled with Elements, Last, 0, 0); + end; end; end "&"; @@ -118,25 +125,32 @@ package body Ada.Containers.Vectors is new Elements_Subtype'(others => Right); begin - return (Controlled with Elements, Index_Type'First); + return (Controlled with Elements, Index_Type'First, 0, 0); end; end if; declare - Last_As_Int : constant Int'Base := + Last_As_Int : constant Int'Base := -- TODO: handle overflow Int (Index_Type'First) + Int (LN); - Last : constant Index_Type := Index_Type (Last_As_Int); + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - LE : Elements_Type renames - Left.Elements (Index_Type'First .. Left.Last); + declare + Last : constant Index_Type := Index_Type (Last_As_Int); - subtype ET is Elements_Type (Index_Type'First .. Last); + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := new ET'(LE & Right); + subtype ET is Elements_Type (Index_Type'First .. Last); - begin - return (Controlled with Elements, Last); + Elements : constant Elements_Access := new ET'(LE & Right); + + begin + return (Controlled with Elements, Last, 0, 0); + end; end; end "&"; @@ -153,38 +167,51 @@ package body Ada.Containers.Vectors is new Elements_Subtype'(others => Left); begin - return (Controlled with Elements, Index_Type'First); + return (Controlled with Elements, Index_Type'First, 0, 0); end; end if; declare - Last_As_Int : constant Int'Base := + Last_As_Int : constant Int'Base := -- TODO: handle overflow Int (Index_Type'First) + Int (RN); - Last : constant Index_Type := Index_Type (Last_As_Int); + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - RE : Elements_Type renames - Right.Elements (Index_Type'First .. Right.Last); + declare + Last : constant Index_Type := Index_Type (Last_As_Int); - subtype ET is Elements_Type (Index_Type'First .. Last); + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); - Elements : constant Elements_Access := new ET'(Left & RE); + subtype ET is Elements_Type (Index_Type'First .. Last); - begin - return (Controlled with Elements, Last); + Elements : constant Elements_Access := new ET'(Left & RE); + + begin + return (Controlled with Elements, Last, 0, 0); + end; end; end "&"; function "&" (Left, Right : Element_Type) return Vector is - subtype IT is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Index_Type'First); + begin + if Index_Type'First >= Index_Type'Last then + raise Constraint_Error; + end if; - subtype ET is Elements_Type (IT); + declare + Last : constant Index_Type := Index_Type'First + 1; - Elements : constant Elements_Access := new ET'(Left, Right); + subtype ET is Elements_Type (Index_Type'First .. Last); - begin - return Vector'(Controlled with Elements, Elements'Last); + Elements : constant Elements_Access := new ET'(Left, Right); + + begin + return (Controlled with Elements, Last, 0, 0); + end; end "&"; --------- @@ -216,25 +243,21 @@ package body Ada.Containers.Vectors is procedure Adjust (Container : in out Vector) is begin - if Container.Elements = null then - return; - end if; - - if Container.Elements'Length = 0 - or else Container.Last < Index_Type'First - then + if Container.Last = No_Index then Container.Elements := null; return; end if; declare - X : constant Elements_Access := Container.Elements; - L : constant Index_Type'Base := Container.Last; - E : Elements_Type renames X (Index_Type'First .. L); + E : constant Elements_Access := Container.Elements; + L : constant Index_Type := Container.Last; + begin Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); - Container.Elements := new Elements_Type'(E); + Container.Last := No_Index; + Container.Busy := 0; + Container.Lock := 0; + Container.Elements := new Elements_Type'(E (Index_Type'First .. L)); Container.Last := L; end; end Adjust; @@ -249,9 +272,13 @@ package body Ada.Containers.Vectors is return; end if; + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + Insert (Container, - Index_Type'Succ (Container.Last), + Container.Last + 1, New_Item); end Append; @@ -265,9 +292,13 @@ package body Ada.Containers.Vectors is return; end if; + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + Insert (Container, - Index_Type'Succ (Container.Last), + Container.Last + 1, New_Item, Count); end Append; @@ -322,7 +353,11 @@ package body Ada.Containers.Vectors is procedure Clear (Container : in out Vector) is begin - Container.Last := Index_Type'Pred (Index_Type'First); + if Container.Busy > 0 then + raise Program_Error; + end if; + + Container.Last := No_Index; end Clear; -------------- @@ -347,39 +382,54 @@ package body Ada.Containers.Vectors is Count : Count_Type := 1) is begin - if Count = 0 then - return; + if Index < Index_Type'First then + raise Constraint_Error; end if; - declare - subtype I_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + if Index > Container.Last then + if Index > Container.Last + 1 then + raise Constraint_Error; + end if; - I : constant I_Subtype := Index; - -- TODO: not sure whether to relax this check ??? + return; + end if; - I_As_Int : constant Int := Int (I); + if Count = 0 then + return; + end if; + if Container.Busy > 0 then + raise Program_Error; + end if; + + declare + I_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); Count1 : constant Int'Base := Count_Type'Pos (Count); Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - - N : constant Int'Base := Int'Min (Count1, Count2); + N : constant Int'Base := Int'Min (Count1, Count2); J_As_Int : constant Int'Base := I_As_Int + N; - J : constant Index_Type'Base := Index_Type'Base (J_As_Int); - E : Elements_Type renames Container.Elements.all; + begin + if J_As_Int > Old_Last_As_Int then + Container.Last := Index - 1; - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + else + declare + J : constant Index_Type := Index_Type (J_As_Int); + E : Elements_Type renames Container.Elements.all; - New_Last : constant Extended_Index := - Extended_Index (New_Last_As_Int); + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + New_Last : constant Index_Type := + Index_Type (New_Last_As_Int); - begin - E (I .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; + begin + E (Index .. New_Last) := E (J .. Container.Last); + Container.Last := New_Last; + end; + end if; end; end Delete; @@ -389,19 +439,15 @@ package body Ada.Containers.Vectors is Count : Count_Type := 1) is begin - - if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) - then - raise Program_Error; + if Position.Container = null then + raise Constraint_Error; end if; - if Position.Container = null + if Position.Container /= + Vector_Access'(Container'Unchecked_Access) or else Position.Index > Container.Last then - Position := No_Element; - return; + raise Program_Error; end if; Delete (Container, Position.Index, Count); @@ -449,14 +495,17 @@ package body Ada.Containers.Vectors is return; end if; - if Count >= Length (Container) then - Clear (Container); - return; + if Container.Busy > 0 then + raise Program_Error; end if; - Index := Int'Base (Container.Last) - Int'Base (Count) + 1; + Index := Int'Base (Container.Last) - Int'Base (Count); - Delete (Container, Index_Type'Base (Index), Count); + if Index < Index_Type'Pos (Index_Type'First) then + Container.Last := No_Index; + else + Container.Last := Index_Type (Index); + end if; end Delete_Last; ------------- @@ -467,14 +516,20 @@ package body Ada.Containers.Vectors is (Container : Vector; Index : Index_Type) return Element_Type is - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; begin - return Container.Elements (T'(Index)); + if Index > Container.Last then + raise Constraint_Error; + end if; + + return Container.Elements (Index); end Element; function Element (Position : Cursor) return Element_Type is begin + if Position.Container = null then + raise Constraint_Error; + end if; + return Element (Position.Container.all, Position.Index); end Element; @@ -485,8 +540,12 @@ package body Ada.Containers.Vectors is procedure Finalize (Container : in out Vector) is X : Elements_Access := Container.Elements; begin + if Container.Busy > 0 then + raise Program_Error; + end if; + Container.Elements := null; - Container.Last := Index_Type'Pred (Index_Type'First); + Container.Last := No_Index; Free (X); end Finalize; @@ -501,8 +560,9 @@ package body Ada.Containers.Vectors is begin if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) + and then (Position.Container /= + Vector_Access'(Container'Unchecked_Access) + or else Position.Index > Container.Last) then raise Program_Error; end if; @@ -566,26 +626,112 @@ package body Ada.Containers.Vectors is return Index_Type'First; end First_Index; - ------------------ - -- Generic_Sort -- - ------------------ + --------------------- + -- Generic_Sorting -- + --------------------- - procedure Generic_Sort (Container : Vector) - is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Index_Type, - Element_Type => Element_Type, - Array_Type => Elements_Type, - "<" => "<"); + package body Generic_Sorting is - begin - if Container.Elements = null then - return; - end if; + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; + + declare + E : Elements_Type renames Container.Elements.all; + begin + for I in Index_Type'First .. Container.Last - 1 loop + if E (I + 1) < E (I) then + return False; + end if; + end loop; + end; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- - Sort (Container.Elements (Index_Type'First .. Container.Last)); - end Generic_Sort; + procedure Merge (Target, Source : in out Vector) is + I : Index_Type'Base := Target.Last; + J : Index_Type'Base; + + begin + if Target.Last < Index_Type'First then + Move (Target => Target, Source => Source); + return; + end if; + + if Target'Address = Source'Address then + return; + end if; + + if Source.Last < Index_Type'First then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error; + end if; + + Target.Set_Length (Length (Target) + Length (Source)); + + J := Target.Last; + while Source.Last >= Index_Type'First loop + if I < Index_Type'First then + Target.Elements (Index_Type'First .. J) := + Source.Elements (Index_Type'First .. Source.Last); + + Source.Last := No_Index; + return; + end if; + + if Source.Elements (Source.Last) < Target.Elements (I) then + Target.Elements (J) := Target.Elements (I); + I := I - 1; + + else + Target.Elements (J) := Source.Elements (Source.Last); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Type, + Array_Type => Elements_Type, + "<" => "<"); + + begin + if Container.Last <= Index_Type'First then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error; + end if; + + Sort (Container.Elements (Index_Type'First .. Container.Last)); + end Sort; + + end Generic_Sorting; ----------------- -- Has_Element -- @@ -610,40 +756,47 @@ package body Ada.Containers.Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - Old_Last : constant Extended_Index := Container.Last; - - Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); - N : constant Int := Count_Type'Pos (Count); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + Dst : Elements_Access; - Index : Index_Type; + begin + if Before < Index_Type'First then + raise Constraint_Error; + end if; - Dst_Last : Index_Type; - Dst : Elements_Access; + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; + end if; - begin if Count = 0 then return; end if; declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Old_Last : constant Extended_Index := Container.Last; - Old_First : constant Before_Subtype := Before; + Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); - Old_First_As_Int : constant Int := Index_Type'Pos (Old_First); + begin + New_Last_As_Int := Old_Last_As_Int + N; - New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - begin - Index := Index_Type (New_First_As_Int); + New_Last := Index_Type (New_Last_As_Int); end; + if Container.Busy > 0 then + raise Program_Error; + end if; + if Container.Elements = null then declare subtype Elements_Subtype is @@ -660,8 +813,23 @@ package body Ada.Containers.Vectors is declare E : Elements_Type renames Container.Elements.all; begin - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index_Type'Pred (Index)) := (others => New_Item); + if Before <= Container.Last then + declare + Index_As_Int : constant Int'Base := + Index_Type'Pos (Before) + N; + + Index : constant Index_Type := Index_Type (Index_As_Int); + + begin + E (Index .. New_Last) := E (Before .. Container.Last); + + E (Before .. Index_Type'Pred (Index)) := + (others => New_Item); + end; + + else + E (Before .. New_Last) := (others => New_Item); + end if; end; Container.Last := New_Last; @@ -669,35 +837,40 @@ package body Ada.Containers.Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - + First : constant Int := Int (Index_Type'First); New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - - Size, Dst_Last_As_Int : Int'Base; + Size : Int'Base := Int'Max (1, Container.Elements'Length); begin - if New_Size >= Max_Size / 2 then - Dst_Last := Index_Type'Last; + while Size < New_Size loop + if Size > Int'Last / 2 then + Size := Int'Last; + exit; + end if; - else - Size := Container.Elements'Length; + Size := 2 * Size; + end loop; - if Size = 0 then - Size := 1; - end if; + -- TODO: The following calculations aren't quite right, since + -- there will be overflow if Index_Type'Range is very large + -- (e.g. this package is instantiated with a 64-bit integer). + -- END TODO. - while Size < New_Size loop - Size := 2 * Size; - end loop; + declare + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; + begin + if Size > Max_Size then + Size := Max_Size; + end if; + end; - Dst_Last_As_Int := First + Size - 1; - Dst_Last := Index_Type (Dst_Last_As_Int); - end if; + declare + Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + begin + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + end; end; - Dst := new Elements_Type (Index_Type'First .. Dst_Last); - declare Src : Elements_Type renames Container.Elements.all; @@ -705,12 +878,21 @@ package body Ada.Containers.Vectors is Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); - Dst (Before .. Index_Type'Pred (Index)) := - (others => New_Item); + if Before <= Container.Last then + declare + Index_As_Int : constant Int'Base := + Index_Type'Pos (Before) + N; - Dst (Index .. New_Last) := - Src (Before .. Container.Last); + Index : constant Index_Type := Index_Type (Index_As_Int); + begin + Dst (Before .. Index_Type'Pred (Index)) := (others => New_Item); + Dst (Index .. New_Last) := Src (Before .. Container.Last); + end; + + else + Dst (Before .. New_Last) := (others => New_Item); + end if; exception when others => Free (Dst); @@ -734,6 +916,16 @@ package body Ada.Containers.Vectors is N : constant Count_Type := Length (New_Item); begin + if Before < Index_Type'First then + raise Constraint_Error; + end if; + + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; + end if; + if N = 0 then return; end if; @@ -747,51 +939,56 @@ package body Ada.Containers.Vectors is Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); begin - if Container'Address = New_Item'Address then - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Pred (Before); + if Container'Address /= New_Item'Address then + Container.Elements (Before .. Dst_Last) := + New_Item.Elements (Index_Type'First .. New_Item.Last); - Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); + return; + end if; - Index_As_Int : constant Int'Base := - Int (Before) + Src'Length - 1; + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Before - 1; - Index : constant Index_Type'Base := - Index_Type'Base (Index_As_Int); + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); - Dst : Elements_Type renames - Container.Elements (Before .. Index); + Index_As_Int : constant Int'Base := + Int (Before) + Src'Length - 1; - begin - Dst := Src; - end; + Index : constant Index_Type'Base := + Index_Type'Base (Index_As_Int); - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'Succ (Dst_Last) .. Container.Last; + Dst : Elements_Type renames + Container.Elements (Before .. Index); - Src : Elements_Type renames - Container.Elements (Src_Index_Subtype); + begin + Dst := Src; + end; - Index_As_Int : constant Int'Base := - Dst_Last_As_Int - Src'Length + 1; + if Dst_Last = Container.Last then + return; + end if; - Index : constant Index_Type'Base := - Index_Type'Base (Index_As_Int); + declare + subtype Src_Index_Subtype is Index_Type'Base range + Dst_Last + 1 .. Container.Last; - Dst : Elements_Type renames - Container.Elements (Index .. Dst_Last); + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); - begin - Dst := Src; - end; + Index_As_Int : constant Int'Base := + Dst_Last_As_Int - Src'Length + 1; - else - Container.Elements (Before .. Dst_Last) := - New_Item.Elements (Index_Type'First .. New_Item.Last); - end if; + Index : constant Index_Type := + Index_Type (Index_As_Int); + + Dst : Elements_Type renames + Container.Elements (Index .. Dst_Last); + + begin + Dst := Src; + end; end; end Insert; @@ -816,7 +1013,12 @@ package body Ada.Containers.Vectors is if Before.Container = null or else Before.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + + Index := Container.Last + 1; + else Index := Before.Index; end if; @@ -854,7 +1056,12 @@ package body Ada.Containers.Vectors is if Before.Container = null or else Before.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + + Index := Container.Last + 1; + else Index := Before.Index; end if; @@ -886,7 +1093,12 @@ package body Ada.Containers.Vectors is if Before.Container = null or else Before.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + + Index := Container.Last + 1; + else Index := Before.Index; end if; @@ -925,7 +1137,12 @@ package body Ada.Containers.Vectors is if Before.Container = null or else Before.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + + Index := Container.Last + 1; + else Index := Before.Index; end if; @@ -944,40 +1161,47 @@ package body Ada.Containers.Vectors is Before : Extended_Index; Count : Count_Type := 1) is - Old_Last : constant Extended_Index := Container.Last; - - Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); - N : constant Int := Count_Type'Pos (Count); - New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + New_Last_As_Int : Int'Base; + New_Last : Index_Type; - New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + Dst : Elements_Access; - Index : Index_Type; + begin + if Before < Index_Type'First then + raise Constraint_Error; + end if; - Dst_Last : Index_Type; - Dst : Elements_Access; + if Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error; + end if; - begin if Count = 0 then return; end if; declare - subtype Before_Subtype is Index_Type'Base range - Index_Type'First .. Index_Type'Succ (Container.Last); + Old_Last : constant Extended_Index := Container.Last; - Old_First : constant Before_Subtype := Before; + Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); - Old_First_As_Int : constant Int := Index_Type'Pos (Old_First); + begin + New_Last_As_Int := Old_Last_As_Int + N; - New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + if New_Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - begin - Index := Index_Type (New_First_As_Int); + New_Last := Index_Type (New_Last_As_Int); end; + if Container.Busy > 0 then + raise Program_Error; + end if; + if Container.Elements = null then Container.Elements := new Elements_Type (Index_Type'First .. New_Last); @@ -990,7 +1214,17 @@ package body Ada.Containers.Vectors is declare E : Elements_Type renames Container.Elements.all; begin - E (Index .. New_Last) := E (Before .. Container.Last); + if Before <= Container.Last then + declare + Index_As_Int : constant Int'Base := + Index_Type'Pos (Before) + N; + + Index : constant Index_Type := Index_Type (Index_As_Int); + + begin + E (Index .. New_Last) := E (Before .. Container.Last); + end; + end if; end; Container.Last := New_Last; @@ -998,35 +1232,40 @@ package body Ada.Containers.Vectors is end if; declare - First : constant Int := Int (Index_Type'First); - + First : constant Int := Int (Index_Type'First); New_Size : constant Int'Base := New_Last_As_Int - First + 1; - Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; - - Size, Dst_Last_As_Int : Int'Base; + Size : Int'Base := Int'Max (1, Container.Elements'Length); begin - if New_Size >= Max_Size / 2 then - Dst_Last := Index_Type'Last; + while Size < New_Size loop + if Size > Int'Last / 2 then + Size := Int'Last; + exit; + end if; - else - Size := Container.Elements'Length; + Size := 2 * Size; + end loop; - if Size = 0 then - Size := 1; - end if; + -- TODO: The following calculations aren't quite right, since + -- there will be overflow if Index_Type'Range is very large + -- (e.g. this package is instantiated with a 64-bit integer). + -- END TODO. - while Size < New_Size loop - Size := 2 * Size; - end loop; + declare + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; + begin + if Size > Max_Size then + Size := Max_Size; + end if; + end; - Dst_Last_As_Int := First + Size - 1; - Dst_Last := Index_Type (Dst_Last_As_Int); - end if; + declare + Dst_Last : constant Index_Type := Index_Type (First + Size - 1); + begin + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + end; end; - Dst := new Elements_Type (Index_Type'First .. Dst_Last); - declare Src : Elements_Type renames Container.Elements.all; @@ -1034,9 +1273,17 @@ package body Ada.Containers.Vectors is Dst (Index_Type'First .. Index_Type'Pred (Before)) := Src (Index_Type'First .. Index_Type'Pred (Before)); - Dst (Index .. New_Last) := - Src (Before .. Container.Last); + if Before <= Container.Last then + declare + Index_As_Int : constant Int'Base := + Index_Type'Pos (Before) + N; + Index : constant Index_Type := Index_Type (Index_As_Int); + + begin + Dst (Index .. New_Last) := Src (Before .. Container.Last); + end; + end if; exception when others => Free (Dst); @@ -1048,7 +1295,6 @@ package body Ada.Containers.Vectors is begin Container.Elements := Dst; Container.Last := New_Last; - Free (X); end; end Insert_Space; @@ -1083,7 +1329,12 @@ package body Ada.Containers.Vectors is if Before.Container = null or else Before.Index > Container.Last then - Index := Index_Type'Succ (Container.Last); + if Container.Last = Index_Type'Last then + raise Constraint_Error; + end if; + + Index := Container.Last + 1; + else Index := Before.Index; end if; @@ -1110,10 +1361,25 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); - end loop; + + B := B + 1; + + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Iterate; ---------- @@ -1155,7 +1421,12 @@ package body Ada.Containers.Vectors is L : constant Int := Int (Container.Last); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; + begin + if N > Count_Type'Pos (Count_Type'Last) then + raise Constraint_Error; + end if; + return Count_Type (N); end Length; @@ -1167,25 +1438,28 @@ package body Ada.Containers.Vectors is (Target : in out Vector; Source : in out Vector) is - X : Elements_Access := Target.Elements; - begin if Target'Address = Source'Address then return; end if; - if Target.Last >= Index_Type'First then - raise Constraint_Error; + if Target.Busy > 0 then + raise Program_Error; end if; - Target.Elements := null; - Free (X); + if Source.Busy > 0 then + raise Program_Error; + end if; - Target.Elements := Source.Elements; - Target.Last := Source.Last; + declare + Target_Elements : constant Elements_Access := Target.Elements; + begin + Target.Elements := Source.Elements; + Source.Elements := Target_Elements; + end; - Source.Elements := null; - Source.Last := Index_Type'Pred (Index_Type'First); + Target.Last := Source.Last; + Source.Last := No_Index; end Move; ---------- @@ -1199,7 +1473,7 @@ package body Ada.Containers.Vectors is end if; if Position.Index < Position.Container.Last then - return (Position.Container, Index_Type'Succ (Position.Index)); + return (Position.Container, Position.Index + 1); end if; return No_Element; @@ -1216,7 +1490,7 @@ package body Ada.Containers.Vectors is end if; if Position.Index < Position.Container.Last then - Position.Index := Index_Type'Succ (Position.Index); + Position.Index := Position.Index + 1; else Position := No_Element; end if; @@ -1254,7 +1528,7 @@ package body Ada.Containers.Vectors is end if; if Position.Index > Index_Type'First then - Position.Index := Index_Type'Pred (Position.Index); + Position.Index := Position.Index - 1; else Position := No_Element; end if; @@ -1267,7 +1541,7 @@ package body Ada.Containers.Vectors is end if; if Position.Index > Index_Type'First then - return (Position.Container, Index_Type'Pred (Position.Index)); + return (Position.Container, Position.Index - 1); end if; return No_Element; @@ -1282,23 +1556,41 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : Element_Type)) is - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + begin - Process (Container.Elements (T'(Index))); + if Index > Container.Last then + raise Constraint_Error; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements (Index)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - Container : Vector renames Position.Container.all; - - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; - begin - Process (Container.Elements (T'(Position.Index))); + if Position.Container = null then + raise Constraint_Error; + end if; + + Query_Element (Position.Container.all, Position.Index, Process); end Query_Element; ---------- @@ -1310,7 +1602,7 @@ package body Ada.Containers.Vectors is Container : out Vector) is Length : Count_Type'Base; - Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + Last : Index_Type'Base := No_Index; begin Clear (Container); @@ -1322,7 +1614,7 @@ package body Ada.Containers.Vectors is end if; for J in Count_Type range 1 .. Length loop - Last := Index_Type'Succ (Last); + Last := Last + 1; Element_Type'Read (Stream, Container.Elements (Last)); Container.Last := Last; end loop; @@ -1337,17 +1629,25 @@ package body Ada.Containers.Vectors is Index : Index_Type; By : Element_Type) is - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; begin - Container.Elements (T'(Index)) := By; + if Index > Container.Last then + raise Constraint_Error; + end if; + + if Container.Lock > 0 then + raise Program_Error; + end if; + + Container.Elements (Index) := By; end Replace_Element; procedure Replace_Element (Position : Cursor; By : Element_Type) is - subtype T is Index_Type'Base range - Index_Type'First .. Position.Container.Last; begin - Position.Container.Elements (T'(Position.Index)) := By; + if Position.Container = null then + raise Constraint_Error; + end if; + + Replace_Element (Position.Container.all, Position.Index, By); end Replace_Element; ---------------------- @@ -1371,6 +1671,10 @@ package body Ada.Containers.Vectors is end; elsif N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare subtype Array_Index_Subtype is Index_Type'Base range Index_Type'First .. Container.Last; @@ -1397,13 +1701,19 @@ package body Ada.Containers.Vectors is Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Capacity) - 1; - Last : constant Index_Type := Index_Type (Last_As_Int); + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); + declare + Last : constant Index_Type := Index_Type (Last_As_Int); - begin - Container.Elements := new Array_Subtype; + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); + begin + Container.Elements := new Array_Subtype; + end; end; return; @@ -1411,6 +1721,10 @@ package body Ada.Containers.Vectors is if Capacity <= N then if N < Container.Elements'Length then + if Container.Busy > 0 then + raise Program_Error; + end if; + declare subtype Array_Index_Subtype is Index_Type'Base range Index_Type'First .. Container.Last; @@ -1437,39 +1751,50 @@ package body Ada.Containers.Vectors is return; end if; + if Container.Busy > 0 then + raise Program_Error; + end if; + declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Capacity) - 1; - Last : constant Index_Type := Index_Type (Last_As_Int); - - subtype Array_Subtype is - Elements_Type (Index_Type'First .. Last); - - E : Elements_Access := new Array_Subtype; - begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; + declare - Src : Elements_Type renames - Container.Elements (Index_Type'First .. Container.Last); + Last : constant Index_Type := Index_Type (Last_As_Int); + + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); - Tgt : Elements_Type renames - E (Index_Type'First .. Container.Last); + E : Elements_Access := new Array_Subtype; begin - Tgt := Src; + declare + Src : Elements_Type renames + Container.Elements (Index_Type'First .. Container.Last); - exception - when others => - Free (E); - raise; - end; + Tgt : Elements_Type renames + E (Index_Type'First .. Container.Last); - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := E; - Free (X); + begin + Tgt := Src; + + exception + when others => + Free (E); + raise; + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := E; + Free (X); + end; end; end; end Reserve_Capacity; @@ -1545,10 +1870,25 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); - end loop; + + B := B + 1; + + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; ---------------- @@ -1557,23 +1897,23 @@ package body Ada.Containers.Vectors is procedure Set_Length (Container : in out Vector; Length : Count_Type) is begin - if Length = 0 then - Clear (Container); + if Length = Vectors.Length (Container) then return; end if; + if Container.Busy > 0 then + raise Program_Error; + end if; + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + declare Last_As_Int : constant Int'Base := Int (Index_Type'First) + Int (Length) - 1; - - Last : constant Index_Type := Index_Type (Last_As_Int); - begin - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - Container.Last := Last; + Container.Last := Index_Type'Base (Last_As_Int); end; end Set_Length; @@ -1581,44 +1921,47 @@ package body Ada.Containers.Vectors is -- Swap -- ---------- - procedure Swap - (Container : Vector; - I, J : Index_Type) - is + procedure Swap (Container : Vector; I, J : Index_Type) is + begin + if I > Container.Last + or else J > Container.Last + then + raise Constraint_Error; + end if; - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; + if I = J then + return; + end if; - EI : constant Element_Type := Container.Elements (T'(I)); + if Container.Lock > 0 then + raise Program_Error; + end if; - begin + declare + EI : Element_Type renames Container.Elements (I); + EJ : Element_Type renames Container.Elements (J); - Container.Elements (T'(I)) := Container.Elements (T'(J)); - Container.Elements (T'(J)) := EI; + EI_Copy : constant Element_Type := EI; + begin + EI := EJ; + EJ := EI_Copy; + end; end Swap; procedure Swap (I, J : Cursor) is + begin + if I.Container = null + or else J.Container = null + then + raise Constraint_Error; + end if; - -- NOTE: The behavior has been liberalized here to - -- allow I and J to designate different containers. - -- TODO: Probably this is supposed to raise P_E ??? - - subtype TI is Index_Type'Base range - Index_Type'First .. I.Container.Last; - - EI : Element_Type renames I.Container.Elements (TI'(I.Index)); - - EI_Copy : constant Element_Type := EI; - - subtype TJ is Index_Type'Base range - Index_Type'First .. J.Container.Last; - - EJ : Element_Type renames J.Container.Elements (TJ'(J.Index)); + if I.Container /= J.Container then + raise Program_Error; + end if; - begin - EI := EJ; - EJ := EI_Copy; + Swap (I.Container.all, I.Index, J.Index); end Swap; --------------- @@ -1667,11 +2010,18 @@ package body Ada.Containers.Vectors is declare First : constant Int := Int (Index_Type'First); Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : constant Index_Type := Index_Type (Last_As_Int); - Elements : constant Elements_Access := - new Elements_Type (Index_Type'First .. Last); + Last : Index_Type; + Elements : Elements_Access; + begin - return (Controlled with Elements, Last); + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; + + Last := Index_Type (Last_As_Int); + Elements := new Elements_Type (Index_Type'First .. Last); + + return (Controlled with Elements, Last, 0, 0); end; end To_Vector; @@ -1687,12 +2037,18 @@ package body Ada.Containers.Vectors is declare First : constant Int := Int (Index_Type'First); Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : constant Index_Type := Index_Type (Last_As_Int); - Elements : constant Elements_Access := - new Elements_Type' - (Index_Type'First .. Last => New_Item); + Last : Index_Type; + Elements : Elements_Access; + begin - return (Controlled with Elements, Last); + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error; + end if; + + Last := Index_Type (Last_As_Int); + Elements := new Elements_Type'(Index_Type'First .. Last => New_Item); + + return (Controlled with Elements, Last, 0, 0); end; end To_Vector; @@ -1705,20 +2061,41 @@ package body Ada.Containers.Vectors is Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - subtype T is Index_Type'Base range - Index_Type'First .. Container.Last; + V : Vector renames Container'Unrestricted_Access.all; + B : Natural renames V.Busy; + L : Natural renames V.Lock; + begin - Process (Container.Elements (T'(Index))); + if Index > Container.Last then + raise Constraint_Error; + end if; + + B := B + 1; + L := L + 1; + + begin + Process (V.Elements (Index)); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; procedure Update_Element (Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is - subtype T is Index_Type'Base range - Index_Type'First .. Position.Container.Last; begin - Process (Position.Container.Elements (T'(Position.Index))); + if Position.Container = null then + raise Constraint_Error; + end if; + + Update_Element (Position.Container.all, Position.Index, Process); end Update_Element; ----------- @@ -1738,4 +2115,3 @@ package body Ada.Containers.Vectors is end Write; end Ada.Containers.Vectors; - diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index ef877c0..638c8dd 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.VECTORS -- +-- A D A . C O N T A I N E R S . V E C T O R S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -200,7 +200,7 @@ pragma Preelaborate (Vectors); procedure Delete (Container : in out Vector; - Index : Extended_Index; -- TODO: verify + Index : Extended_Index; Count : Count_Type := 1); procedure Delete @@ -234,7 +234,15 @@ pragma Preelaborate (Vectors); generic with function "<" (Left, Right : Element_Type) return Boolean is <>; - procedure Generic_Sort (Container : Vector); + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target, Source : in out Vector); + + end Generic_Sorting; function Find_Index (Container : Vector; @@ -301,6 +309,8 @@ private type Vector is new Controlled with record Elements : Elements_Access; Last : Extended_Index := No_Index; + Busy : Natural := 0; + Lock : Natural := 0; end record; procedure Adjust (Container : in out Vector); @@ -321,7 +331,7 @@ private for Vector'Read use Read; - Empty_Vector : constant Vector := (Controlled with null, No_Index); + Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); type Vector_Access is access constant Vector; for Vector_Access'Storage_Size use 0; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index 2a706ab..8b2af9c1 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_MAPS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -41,21 +41,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); with Ada.Containers.Red_Black_Trees.Generic_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); -with System; use type System.Address; - package body Ada.Containers.Ordered_Maps is - use Red_Black_Trees; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Key : Key_Type; - Element : Element_Type; - end record; - ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -94,10 +81,6 @@ package body Ada.Containers.Ordered_Maps is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; pragma Inline (Is_Equal_Node_Node); @@ -118,9 +101,13 @@ package body Ada.Containers.Ordered_Maps is procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); use Tree_Operations; @@ -159,10 +146,6 @@ package body Ada.Containers.Ordered_Maps is function "=" (Left, Right : Map) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; @@ -189,24 +172,12 @@ package body Ada.Containers.Ordered_Maps is -- Adjust -- ------------ - procedure Adjust (Container : in out Map) is - Tree : Tree_Type renames Container.Tree; - - N : constant Count_Type := Tree.Length; - X : constant Node_Access := Tree.Root; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Map) is begin - if N = 0 then - pragma Assert (X = null); - return; - end if; - - Tree := (Length => 0, others => null); - - Tree.Root := Copy_Tree (X); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; + Adjust (Container.Tree); end Adjust; ------------- @@ -221,19 +192,19 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Map) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -270,64 +241,21 @@ package body Ada.Containers.Ordered_Maps is return Target; end Copy_Node; - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - P, X : Node_Access; - - begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - - exception - when others => - Delete_Tree (Target_Root); - raise; - end Copy_Tree; - ------------ -- Delete -- ------------ procedure Delete (Container : in out Map; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Map_Access'(Container'Unchecked_Access) then + if Position.Container /= Map_Access'(Container'Unrestricted_Access) then raise Program_Error; end if; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -350,9 +278,12 @@ package body Ada.Containers.Ordered_Maps is ------------------ procedure Delete_First (Container : in out Map) is - Position : Cursor := First (Container); + X : Node_Access := Container.Tree.First; begin - Delete (Container, Position); + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; end Delete_First; ----------------- @@ -360,27 +291,13 @@ package body Ada.Containers.Ordered_Maps is ----------------- procedure Delete_Last (Container : in out Map) is - Position : Cursor := Last (Container); + X : Node_Access := Container.Tree.Last; begin - Delete (Container, Position); - end Delete_Last; - - - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; - begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); - X := Y; - end loop; - end Delete_Tree; + end if; + end Delete_Last; ------------- -- Element -- @@ -423,7 +340,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -436,7 +353,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -469,7 +386,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ----------------- @@ -497,6 +414,10 @@ package body Ada.Containers.Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Key := Key; Position.Node.Element := New_Item; end if; @@ -543,7 +464,7 @@ package body Ada.Containers.Ordered_Maps is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -609,7 +530,7 @@ package body Ada.Containers.Ordered_Maps is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; -------------- @@ -628,7 +549,15 @@ package body Ada.Containers.Ordered_Maps is function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is begin - return L.Element = R.Element; + if L.Key < R.Key then + return False; + + elsif R.Key < L.Key then + return False; + + else + return L.Element = R.Element; + end if; end Is_Equal_Node_Node; ------------------------- @@ -677,13 +606,25 @@ package body Ada.Containers.Ordered_Maps is 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.Tree'Unrestricted_Access.all.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- @@ -705,7 +646,7 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -748,12 +689,11 @@ package body Ada.Containers.Ordered_Maps is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Map; Source : in out Map) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -828,10 +768,32 @@ package body Ada.Containers.Ordered_Maps is procedure Query_Element (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) is + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -842,41 +804,35 @@ package body Ada.Containers.Ordered_Maps is (Stream : access Root_Stream_Type'Class; Container : out Map) is - N : Count_Type'Base; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); - function New_Node return Node_Access; - pragma Inline (New_Node); + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); - procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + --------------- + -- Read_Node -- + --------------- - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; - begin - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - exception - when others => - Free (Node); - raise; - end; - + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); return Node; - end New_Node; + exception + when others => + Free (Node); + raise; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - Local_Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -895,6 +851,10 @@ package body Ada.Containers.Ordered_Maps is raise Constraint_Error; end if; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Node.Key := Key; Node.Element := New_Item; end Replace; @@ -904,8 +864,14 @@ package body Ada.Containers.Ordered_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is + E : Element_Type renames Position.Node.Element; + begin - Position.Node.Element := By; + if Position.Container.Tree.Lock > 0 then + raise Program_Error; + end if; + + E := By; end Replace_Element; --------------------- @@ -928,13 +894,25 @@ package body Ada.Containers.Ordered_Maps is 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.Tree'Unrestricted_Access.all.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (Container.Tree); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -976,7 +954,6 @@ package body Ada.Containers.Ordered_Maps is Node.Parent := Parent; end Set_Parent; - --------------- -- Set_Right -- --------------- @@ -992,10 +969,32 @@ package body Ada.Containers.Ordered_Maps is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Key, Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Update_Element; ----------- @@ -1006,26 +1005,31 @@ package body Ada.Containers.Ordered_Maps is (Stream : access Root_Stream_Type'Class; Container : Map) is - procedure Process (Node : Node_Access); - pragma Inline (Process); - - procedure Iterate is new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Key_Type'Write (Stream, Node.Key); Element_Type'Write (Stream, Node.Element); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 7fa06e0..c31a7f0 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_MAPS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -93,34 +93,34 @@ pragma Preelaborate (Ordered_Maps); procedure Insert (Container : in out Map; Key : Key_Type; - New_Item : Element_Type); + Position : out Cursor; + Inserted : out Boolean); - procedure Include + procedure Insert (Container : in out Map; Key : Key_Type; New_Item : Element_Type); - procedure Replace + procedure Include (Container : in out Map; Key : Key_Type; New_Item : Element_Type); - procedure Insert + procedure Replace (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); + New_Item : Element_Type); procedure Delete (Container : in out Map; Key : Key_Type); - procedure Exclude (Container : in out Map; Key : Key_Type); - procedure Delete (Container : in out Map; Position : in out Cursor); procedure Delete_First (Container : in out Map); procedure Delete_Last (Container : in out Map); + procedure Exclude (Container : in out Map; Key : Key_Type); + function Contains (Container : Map; Key : Key_Type) return Boolean; function Find (Container : Map; Key : Key_Type) return Cursor; @@ -145,10 +145,10 @@ pragma Preelaborate (Ordered_Maps); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -178,21 +178,32 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Type; + Element : Element_Type; + end record; - use Tree_Types; - use Ada.Finalization; + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); - type Map is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + type Map is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Map); procedure Finalize (Container : in out Map) renames Clear; - type Map_Access is access constant Map; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Map_Access is access Map; for Map_Access'Storage_Size use 0; type Cursor is record @@ -210,7 +221,6 @@ private for Map'Write use Write; - procedure Read (Stream : access Root_Stream_Type'Class; Container : out Map); @@ -218,6 +228,11 @@ private for Map'Read use Read; Empty_Map : constant Map := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index 2071296..387abfb 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_MULTISETS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -44,20 +44,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); -with System; use type System.Address; - package body Ada.Containers.Ordered_Multisets is - use Red_Black_Trees; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Element : Element_Type; - end record; - ----------------------------- -- Node Access Subprograms -- ----------------------------- @@ -96,10 +84,6 @@ package body Ada.Containers.Ordered_Multisets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -122,19 +106,28 @@ package body Ada.Containers.Ordered_Multisets is function Is_Less_Node_Node (L, R : Node_Access) return Boolean; pragma Inline (Is_Less_Node_Node); + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + -------------------------- -- Local Instantiations -- -------------------------- + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); - use Tree_Operations; + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; function Is_Equal is new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); @@ -182,10 +175,6 @@ package body Ada.Containers.Ordered_Multisets is function "=" (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; @@ -216,24 +205,12 @@ package body Ada.Containers.Ordered_Multisets is -- Adjust -- ------------ - procedure Adjust (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - - N : constant Count_Type := Tree.Length; - X : constant Node_Access := Tree.Root; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Set) is begin - if N = 0 then - pragma Assert (X = null); - return; - end if; - - Tree := (Length => 0, others => null); - - Tree.Root := Copy_Tree (X); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; + Adjust (Container.Tree); end Adjust; ------------- @@ -249,19 +226,19 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -297,49 +274,6 @@ package body Ada.Containers.Ordered_Multisets is return Target; end Copy_Node; - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - - P, X : Node_Access; - - begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - - exception - when others => - Delete_Tree (Target_Root); - raise; - end Copy_Tree; - ------------ -- Delete -- ------------ @@ -367,11 +301,11 @@ package body Ada.Containers.Ordered_Multisets is procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; @@ -415,48 +349,20 @@ package body Ada.Containers.Ordered_Multisets is Free (X); end Delete_Last; - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; - begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; - Free (X); - X := Y; - end loop; - end Delete_Tree; - ---------------- -- Difference -- ---------------- procedure Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Difference (Target.Tree, Source.Tree); end Difference; function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Difference; ------------- @@ -468,6 +374,39 @@ package body Ada.Containers.Ordered_Multisets is return Position.Node.Element; end Element; + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + ------------- -- Exclude -- ------------- @@ -499,7 +438,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -512,7 +451,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -537,7 +476,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------ @@ -612,77 +551,9 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; - ---------------------------- - -- Checked_Update_Element -- - ---------------------------- - - procedure Checked_Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error; - end if; - - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - declare - Old_Key : Key_Type renames Key (Position.Node.Element); - - begin - Process (Position.Node.Element); - - if Old_Key < Position.Node.Element - or else Old_Key > Position.Node.Element - then - null; - else - return; - end if; - end; - - Delete_Node_Sans_Free (Container.Tree, Position.Node); - - Do_Insert : declare - Result : Node_Access; - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Keys.Generic_Insert_Post (New_Node); - - procedure Insert is - new Key_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - -- Start of processing for Do_Insert - - begin - Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element), - Node => Result); - - pragma Assert (Result = Position.Node); - end Do_Insert; - end Checked_Update_Element; - -------------- -- Contains -- -------------- @@ -759,7 +630,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -775,7 +646,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -821,13 +692,26 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree, Key); + B := B + 1; + + begin + Local_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- @@ -839,27 +723,6 @@ package body Ada.Containers.Ordered_Multisets is return Key (Position.Node.Element); end Key; - ------------- - -- Replace -- - ------------- - - -- In post-madision api:??? - --- procedure Replace --- (Container : in out Set; --- Key : Key_Type; --- New_Item : Element_Type) --- is --- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); - --- begin --- if Node = null then --- raise Constraint_Error; --- end if; - --- Replace_Node (Container, Node, New_Item); --- end Replace; - --------------------- -- Reverse_Iterate -- --------------------- @@ -881,15 +744,90 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree, Key); + B := B + 1; + + begin + Local_Reverse_Iterate (T, Key); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + declare + E : Element_Type renames Position.Node.Element; + K : Key_Type renames Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if K < E + or else K > E + then + null; + else + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error; + end Update_Element_Preserving_Key; + end Generic_Keys; ----------------- @@ -948,7 +886,7 @@ package body Ada.Containers.Ordered_Multisets is New_Item, Position.Node); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; ---------------------- @@ -1006,25 +944,14 @@ package body Ada.Containers.Ordered_Multisets is procedure Intersection (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Intersection (Target.Tree, Source.Tree); end Intersection; function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Intersection; -------------- @@ -1086,10 +1013,6 @@ package body Ada.Containers.Ordered_Multisets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is begin - if Subset'Address = Of_Set'Address then - return True; - end if; - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); end Is_Subset; @@ -1113,13 +1036,26 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; procedure Iterate @@ -1139,13 +1075,26 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.Tree, Item); + B := B + 1; + + begin + Local_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -1158,7 +1107,7 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -1192,12 +1141,11 @@ package body Ada.Containers.Ordered_Multisets is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Set; Source : in out Set) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -1219,7 +1167,7 @@ package body Ada.Containers.Ordered_Multisets is declare Node : constant Node_Access := - Tree_Operations.Next (Position.Node); + Tree_Operations.Next (Position.Node); begin if Node = null then return No_Element; @@ -1235,10 +1183,6 @@ package body Ada.Containers.Ordered_Multisets is function Overlap (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return Left.Tree.Length /= 0; - end if; - return Set_Ops.Overlap (Left.Tree, Right.Tree); end Overlap; @@ -1269,7 +1213,7 @@ package body Ada.Containers.Ordered_Multisets is declare Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); + Tree_Operations.Previous (Position.Node); begin if Node = null then return No_Element; @@ -1287,8 +1231,29 @@ package body Ada.Containers.Ordered_Multisets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + E : Element_Type renames Position.Node.Element; + + S : Set renames Position.Container.all; + T : Tree_Type renames S.Tree'Unrestricted_Access.all; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -1299,151 +1264,113 @@ package body Ada.Containers.Ordered_Multisets is (Stream : access Root_Stream_Type'Class; Container : out Set) is - N : Count_Type'Base; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); - -------------- - -- New_Node -- - -------------- + --------------- + -- Read_Node -- + --------------- - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; - begin - begin - Element_Type'Read (Stream, Node.Element); - - exception - when others => - Free (Node); - raise; - end; - + Element_Type'Read (Stream, Node.Element); return Node; - end New_Node; + exception + when others => + Free (Node); -- Note that Free deallocates elem too + raise; + end Read_Node; -- Start of processing for Read begin - Clear (Container); + Read (Stream, Container.Tree); + end Read; - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); + --------------------- + -- Replace_Element -- + --------------------- - Local_Read (Container.Tree, N); - end Read; + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; - ------------- - -- Replace -- - ------------- + Node.Element := Item; + return; + end if; - -- NOTE: from post-madison api ??? + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit --- procedure Replace --- (Container : in out Set; --- Position : Cursor; --- By : Element_Type) --- is --- begin --- if Position.Container = null then --- raise Constraint_Error; --- end if; + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); --- Replace_Node (Container, Position.Node, By); --- end Replace; + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - ------------------ - -- Replace_Node -- - ------------------ + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := Item; + return Node; + end New_Node; + + Result : Node_Access; + + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Item, + Node => Result); + + pragma Assert (Result = Node); + end Insert_New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; - -- NOTE: from post-madison api ??? - --- procedure Replace_Node --- (Container : in out Set; --- Position : Node_Access; --- By : Element_Type) --- is --- Tree : Tree_Type renames Container.Tree; --- Node : Node_Access := Position; - --- begin --- if By < Node.Element --- or else Node.Element < By --- then --- null; - --- else --- begin --- Node.Element := By; - --- exception --- when others => --- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); --- Free (Node); --- raise; --- end; - --- return; --- end if; - --- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); - --- begin --- Node.Element := By; - --- exception --- when others => --- Free (Node); --- raise; --- end; --- --- Do_Insert : declare --- Result : Node_Access; --- Success : Boolean; - --- function New_Node return Node_Access; --- pragma Inline (New_Node); - --- procedure Insert_Post is --- new Element_Keys.Generic_Insert_Post (New_Node); --- --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (Insert_Post); - --- -------------- --- -- New_Node -- --- -------------- - --- function New_Node return Node_Access is --- begin --- return Node; --- end New_Node; - --- -- Start of processing for Do_Insert - --- begin --- Insert --- (Tree => Tree, --- Key => Node.Element, --- Node => Result, --- Success => Success); --- --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; --- --- pragma Assert (Result = Node); --- end Do_Insert; --- end Replace_Node; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Tree, Position.Node, By); + end Replace_Element; --------------------- -- Reverse_Iterate -- @@ -1465,13 +1392,26 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; procedure Reverse_Iterate @@ -1491,13 +1431,26 @@ package body Ada.Containers.Ordered_Multisets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree, Item); + B := B + 1; + + begin + Local_Reverse_Iterate (T, Item); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -1551,26 +1504,14 @@ package body Ada.Containers.Ordered_Multisets is procedure Symmetric_Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Symmetric_Difference; ----------- @@ -1579,25 +1520,14 @@ package body Ada.Containers.Ordered_Multisets is procedure Union (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Union (Target.Tree, Source.Tree); end Union; function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Union (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Union; ----------- @@ -1608,28 +1538,30 @@ package body Ada.Containers.Ordered_Multisets is (Stream : access Root_Stream_Type'Class; Container : Set) is - procedure Process (Node : Node_Access); - pragma Inline (Process); + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); - ------------- - -- Process -- - ------------- + ---------------- + -- Write_Node -- + ---------------- - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Element_Type'Write (Stream, Node.Element); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; end Ada.Containers.Ordered_Multisets; - - diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index 6d848a8..4fbb653 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_MULTISETS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -56,6 +56,8 @@ pragma Preelaborate (Ordered_Multisets); function "=" (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -68,6 +70,11 @@ pragma Preelaborate (Ordered_Multisets); (Position : Cursor; Process : not null access procedure (Element : Element_Type)); + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type); + procedure Move (Target : in out Set; Source : in out Set); @@ -85,10 +92,6 @@ pragma Preelaborate (Ordered_Multisets); (Container : in out Set; Item : Element_Type); - procedure Exclude - (Container : in out Set; - Item : Element_Type); - procedure Delete (Container : in out Set; Position : in out Cursor); @@ -97,13 +100,9 @@ pragma Preelaborate (Ordered_Multisets); procedure Delete_Last (Container : in out Set); - -- NOTE: The following operation is named Replace in the Madison API. - -- However, it should be named Replace_Element. ??? - -- - -- procedure Replace - -- (Container : in out Set; - -- Position : Cursor; - -- By : Element_Type); + procedure Exclude + (Container : in out Set; + Item : Element_Type); procedure Union (Target : in out Set; Source : Set); @@ -151,10 +150,10 @@ pragma Preelaborate (Ordered_Multisets); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -214,12 +213,6 @@ pragma Preelaborate (Ordered_Multisets); function Element (Container : Set; Key : Key_Type) return Element_Type; - -- NOTE: in post-madison api ??? - -- procedure Replace - -- (Container : in out Set; - -- Key : Key_Type; - -- New_Item : Element_Type); - procedure Delete (Container : in out Set; Key : Key_Type); procedure Exclude (Container : in out Set; Key : Key_Type); @@ -232,9 +225,7 @@ pragma Preelaborate (Ordered_Multisets); function ">" (Left : Key_Type; Right : Cursor) return Boolean; - -- Should name of following be "Update_Element" ??? - - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; Process : not null access @@ -257,21 +248,31 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Type; + end record; - use Tree_Types; - use Ada.Finalization; + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); - type Set is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Set); procedure Finalize (Container : in out Set) renames Clear; - type Set_Access is access constant Set; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Set_Access is access all Set; for Set_Access'Storage_Size use 0; type Cursor is record @@ -296,6 +297,11 @@ private for Set'Read use Read; Empty_Set : constant Set := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 03cf003..6e80398 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_SETS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -44,20 +44,8 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); -with System; use type System.Address; - package body Ada.Containers.Ordered_Sets is - use Red_Black_Trees; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red; - Element : Element_Type; - end record; - ------------------------------ -- Access to Fields of Node -- ------------------------------ @@ -96,10 +84,6 @@ package body Ada.Containers.Ordered_Sets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); - function Copy_Tree (Source_Root : Node_Access) return Node_Access; - - procedure Delete_Tree (X : in out Node_Access); - procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -122,19 +106,28 @@ package body Ada.Containers.Ordered_Sets is function Is_Less_Node_Node (L, R : Node_Access) return Boolean; pragma Inline (Is_Less_Node_Node); + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + -------------------------- -- Local Instantiations -- -------------------------- + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + package Tree_Operations is - new Red_Black_Trees.Generic_Operations - (Tree_Types => Tree_Types, - Null_Node => Node_Access'(null)); + new Red_Black_Trees.Generic_Operations (Tree_Types); - use Tree_Operations; + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; function Is_Equal is new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); @@ -180,10 +173,6 @@ package body Ada.Containers.Ordered_Sets is function "=" (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return True; - end if; - return Is_Equal (Left.Tree, Right.Tree); end "="; @@ -212,24 +201,12 @@ package body Ada.Containers.Ordered_Sets is -- Adjust -- ------------ - procedure Adjust (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - - N : constant Count_Type := Tree.Length; - X : constant Node_Access := Tree.Root; + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + procedure Adjust (Container : in out Set) is begin - if N = 0 then - pragma Assert (X = null); - return; - end if; - - Tree := (Length => 0, others => null); - - Tree.Root := Copy_Tree (X); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; + Adjust (Container.Tree); end Adjust; ------------- @@ -245,19 +222,19 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- -- Clear -- ----------- + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + procedure Clear (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - Root : Node_Access := Tree.Root; begin - Tree := (Length => 0, others => null); - Delete_Tree (Root); + Clear (Container.Tree); end Clear; ----------- @@ -296,65 +273,21 @@ package body Ada.Containers.Ordered_Sets is return Target; end Copy_Node; - --------------- - -- Copy_Tree -- - --------------- - - function Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - - P, X : Node_Access; - - begin - if Source_Root.Right /= null then - Target_Root.Right := Copy_Tree (Source_Root.Right); - Target_Root.Right.Parent := Target_Root; - end if; - - P := Target_Root; - X := Source_Root.Left; - while X /= null loop - declare - Y : Node_Access := Copy_Node (X); - - begin - P.Left := Y; - Y.Parent := P; - - if X.Right /= null then - Y.Right := Copy_Tree (X.Right); - Y.Right.Parent := Y; - end if; - - P := Y; - X := X.Left; - end; - end loop; - - return Target_Root; - - exception - when others => - - Delete_Tree (Target_Root); - raise; - end Copy_Tree; - ------------ -- Delete -- ------------ procedure Delete (Container : in out Set; Position : in out Cursor) is begin - if Position = No_Element then - return; + if Position.Node = null then + raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; end Delete; @@ -367,7 +300,7 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error; end if; - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end Delete; @@ -376,9 +309,14 @@ package body Ada.Containers.Ordered_Sets is ------------------ procedure Delete_First (Container : in out Set) is - C : Cursor := First (Container); + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + begin - Delete (Container, C); + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; end Delete_First; ----------------- @@ -386,26 +324,15 @@ package body Ada.Containers.Ordered_Sets is ----------------- procedure Delete_Last (Container : in out Set) is - C : Cursor := Last (Container); - begin - Delete (Container, C); - end Delete_Last; - - ----------------- - -- Delete_Tree -- - ----------------- + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; - procedure Delete_Tree (X : in out Node_Access) is - Y : Node_Access; begin - while X /= null loop - Y := X.Right; - Delete_Tree (Y); - Y := X.Left; + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); Free (X); - X := Y; - end loop; - end Delete_Tree; + end if; + end Delete_Last; ---------------- -- Difference -- @@ -413,26 +340,14 @@ package body Ada.Containers.Ordered_Sets is procedure Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Difference (Target.Tree, Source.Tree); end Difference; function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Difference; ------------- @@ -444,6 +359,38 @@ package body Ada.Containers.Ordered_Sets is return Position.Node.Element; end Element; + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + ------------- -- Exclude -- ------------- @@ -453,7 +400,7 @@ package body Ada.Containers.Ordered_Sets is begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -471,7 +418,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -484,7 +431,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end First; ------------------- @@ -509,7 +456,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------ @@ -584,88 +531,9 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; - ---------------------------- - -- Checked_Update_Element -- - ---------------------------- - - procedure Checked_Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Container = null then - raise Constraint_Error; - end if; - - if Position.Container /= Set_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - declare - Old_Key : Key_Type renames Key (Position.Node.Element); - - begin - Process (Position.Node.Element); - - if Old_Key < Position.Node.Element - or else Old_Key > Position.Node.Element - then - null; - else - return; - end if; - end; - - Delete_Node_Sans_Free (Container.Tree, Position.Node); - - declare - Result : Node_Access; - Success : Boolean; - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Key_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Conditional_Insert is - new Key_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return Position.Node; - end New_Node; - - - begin - Local_Conditional_Insert - (Tree => Container.Tree, - Key => Key (Position.Node.Element), - Node => Result, - Success => Success); - - if not Success then - declare - X : Node_Access := Position.Node; - begin - Free (X); - end; - - raise Program_Error; - end if; - - pragma Assert (Result = Position.Node); - end; - end Checked_Update_Element; - -------------- -- Contains -- -------------- @@ -700,6 +568,7 @@ package body Ada.Containers.Ordered_Sets is Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin return Node.Element; end Element; @@ -710,6 +579,7 @@ package body Ada.Containers.Ordered_Sets is procedure Exclude (Container : in out Set; Key : Key_Type) is X : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin if X /= null then Delete_Node_Sans_Free (Container.Tree, X); @@ -729,7 +599,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -744,7 +614,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ------------------------- @@ -784,22 +654,82 @@ package body Ada.Containers.Ordered_Sets is -- Replace -- ------------- --- TODO??? + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); --- procedure Replace --- (Container : in out Set; --- Key : Key_Type; --- New_Item : Element_Type) --- is --- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if Node = null then + raise Constraint_Error; + end if; --- begin --- if Node = null then --- raise Constraint_Error; --- end if; + Replace_Element (Container.Tree, Node, New_Item); + end Replace; --- Replace_Element (Container, Node, New_Item); --- end Replace; + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + declare + E : Element_Type renames Position.Node.Element; + K : Key_Type renames Key (E); + + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + + begin + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + + if K < E + or else K > E + then + null; + else + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error; + end Update_Element_Preserving_Key; end Generic_Keys; @@ -824,6 +754,10 @@ package body Ada.Containers.Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Position.Node.Element := New_Item; end if; end Include; @@ -871,14 +805,13 @@ package body Ada.Containers.Ordered_Sets is Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; Inserted : Boolean; @@ -948,25 +881,14 @@ package body Ada.Containers.Ordered_Sets is procedure Intersection (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Intersection (Target.Tree, Source.Tree); end Intersection; function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Intersection; -------------- @@ -975,7 +897,7 @@ package body Ada.Containers.Ordered_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Length (Container) = 0; + return Container.Tree.Length = 0; end Is_Empty; ------------------------ @@ -1028,10 +950,6 @@ package body Ada.Containers.Ordered_Sets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is begin - if Subset'Address = Of_Set'Address then - return True; - end if; - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); end Is_Subset; @@ -1055,13 +973,26 @@ package body Ada.Containers.Ordered_Sets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of prccessing for Iterate begin - Local_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; ---------- @@ -1074,7 +1005,7 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end Last; ------------------ @@ -1108,12 +1039,11 @@ package body Ada.Containers.Ordered_Sets is -- Move -- ---------- + procedure Move is + new Tree_Operations.Generic_Move (Clear); + procedure Move (Target : in out Set; Source : in out Set) is begin - if Target'Address = Source'Address then - return; - end if; - Move (Target => Target.Tree, Source => Source.Tree); end Move; @@ -1129,7 +1059,8 @@ package body Ada.Containers.Ordered_Sets is declare Node : constant Node_Access := - Tree_Operations.Next (Position.Node); + Tree_Operations.Next (Position.Node); + begin if Node = null then return No_Element; @@ -1150,10 +1081,6 @@ package body Ada.Containers.Ordered_Sets is function Overlap (Left, Right : Set) return Boolean is begin - if Left'Address = Right'Address then - return Left.Tree.Length /= 0; - end if; - return Set_Ops.Overlap (Left.Tree, Right.Tree); end Overlap; @@ -1202,8 +1129,29 @@ package body Ada.Containers.Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is + E : Element_Type renames Position.Node.Element; + + S : Set renames Position.Container.all; + T : Tree_Type renames S.Tree'Unrestricted_Access.all; + + B : Natural renames T.Busy; + L : Natural renames T.Lock; + begin - Process (Position.Node.Element); + B := B + 1; + L := L + 1; + + begin + Process (E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end Query_Element; ---------- @@ -1214,42 +1162,36 @@ package body Ada.Containers.Ordered_Sets is (Stream : access Root_Stream_Type'Class; Container : out Set) is - N : Count_Type'Base; + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); - -------------- - -- New_Node -- - -------------- + --------------- + -- Read_Node -- + --------------- - function New_Node return Node_Access is + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is Node : Node_Access := new Node_Type; begin - begin - Element_Type'Read (Stream, Node.Element); - - exception - when others => - Free (Node); - raise; - end; - + Element_Type'Read (Stream, Node.Element); return Node; - end New_Node; + + exception + when others => + Free (Node); + raise; + end Read_Node; -- Start of processing for Read begin - Clear (Container); - - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - Local_Read (Container.Tree, N); + Read (Stream, Container.Tree); end Read; ------------- @@ -1265,6 +1207,10 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error; end if; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + Node.Element := New_Item; end Replace; @@ -1272,95 +1218,124 @@ package body Ada.Containers.Ordered_Sets is -- Replace_Element -- --------------------- --- TODO: ??? --- procedure Replace_Element --- (Container : in out Set; --- Position : Node_Access; --- By : Element_Type) --- is --- Node : Node_Access := Position; - --- begin --- if By < Node.Element --- or else Node.Element < By --- then --- null; - --- else --- begin --- Node.Element := By; - --- exception --- when others => --- Delete_Node_Sans_Free (Container.Tree, Node); --- Free (Node); --- raise; --- end; - --- return; --- end if; - --- Delete_Node_Sans_Free (Container.Tree, Node); - --- begin --- Node.Element := By; --- exception --- when others => --- Free (Node); --- raise; --- end; - --- declare --- function New_Node return Node_Access; --- pragma Inline (New_Node); - --- function New_Node return Node_Access is --- begin --- return Node; --- end New_Node; - --- procedure Insert_Post is --- new Element_Keys.Generic_Insert_Post (New_Node); - --- procedure Insert is --- new Element_Keys.Generic_Conditional_Insert (Insert_Post); - --- Result : Node_Access; --- Success : Boolean; - --- begin --- Insert --- (Tree => Container.Tree, --- Key => Node.Element, --- Node => Result, --- Success => Success); - --- if not Success then --- Free (Node); --- raise Program_Error; --- end if; - --- pragma Assert (Result = Node); --- end; --- end Replace_Element; - - --- procedure Replace_Element --- (Container : in out Set; --- Position : Cursor; --- By : Element_Type) --- is --- begin --- if Position.Container = null then --- raise Constraint_Error; --- end if; - --- if Position.Container /= Set_Access'(Container'Unchecked_Access) then --- raise Program_Error; --- end if; - --- Replace_Element (Container, Position.Node, By); --- end Replace_Element; + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + else + if Tree.Lock > 0 then + raise Program_Error; + end if; + + Node.Element := Item; + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := Item; + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Insert_New_Item + + begin + Insert + (Tree => Tree, + Key => Item, + Node => Result, + Success => Inserted); -- TODO: change param name + + if Inserted then + pragma Assert (Result = Node); + return; + end if; + exception + when others => + null; -- Assignment must have failed + end Insert_New_Item; + + Reinsert_Old_Element : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Node; + end New_Node; + + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Reinsert_Old_Element + + begin + Insert + (Tree => Tree, + Key => Node.Element, + Node => Result, + Success => Inserted); -- TODO: change param name + exception + when others => + null; -- Assignment must have failed + end Reinsert_Old_Element; + + raise Program_Error; + end Replace_Element; + + procedure Replace_Element + (Container : Set; + Position : Cursor; + By : Element_Type) + is + Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all; + + begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Tree, Position.Node, By); + end Replace_Element; --------------------- -- Reverse_Iterate -- @@ -1382,13 +1357,26 @@ package body Ada.Containers.Ordered_Sets is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + B : Natural renames T.Busy; + -- Start of processing for Reverse_Iterate begin - Local_Reverse_Iterate (Container.Tree); + B := B + 1; + + begin + Local_Reverse_Iterate (T); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Reverse_Iterate; ----------- @@ -1442,26 +1430,14 @@ package body Ada.Containers.Ordered_Sets is procedure Symmetric_Difference (Target : in out Set; Source : Set) is begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); end Symmetric_Difference; function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - declare - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Symmetric_Difference; ----------- @@ -1470,25 +1446,14 @@ package body Ada.Containers.Ordered_Sets is procedure Union (Target : in out Set; Source : Set) is begin - - if Target'Address = Source'Address then - return; - end if; - Set_Ops.Union (Target.Tree, Source.Tree); end Union; function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); begin - if Left'Address = Right'Address then - return Left; - end if; - - declare - Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); - begin - return (Controlled with Tree); - end; + return Set'(Controlled with Tree); end Union; ----------- @@ -1499,31 +1464,30 @@ package body Ada.Containers.Ordered_Sets is (Stream : access Root_Stream_Type'Class; Container : Set) is - procedure Process (Node : Node_Access); - pragma Inline (Process); + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); - ------------- - -- Process -- - ------------- + ---------------- + -- Write_Node -- + ---------------- - procedure Process (Node : Node_Access) is + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is begin Element_Type'Write (Stream, Node.Element); - end Process; + end Write_Node; -- Start of processing for Write begin - Count_Type'Base'Write (Stream, Container.Tree.Length); - Iterate (Container.Tree); + Write (Stream, Container.Tree); end Write; - - - end Ada.Containers.Ordered_Sets; - - diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 1dca837..1799495 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.ORDERED_SETS -- +-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -57,6 +57,8 @@ pragma Preelaborate (Ordered_Sets); function "=" (Left, Right : Set) return Boolean; + function Equivalent_Sets (Left, Right : Set) return Boolean; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -69,11 +71,10 @@ pragma Preelaborate (Ordered_Sets); (Position : Cursor; Process : not null access procedure (Element : Element_Type)); --- TODO: resolve in Atlanta. ??? --- procedure Replace_Element --- (Container : in out Set; --- Position : Cursor; --- By : Element_Type); + procedure Replace_Element + (Container : Set; -- TODO: need ARG ruling + Position : Cursor; + By : Element_Type); procedure Move (Target : in out Set; @@ -94,17 +95,13 @@ pragma Preelaborate (Ordered_Sets); New_Item : Element_Type); procedure Replace - (Container : in out Set; + (Container : in out Set; -- TODO: need ARG ruling New_Item : Element_Type); procedure Delete (Container : in out Set; Item : Element_Type); - procedure Exclude - (Container : in out Set; - Item : Element_Type); - procedure Delete (Container : in out Set; Position : in out Cursor); @@ -113,6 +110,10 @@ pragma Preelaborate (Ordered_Sets); procedure Delete_Last (Container : in out Set); + procedure Exclude + (Container : in out Set; + Item : Element_Type); + procedure Union (Target : in out Set; Source : Set); function Union (Left, Right : Set) return Set; @@ -160,10 +161,10 @@ pragma Preelaborate (Ordered_Sets); function Next (Position : Cursor) return Cursor; - function Previous (Position : Cursor) return Cursor; - procedure Next (Position : in out Cursor); + function Previous (Position : Cursor) return Cursor; + procedure Previous (Position : in out Cursor); function Has_Element (Position : Cursor) return Boolean; @@ -215,11 +216,10 @@ pragma Preelaborate (Ordered_Sets); function Element (Container : Set; Key : Key_Type) return Element_Type; --- TODO: resolve in Atlanta ??? --- procedure Replace --- (Container : in out Set; --- Key : Key_Type; --- New_Item : Element_Type); + procedure Replace + (Container : in out Set; -- TODO: need ARG ruling + Key : Key_Type; + New_Item : Element_Type); procedure Delete (Container : in out Set; Key : Key_Type); @@ -233,8 +233,7 @@ pragma Preelaborate (Ordered_Sets); function ">" (Left : Key_Type; Right : Cursor) return Boolean; --- TODO: resolve name in Atlanta. Should name be just "Update_Element" ??? - procedure Checked_Update_Element + procedure Update_Element_Preserving_Key (Container : in out Set; Position : Cursor; Process : not null access @@ -247,21 +246,32 @@ private type Node_Type; type Node_Access is access Node_Type; - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Access); + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Type; + end record; - use Tree_Types; - use Ada.Finalization; + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); - type Set is new Controlled with record - Tree : Tree_Type := (Length => 0, others => null); + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; end record; procedure Adjust (Container : in out Set); procedure Finalize (Container : in out Set) renames Clear; - type Set_Access is access constant Set; + use Red_Black_Trees; + use Tree_Types; + use Ada.Finalization; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; type Cursor is record Container : Set_Access; @@ -285,6 +295,11 @@ private for Set'Read use Read; Empty_Set : constant Set := - (Controlled with Tree => (Length => 0, others => null)); + (Controlled with Tree => (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0)); end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads index fe20d45..abf9fa6 100644 --- a/gcc/ada/a-crbltr.ads +++ b/gcc/ada/a-crbltr.ads @@ -2,15 +2,35 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S -- -- -- -- S p e c -- -- -- --- This specification is adapted from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ package Ada.Containers.Red_Black_Trees is @@ -19,13 +39,17 @@ pragma Pure (Red_Black_Trees); type Color_Type is (Red, Black); generic - type Node_Access is private; + type Node_Type (<>) is limited private; + type Node_Access is access Node_Type; package Generic_Tree_Types is - type Tree_Type is record + type Tree_Type is tagged record First : Node_Access; Last : Node_Access; Root : Node_Access; - Length : Count_Type; + Length : Count_Type := 0; + Busy : Natural := 0; + Lock : Natural := 0; end record; end Generic_Tree_Types; + end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 70c8f35..5efd4cd 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- +-- G E N E R I C _ K E Y S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -48,7 +49,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access := Tree.Root; begin - while X /= Ops.Null_Node loop + while X /= null loop if Is_Greater_Key_Node (Key, X) then X := Ops.Right (X); else @@ -69,7 +70,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access := Tree.Root; begin - while X /= Ops.Null_Node loop + while X /= null loop if Is_Greater_Key_Node (Key, X) then X := Ops.Right (X); else @@ -78,12 +79,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; end loop; - if Y = Ops.Null_Node then - return Ops.Null_Node; + if Y = null then + return null; end if; if Is_Less_Key_Node (Key, Y) then - return Ops.Null_Node; + return null; end if; return Y; @@ -98,7 +99,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access := Tree.Root; begin - while X /= Ops.Null_Node loop + while X /= null loop if Is_Less_Key_Node (Key, X) then X := Ops.Left (X); else @@ -120,12 +121,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Node : out Node_Access; Success : out Boolean) is - Y : Node_Access := Ops.Null_Node; + Y : Node_Access := null; X : Node_Access := Tree.Root; begin Success := True; - while X /= Ops.Null_Node loop + while X /= null loop Y := X; Success := Is_Less_Key_Node (Key, X); @@ -168,11 +169,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Success : out Boolean) is begin - if Position = Ops.Null_Node then -- largest + if Position = null then -- largest if Tree.Length > 0 and then Is_Greater_Key_Node (Key, Tree.Last) then - Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Insert_Post (Tree, null, Tree.Last, Key, Node); Success := True; else Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); @@ -195,8 +196,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is begin if Is_Greater_Key_Node (Key, Before) then - if Ops.Right (Before) = Ops.Null_Node then - Insert_Post (Tree, Ops.Null_Node, Before, Key, Node); + if Ops.Right (Before) = null then + Insert_Post (Tree, null, Before, Key, Node); else Insert_Post (Tree, Position, Position, Key, Node); end if; @@ -213,7 +214,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is if Is_Greater_Key_Node (Key, Position) then if Position = Tree.Last then - Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Insert_Post (Tree, null, Tree.Last, Key, Node); Success := True; return; end if; @@ -223,8 +224,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is begin if Is_Less_Key_Node (Key, After) then - if Ops.Right (Position) = Ops.Null_Node then - Insert_Post (Tree, Ops.Null_Node, Position, Key, Node); + if Ops.Right (Position) = null then + Insert_Post (Tree, null, Position, Key, Node); else Insert_Post (Tree, After, After, Key, Node); end if; @@ -258,26 +259,30 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1; begin - if Y = Ops.Null_Node - or else X /= Ops.Null_Node + if Tree.Busy > 0 then + raise Program_Error; + end if; + + if Y = null + or else X /= null or else Is_Less_Key_Node (Key, Y) then - pragma Assert (Y = Ops.Null_Node - or else Ops.Left (Y) = Ops.Null_Node); + pragma Assert (Y = null + or else Ops.Left (Y) = null); -- Delay allocation as long as we can, in order to defend -- against exceptions propagated by relational operators. Z := New_Node; - pragma Assert (Z /= Ops.Null_Node); + pragma Assert (Z /= null); pragma Assert (Ops.Color (Z) = Red); - if Y = Ops.Null_Node then + if Y = null then pragma Assert (Tree.Length = 0); - pragma Assert (Tree.Root = Ops.Null_Node); - pragma Assert (Tree.First = Ops.Null_Node); - pragma Assert (Tree.Last = Ops.Null_Node); + pragma Assert (Tree.Root = null); + pragma Assert (Tree.First = null); + pragma Assert (Tree.Last = null); Tree.Root := Z; Tree.First := Z; @@ -292,14 +297,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end if; else - pragma Assert (Ops.Right (Y) = Ops.Null_Node); + pragma Assert (Ops.Right (Y) = null); -- Delay allocation as long as we can, in order to defend -- against exceptions propagated by relational operators. Z := New_Node; - pragma Assert (Z /= Ops.Null_Node); + pragma Assert (Z /= null); pragma Assert (Ops.Color (Z) = Red); Ops.Set_Right (Y, Z); @@ -331,7 +336,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is procedure Iterate (Node : Node_Access) is N : Node_Access := Node; begin - while N /= Ops.Null_Node loop + while N /= null loop if Is_Less_Key_Node (Key, N) then N := Ops.Left (N); elsif Is_Greater_Key_Node (Key, N) then @@ -367,7 +372,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is procedure Iterate (Node : Node_Access) is N : Node_Access := Node; begin - while N /= Ops.Null_Node loop + while N /= null loop if Is_Less_Key_Node (Key, N) then N := Ops.Left (N); elsif Is_Greater_Key_Node (Key, N) then @@ -395,11 +400,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Key : Key_Type; Node : out Node_Access) is - Y : Node_Access := Ops.Null_Node; + Y : Node_Access := null; X : Node_Access := Tree.Root; begin - while X /= Ops.Null_Node loop + while X /= null loop Y := X; if Is_Less_Key_Node (Key, X) then @@ -431,11 +436,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- inserted last in the sequence of equivalent items.) ??? begin - if Hint = Ops.Null_Node then -- largest + if Hint = null then -- largest if Tree.Length > 0 and then Is_Greater_Key_Node (Key, Tree.Last) then - Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Insert_Post (Tree, null, Tree.Last, Key, Node); else Unconditional_Insert_Sans_Hint (Tree, Key, Node); end if; @@ -455,8 +460,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Before : constant Node_Access := Ops.Previous (Hint); begin if Is_Greater_Key_Node (Key, Before) then - if Ops.Right (Before) = Ops.Null_Node then - Insert_Post (Tree, Ops.Null_Node, Before, Key, Node); + if Ops.Right (Before) = null then + Insert_Post (Tree, null, Before, Key, Node); else Insert_Post (Tree, Hint, Hint, Key, Node); end if; @@ -470,7 +475,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is if Is_Greater_Key_Node (Key, Hint) then if Hint = Tree.Last then - Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Insert_Post (Tree, null, Tree.Last, Key, Node); return; end if; @@ -478,8 +483,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is After : constant Node_Access := Ops.Next (Hint); begin if Is_Less_Key_Node (Key, After) then - if Ops.Right (Hint) = Ops.Null_Node then - Insert_Post (Tree, Ops.Null_Node, Hint, Key, Node); + if Ops.Right (Hint) = null then + Insert_Post (Tree, null, Hint, Key, Node); else Insert_Post (Tree, After, After, Key, Node); end if; @@ -506,7 +511,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is X : Node_Access := Tree.Root; begin - while X /= Ops.Null_Node loop + while X /= null loop if Is_Less_Key_Node (Key, X) then Y := X; X := Ops.Left (X); @@ -519,5 +524,3 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is end Upper_Bound; end Ada.Containers.Red_Black_Trees.Generic_Keys; - - diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads index 445c28b..d20d700 100644 --- a/gcc/ada/a-crbtgk.ads +++ b/gcc/ada/a-crbtgk.ads @@ -2,7 +2,8 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- +-- G E N E R I C _ K E Y S -- -- -- -- S p e c -- -- -- @@ -133,6 +134,3 @@ pragma Pure (Generic_Keys); Key : Key_Type); end Ada.Containers.Red_Black_Trees.Generic_Keys; - - - diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index 9f9b712..dc82e55 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- +-- G E N E R I C _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,6 +34,8 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with System; use type System.Address; + package body Ada.Containers.Red_Black_Trees.Generic_Operations is ----------------------- @@ -61,7 +64,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Check (Node : Node_Access) return Natural is begin - if Node = Null_Node then + if Node = null then return 0; end if; @@ -69,14 +72,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is declare L : constant Node_Access := Left (Node); begin - pragma Assert (L = Null_Node or else Color (L) = Black); + pragma Assert (L = null or else Color (L) = Black); null; end; declare R : constant Node_Access := Right (Node); begin - pragma Assert (R = Null_Node or else Color (R) = Black); + pragma Assert (R = null or else Color (R) = Black); null; end; @@ -101,24 +104,24 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is -- Start of processing for Check_Invariant begin - if Root = Null_Node then - pragma Assert (Tree.First = Null_Node); - pragma Assert (Tree.Last = Null_Node); + if Root = null then + pragma Assert (Tree.First = null); + pragma Assert (Tree.Last = null); pragma Assert (Tree.Length = 0); null; else pragma Assert (Color (Root) = Black); pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= Null_Node); - pragma Assert (Tree.First /= Null_Node); - pragma Assert (Tree.Last /= Null_Node); - pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert (Tree.Root /= null); + pragma Assert (Tree.First /= null); + pragma Assert (Tree.Last /= null); + pragma Assert (Parent (Tree.Root) = null); pragma Assert ((Tree.Length > 1) or else (Tree.First = Tree.Last and Tree.First = Tree.Root)); - pragma Assert (Left (Tree.First) = Null_Node); - pragma Assert (Right (Tree.Last) = Null_Node); + pragma Assert (Left (Tree.First) = null); + pragma Assert (Right (Tree.Last) = null); declare L : constant Node_Access := Left (Root); @@ -157,18 +160,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is W := Right (Parent (X)); end if; - if (Left (W) = Null_Node or else Color (Left (W)) = Black) + if (Left (W) = null or else Color (Left (W)) = Black) and then - (Right (W) = Null_Node or else Color (Right (W)) = Black) + (Right (W) = null or else Color (Right (W)) = Black) then Set_Color (W, Red); X := Parent (X); else - if Right (W) = Null_Node + if Right (W) = null or else Color (Right (W)) = Black then - if Left (W) /= Null_Node then + if Left (W) /= null then Set_Color (Left (W), Black); end if; @@ -196,16 +199,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is W := Left (Parent (X)); end if; - if (Left (W) = Null_Node or else Color (Left (W)) = Black) + if (Left (W) = null or else Color (Left (W)) = Black) and then - (Right (W) = Null_Node or else Color (Right (W)) = Black) + (Right (W) = null or else Color (Right (W)) = Black) then Set_Color (W, Red); X := Parent (X); else - if Left (W) = Null_Node or else Color (Left (W)) = Black then - if Right (W) /= Null_Node then + if Left (W) = null or else Color (Left (W)) = Black then + if Right (W) /= null then Set_Color (Right (W), Black); end if; @@ -239,28 +242,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is X, Y : Node_Access; Z : constant Node_Access := Node; - pragma Assert (Z /= Null_Node); + pragma Assert (Z /= null); begin + if Tree.Busy > 0 then + raise Program_Error; + end if; + pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= Null_Node); - pragma Assert (Tree.First /= Null_Node); - pragma Assert (Tree.Last /= Null_Node); - pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert (Tree.Root /= null); + pragma Assert (Tree.First /= null); + pragma Assert (Tree.Last /= null); + pragma Assert (Parent (Tree.Root) = null); pragma Assert ((Tree.Length > 1) or else (Tree.First = Tree.Last and then Tree.First = Tree.Root)); - pragma Assert ((Left (Node) = Null_Node) + pragma Assert ((Left (Node) = null) or else (Parent (Left (Node)) = Node)); - pragma Assert ((Right (Node) = Null_Node) + pragma Assert ((Right (Node) = null) or else (Parent (Right (Node)) = Node)); - pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node)) - or else ((Parent (Node) /= Null_Node) and then + pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) + or else ((Parent (Node) /= null) and then ((Left (Parent (Node)) = Node) or else (Right (Parent (Node)) = Node)))); - if Left (Z) = Null_Node then - if Right (Z) = Null_Node then + if Left (Z) = null then + if Right (Z) = null then if Z = Tree.First then Tree.First := Parent (Z); end if; @@ -273,18 +280,18 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Delete_Fixup (Tree, Z); end if; - pragma Assert (Left (Z) = Null_Node); - pragma Assert (Right (Z) = Null_Node); + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); if Z = Tree.Root then pragma Assert (Tree.Length = 1); - pragma Assert (Parent (Z) = Null_Node); - Tree.Root := Null_Node; + pragma Assert (Parent (Z) = null); + Tree.Root := null; elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), Null_Node); + Set_Left (Parent (Z), null); else pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), Null_Node); + Set_Right (Parent (Z), null); end if; else @@ -312,7 +319,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is end if; end if; - elsif Right (Z) = Null_Node then + elsif Right (Z) = null then pragma Assert (Z /= Tree.First); X := Left (Z); @@ -341,11 +348,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is pragma Assert (Z /= Tree.Last); Y := Next (Z); - pragma Assert (Left (Y) = Null_Node); + pragma Assert (Left (Y) = null); X := Right (Y); - if X = Null_Node then + if X = null then if Y = Left (Parent (Y)) then pragma Assert (Parent (Y) /= Z); Delete_Swap (Tree, Z, Y); @@ -369,8 +376,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Set_Parent (Left (Y), Y); Set_Right (Y, Z); Set_Parent (Z, Y); - Set_Left (Z, Null_Node); - Set_Right (Z, Null_Node); + Set_Left (Z, null); + Set_Right (Z, null); declare Y_Color : constant Color_Type := Color (Y); @@ -384,14 +391,14 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Delete_Fixup (Tree, Z); end if; - pragma Assert (Left (Z) = Null_Node); - pragma Assert (Right (Z) = Null_Node); + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); if Z = Right (Parent (Z)) then - Set_Right (Parent (Z), Null_Node); + Set_Right (Parent (Z), null); else pragma Assert (Z = Left (Parent (Z))); - Set_Left (Parent (Z), Null_Node); + Set_Left (Parent (Z), null); end if; else @@ -467,20 +474,137 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Set_Left (Parent (Y), Y); end if; - if Right (Y) /= Null_Node then + if Right (Y) /= null then Set_Parent (Right (Y), Y); end if; - if Left (Y) /= Null_Node then + if Left (Y) /= null then Set_Parent (Left (Y), Y); end if; Set_Parent (Z, Y_Parent); Set_Color (Z, Y_Color); - Set_Left (Z, Null_Node); - Set_Right (Z, Null_Node); + Set_Left (Z, null); + Set_Right (Z, null); end Delete_Swap; + -------------------- + -- Generic_Adjust -- + -------------------- + + procedure Generic_Adjust (Tree : in out Tree_Type) is + N : constant Count_Type := Tree.Length; + Root : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (Root = null); + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.Lock = 0); + return; + end if; + + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Tree.Root := Copy_Tree (Root); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Generic_Adjust; + + ------------------- + -- Generic_Clear -- + ------------------- + + procedure Generic_Clear (Tree : in out Tree_Type) is + Root : Node_Access := Tree.Root; + begin + if Tree.Busy > 0 then + raise Program_Error; + end if; + + Tree := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + + Delete_Tree (Root); + end Generic_Clear; + + ----------------------- + -- Generic_Copy_Tree -- + ----------------------- + + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + + if Right (Source_Root) /= null then + Set_Right + (Node => Target_Root, + Right => Generic_Copy_Tree (Right (Source_Root))); + + Set_Parent + (Node => Right (Target_Root), + Parent => Target_Root); + end if; + + P := Target_Root; + + X := Left (Source_Root); + while X /= null loop + declare + Y : constant Node_Access := Copy_Node (X); + begin + Set_Left (Node => P, Left => Y); + Set_Parent (Node => Y, Parent => P); + + if Right (X) /= null then + Set_Right + (Node => Y, + Right => Generic_Copy_Tree (Right (X))); + + Set_Parent + (Node => Right (Y), + Parent => Y); + end if; + + P := Y; + X := Left (X); + end; + end loop; + + return Target_Root; + exception + when others => + Delete_Tree (Target_Root); + raise; + + end Generic_Copy_Tree; + + ------------------------- + -- Generic_Delete_Tree -- + ------------------------- + + procedure Generic_Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := Right (X); + Generic_Delete_Tree (Y); + Y := Left (X); + Free (X); + X := Y; + end loop; + end Generic_Delete_Tree; + ------------------- -- Generic_Equal -- ------------------- @@ -490,13 +614,17 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is R_Node : Node_Access; begin + if Left'Address = Right'Address then + return True; + end if; + if Left.Length /= Right.Length then return False; end if; L_Node := Left.First; R_Node := Right.First; - while L_Node /= Null_Node loop + while L_Node /= null loop if not Is_Equal (L_Node, R_Node) then return False; end if; @@ -522,7 +650,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Iterate (P : Node_Access) is X : Node_Access := P; begin - while X /= Null_Node loop + while X /= null loop Iterate (Left (X)); Process (X); X := Right (X); @@ -536,23 +664,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is end Generic_Iteration; ------------------ - -- Generic_Read -- + -- Generic_Move -- ------------------ - procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is + procedure Generic_Move (Target, Source : in out Tree_Type) is + begin + if Target'Address = Source'Address then + return; + end if; - pragma Assert (Tree.Length = 0); - -- Clear and back node reinit was done by caller + if Source.Busy > 0 then + raise Program_Error; + end if; + + Clear (Target); + + Target := Source; + + Source := (First => null, + Last => null, + Root => null, + Length => 0, + Busy => 0, + Lock => 0); + end Generic_Move; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : access Root_Stream_Type'Class; + Tree : in out Tree_Type) + is + N : Count_Type'Base; Node, Last_Node : Node_Access; begin + Clear (Tree); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + if N = 0 then return; end if; - Node := New_Node; - pragma Assert (Node /= Null_Node); + Node := Read_Node (Stream); + pragma Assert (Node /= null); pragma Assert (Color (Node) = Red); Set_Color (Node, Black); @@ -567,8 +727,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Last_Node := Node; pragma Assert (Last_Node = Tree.Last); - Node := New_Node; - pragma Assert (Node /= Null_Node); + Node := Read_Node (Stream); + pragma Assert (Node /= null); pragma Assert (Color (Node) = Red); Set_Right (Node => Last_Node, Right => Node); @@ -594,7 +754,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Iterate (P : Node_Access) is X : Node_Access := P; begin - while X /= Null_Node loop + while X /= null loop Iterate (Right (X)); Process (X); X := Left (X); @@ -607,6 +767,36 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Iterate (Tree.Root); end Generic_Reverse_Iteration; + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : access Root_Stream_Type'Class; + Tree : in Tree_Type) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Write_Node (Stream, Node); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + ----------------- -- Left_Rotate -- ----------------- @@ -616,12 +806,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is -- CLR p266 ??? Y : constant Node_Access := Right (X); - pragma Assert (Y /= Null_Node); + pragma Assert (Y /= null); begin Set_Right (X, Left (Y)); - if Left (Y) /= Null_Node then + if Left (Y) /= null then Set_Parent (Left (Y), X); end if; @@ -655,7 +845,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is loop Y := Right (X); - if Y = Null_Node then + if Y = null then return X; end if; @@ -678,7 +868,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is loop Y := Left (X); - if Y = Null_Node then + if Y = null then return X; end if; @@ -687,23 +877,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is end Min; ---------- - -- Move -- - ---------- - - procedure Move (Target, Source : in out Tree_Type) is - begin - if Target.Length > 0 then - raise Constraint_Error; - end if; - - Target := Source; - Source := (First => Null_Node, - Last => Null_Node, - Root => Null_Node, - Length => 0); - end Move; - - ---------- -- Next -- ---------- @@ -711,11 +884,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is begin -- CLR p249 ??? - if Node = Null_Node then - return Null_Node; + if Node = null then + return null; end if; - if Right (Node) /= Null_Node then + if Right (Node) /= null then return Min (Right (Node)); end if; @@ -724,7 +897,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Y : Node_Access := Parent (Node); begin - while Y /= Null_Node + while Y /= null and then X = Right (Y) loop X := Y; @@ -749,11 +922,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Previous (Node : Node_Access) return Node_Access is begin - if Node = Null_Node then - return Null_Node; + if Node = null then + return null; end if; - if Left (Node) /= Null_Node then + if Left (Node) /= null then return Max (Left (Node)); end if; @@ -762,7 +935,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Y : Node_Access := Parent (Node); begin - while Y /= Null_Node + while Y /= null and then X = Left (Y) loop X := Y; @@ -792,7 +965,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is -- CLR p.268 ??? X : Node_Access := Node; - pragma Assert (X /= Null_Node); + pragma Assert (X /= null); pragma Assert (Color (X) = Red); Y : Node_Access; @@ -802,7 +975,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is if Parent (X) = Left (Parent (Parent (X))) then Y := Right (Parent (Parent (X))); - if Y /= Null_Node and then Color (Y) = Red then + if Y /= null and then Color (Y) = Red then Set_Color (Parent (X), Black); Set_Color (Y, Black); Set_Color (Parent (Parent (X)), Red); @@ -824,7 +997,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Y := Left (Parent (Parent (X))); - if Y /= Null_Node and then Color (Y) = Red then + if Y /= null and then Color (Y) = Red then Set_Color (Parent (X), Black); Set_Color (Y, Black); Set_Color (Parent (Parent (X)), Red); @@ -852,12 +1025,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is X : constant Node_Access := Left (Y); - pragma Assert (X /= Null_Node); + pragma Assert (X /= null); begin Set_Left (Y, Right (X)); - if Right (X) /= Null_Node then + if Right (X) /= null then Set_Parent (Right (X), Y); end if; diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads index 3e13ae5..84ab260 100644 --- a/gcc/ada/a-crbtgo.ads +++ b/gcc/ada/a-crbtgo.ads @@ -2,23 +2,44 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- +-- G E N E R I C _ O P E R A T I O N S -- -- -- -- S p e c -- -- -- --- This specification is adapted from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Streams; use Ada.Streams; + generic with package Tree_Types is new Generic_Tree_Types (<>); use Tree_Types; - Null_Node : Node_Access; - with function Parent (Node : Node_Access) return Node_Access is <>; with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; with function Left (Node : Node_Access) return Node_Access is <>; @@ -41,8 +62,6 @@ pragma Pure; function Previous (Node : Node_Access) return Node_Access; - procedure Move (Target, Source : in out Tree_Type); - generic with function Is_Equal (L, R : Node_Access) return Boolean; function Generic_Equal (Left, Right : Tree_Type) return Boolean; @@ -52,6 +71,27 @@ pragma Pure; Node : Node_Access); generic + with procedure Free (X : in out Node_Access); + procedure Generic_Delete_Tree (X : in out Node_Access); + + generic + with function Copy_Node (Source : Node_Access) return Node_Access; + with procedure Delete_Tree (X : in out Node_Access); + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access; + + generic + with function Copy_Tree (Root : Node_Access) return Node_Access; + procedure Generic_Adjust (Tree : in out Tree_Type); + + generic + with procedure Delete_Tree (X : in out Node_Access); + procedure Generic_Clear (Tree : in out Tree_Type); + + generic + with procedure Clear (Tree : in out Tree_Type); + procedure Generic_Move (Target, Source : in out Tree_Type); + + generic with procedure Process (Node : Node_Access) is <>; procedure Generic_Iteration (Tree : Tree_Type); @@ -60,8 +100,20 @@ pragma Pure; procedure Generic_Reverse_Iteration (Tree : Tree_Type); generic - with function New_Node return Node_Access is <>; - procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type); + with procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + procedure Generic_Write + (Stream : access Root_Stream_Type'Class; + Tree : Tree_Type); + + generic + with procedure Clear (Tree : in out Tree_Type); + with function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + procedure Generic_Read + (Stream : access Root_Stream_Type'Class; + Tree : in out Tree_Type); procedure Rebalance_For_Insert (Tree : in out Tree_Type; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb index d775234..2c0b39f 100644 --- a/gcc/ada/a-rbtgso.adb +++ b/gcc/ada/a-rbtgso.adb @@ -2,11 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S . -- +-- G E N E R I C _ S E T _ O P E R A T I O N S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,8 +34,57 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with System; use type System.Address; + package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Clear (Tree : in out Tree_Type); + + function Copy (Source : Tree_Type) return Tree_Type; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Tree : in out Tree_Type) is + pragma Assert (Tree.Busy = 0); + pragma Assert (Tree.Lock = 0); + + Root : Node_Access := Tree.Root; + + begin + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Delete_Tree (Root); + end Clear; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Tree_Type) return Tree_Type is + Target : Tree_Type; + + begin + if Source.Length = 0 then + return Target; + end if; + + Target.Root := Copy_Tree (Source.Root); + Target.First := Tree_Operations.Min (Target.Root); + Target.Last := Tree_Operations.Max (Target.Root); + Target.Length := Source.Length; + + return Target; + end Copy; + ---------------- -- Difference -- ---------------- @@ -44,19 +94,29 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Src : Node_Access := Source.First; begin + if Target'Address = Source'Address then + if Target.Busy > 0 then + raise Program_Error; + end if; + + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; - -- NOTE: must be done by client: - -- if Target'Address = Source'Address then - -- Clear (Target); - -- return; - -- end if; + if Target.Busy > 0 then + raise Program_Error; + end if; loop - if Tgt = Tree_Operations.Null_Node then + if Tgt = null then return; end if; - if Src = Tree_Operations.Null_Node then + if Src = null then return; end if; @@ -81,7 +141,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Difference; function Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + Tree : Tree_Type; L_Node : Node_Access := Left.First; R_Node : Node_Access := Right.First; @@ -89,21 +149,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Dst_Node : Node_Access; begin - -- NOTE: must by done by client: - -- if Left'Address = Right'Address then - -- return Empty_Set; - -- end if; + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Left.Length = 0 then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; loop - if L_Node = Tree_Operations.Null_Node then + if L_Node = null then return Tree; end if; - if R_Node = Tree_Operations.Null_Node then - while L_Node /= Tree_Operations.Null_Node loop + if R_Node = null then + while L_Node /= null loop Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => L_Node, Dst_Node => Dst_Node); @@ -117,7 +184,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => L_Node, Dst_Node => Dst_Node); @@ -150,13 +217,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Src : Node_Access := Source.First; begin - -- NOTE: must be done by caller: ??? - -- if Target'Address = Source'Address then - -- return; - -- end if; + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; - while Tgt /= Tree_Operations.Null_Node - and then Src /= Tree_Operations.Null_Node + while Tgt /= null + and then Src /= null loop if Is_Less (Tgt, Src) then declare @@ -175,10 +250,20 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Src := Tree_Operations.Next (Src); end if; end loop; + + while Tgt /= null loop + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + end loop; end Intersection; function Intersection (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + Tree : Tree_Type; L_Node : Node_Access := Left.First; R_Node : Node_Access := Right.First; @@ -186,17 +271,16 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Dst_Node : Node_Access; begin - -- NOTE: must be done by caller: ??? - -- if Left'Address = Right'Address then - -- return Left; - -- end if; + if Left'Address = Right'Address then + return Copy (Left); + end if; loop - if L_Node = Tree_Operations.Null_Node then + if L_Node = null then return Tree; end if; - if R_Node = Tree_Operations.Null_Node then + if R_Node = null then return Tree; end if; @@ -209,7 +293,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is else Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => L_Node, Dst_Node => Dst_Node); @@ -233,10 +317,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Of_Set : Tree_Type) return Boolean is begin - -- NOTE: must by done by caller: - -- if Subset'Address = Of_Set'Address then - -- return True; - -- end if; + if Subset'Address = Of_Set'Address then + return True; + end if; if Subset.Length > Of_Set.Length then return False; @@ -244,15 +327,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is declare Subset_Node : Node_Access := Subset.First; - Set_Node : Node_Access := Of_Set.First; + Set_Node : Node_Access := Of_Set.First; begin loop - if Set_Node = Tree_Operations.Null_Node then - return Subset_Node = Tree_Operations.Null_Node; + if Set_Node = null then + return Subset_Node = null; end if; - if Subset_Node = Tree_Operations.Null_Node then + if Subset_Node = null then return True; end if; @@ -279,14 +362,13 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is R_Node : Node_Access := Right.First; begin - -- NOTE: must be done by caller: ??? - -- if Left'Address = Right'Address then - -- return Left.Tree.Length /= 0; - -- end if; + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; loop - if L_Node = Tree_Operations.Null_Node - or else R_Node = Tree_Operations.Null_Node + if L_Node = null + or else R_Node = null then return False; end if; @@ -317,18 +399,21 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is New_Tgt_Node : Node_Access; begin - -- NOTE: must by done by client: ??? - -- if Target'Address = Source'Address then - -- Clear (Target); - -- return; - -- end if; + if Target.Busy > 0 then + raise Program_Error; + end if; + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; loop - if Tgt = Tree_Operations.Null_Node then - while Src /= Tree_Operations.Null_Node loop + if Tgt = null then + while Src /= null loop Insert_With_Hint (Dst_Tree => Target, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => Src, Dst_Node => New_Tgt_Node); @@ -338,7 +423,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return; end if; - if Src = Tree_Operations.Null_Node then + if Src = null then return; end if; @@ -369,7 +454,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is end Symmetric_Difference; function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + Tree : Tree_Type; L_Node : Node_Access := Left.First; R_Node : Node_Access := Right.First; @@ -377,17 +462,24 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is Dst_Node : Node_Access; begin - -- NOTE: must by done by caller ??? - -- if Left'Address = Right'Address then - -- return Empty_Set; - -- end if; + if Left'Address = Right'Address then + return Tree; -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; loop - if L_Node = Tree_Operations.Null_Node then - while R_Node /= Tree_Operations.Null_Node loop + if L_Node = null then + while R_Node /= null loop Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => R_Node, Dst_Node => Dst_Node); R_Node := Tree_Operations.Next (R_Node); @@ -396,11 +488,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is return Tree; end if; - if R_Node = Tree_Operations.Null_Node then - while L_Node /= Tree_Operations.Null_Node loop + if R_Node = null then + while L_Node /= null loop Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => L_Node, Dst_Node => Dst_Node); @@ -413,7 +505,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is if Is_Less (L_Node, R_Node) then Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => L_Node, Dst_Node => Dst_Node); @@ -422,7 +514,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is elsif Is_Less (R_Node, L_Node) then Insert_With_Hint (Dst_Tree => Tree, - Dst_Hint => Tree_Operations.Null_Node, + Dst_Hint => null, Src_Node => R_Node, Dst_Node => Dst_Node); @@ -469,33 +561,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is -- Start of processing for Union begin - -- NOTE: must be done by caller: ??? - -- if Target'Address = Source'Address then - -- return; - -- end if; + if Target'Address = Source'Address then + return; + end if; + + if Target.Busy > 0 then + raise Program_Error; + end if; Iterate (Source); end Union; function Union (Left, Right : Tree_Type) return Tree_Type is - Tree : Tree_Type; - begin - -- NOTE: must be done by caller: - -- if Left'Address = Right'Address then - -- return Left; - -- end if; + if Left'Address = Right'Address then + return Copy (Left); + end if; - declare - Root : constant Node_Access := Copy_Tree (Left.Root); - begin - Tree := (Root => Root, - First => Tree_Operations.Min (Root), - Last => Tree_Operations.Max (Root), - Length => Left.Length); - end; + if Left.Length = 0 then + return Copy (Right); + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; declare + Tree : Tree_Type := Copy (Left); + Hint : Node_Access; procedure Process (Node : Node_Access); @@ -521,6 +614,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is begin Iterate (Right); + return Tree; exception when others => @@ -528,7 +622,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is raise; end; - return Tree; end Union; end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-shcain.adb b/gcc/ada/a-shcain.adb index 1c6e78f..95d8936 100644 --- a/gcc/ada/a-shcain.adb +++ b/gcc/ada/a-shcain.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.HASH_CASE_INSENSITIVE -- +-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -52,17 +52,8 @@ is begin Tmp := 0; for J in Key'Range loop - Tmp := Rotate_Left (Tmp, 1) + Character'Pos (To_Lower (Key (J))); + Tmp := Rotate_Left (Tmp, 3) + Character'Pos (To_Lower (Key (J))); end loop; return Tmp; end Ada.Strings.Hash_Case_Insensitive; - - - - - - - - - diff --git a/gcc/ada/a-shcain.ads b/gcc/ada/a-shcain.ads index 24bd62c..a6e083c 100644 --- a/gcc/ada/a-shcain.ads +++ b/gcc/ada/a-shcain.ads @@ -2,7 +2,7 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.HASH_CASE_INSENSITIVE -- +-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- -- -- -- S p e c -- -- -- diff --git a/gcc/ada/a-strhas.adb b/gcc/ada/a-strhas.adb index 3dffb20..62c4610 100644 --- a/gcc/ada/a-strhas.adb +++ b/gcc/ada/a-strhas.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.HASH -- +-- A D A . S T R I N G S . H A S H -- -- -- --- B o d y -- +-- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -48,16 +48,8 @@ function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is begin Tmp := 0; for J in Key'Range loop - Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J)); + Tmp := Rotate_Left (Tmp, 3) + Character'Pos (Key (J)); end loop; return Tmp; end Ada.Strings.Hash; - - - - - - - - diff --git a/gcc/ada/a-stunha.adb b/gcc/ada/a-stunha.adb index a6b6920..1f8d6bc 100644 --- a/gcc/ada/a-stunha.adb +++ b/gcc/ada/a-stunha.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.UNBOUNDED.HASH -- +-- A D A . S T R I N G S . U N B O U N D E D . H A S H -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -50,7 +50,7 @@ is begin Tmp := 0; for J in 1 .. Key.Last loop - Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key.Reference (J)); + Tmp := Rotate_Left (Tmp, 3) + Character'Pos (Key.Reference (J)); end loop; return Tmp; diff --git a/gcc/ada/a-stwiha.adb b/gcc/ada/a-stwiha.adb index f218b48..17ccfb8 100644 --- a/gcc/ada/a-stwiha.adb +++ b/gcc/ada/a-stwiha.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.WIDE_HASH -- +-- A D A . S T R I N G S . W I D E _ H A S H -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -50,10 +50,8 @@ is begin Tmp := 0; for J in Key'Range loop - Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key (J)); + Tmp := Rotate_Left (Tmp, 3) + Wide_Character'Pos (Key (J)); end loop; return Tmp; end Ada.Strings.Wide_Hash; - - diff --git a/gcc/ada/a-stwiha.ads b/gcc/ada/a-stwiha.ads index 349b891..3b0af1f 100644 --- a/gcc/ada/a-stwiha.ads +++ b/gcc/ada/a-stwiha.ads @@ -2,7 +2,7 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.WIDE_HASH -- +-- A D A . S T R I N G S . W I D E _ H A S H -- -- -- -- S p e c -- -- -- @@ -19,6 +19,3 @@ function Ada.Strings.Wide_Hash (Key : Wide_String) return Containers.Hash_Type; pragma Pure (Ada.Strings.Wide_Hash); - - - diff --git a/gcc/ada/a-stzhas.adb b/gcc/ada/a-stzhas.adb index b6fa3a9..9c1b752 100644 --- a/gcc/ada/a-stzhas.adb +++ b/gcc/ada/a-stzhas.adb @@ -50,10 +50,8 @@ is begin Tmp := 0; for J in Key'Range loop - Tmp := Rotate_Left (Tmp, 1) + Wide_Wide_Character'Pos (Key (J)); + Tmp := Rotate_Left (Tmp, 3) + Wide_Wide_Character'Pos (Key (J)); end loop; return Tmp; end Ada.Strings.Wide_Wide_Hash; - - diff --git a/gcc/ada/a-swunha.adb b/gcc/ada/a-swuwha.adb index 8229494..77912e7 100644 --- a/gcc/ada/a-swunha.adb +++ b/gcc/ada/a-swuwha.adb @@ -2,11 +2,11 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.WIDE_UNBOUNDED.HASH -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- -- -- -- B o d y -- -- -- --- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,7 +35,7 @@ -- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) -function Ada.Strings.Wide_Unbounded.Hash +function Ada.Strings.Wide_Unbounded.Wide_Hash (Key : Unbounded_Wide_String) return Containers.Hash_Type is use Ada.Containers; @@ -50,8 +50,8 @@ is begin Tmp := 0; for J in 1 .. Key.Last loop - Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key.Reference (J)); + Tmp := Rotate_Left (Tmp, 3) + Wide_Character'Pos (Key.Reference (J)); end loop; return Tmp; -end Ada.Strings.Wide_Unbounded.Hash; +end Ada.Strings.Wide_Unbounded.Wide_Hash; diff --git a/gcc/ada/a-swunha.ads b/gcc/ada/a-swuwha.ads index 267392f..078094a 100644 --- a/gcc/ada/a-swunha.ads +++ b/gcc/ada/a-swuwha.ads @@ -2,10 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- ADA.STRINGS.WIDE_UNBOUNDED.HASH -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- -- -- -- S p e c -- -- -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- -- copy and modify this specification, provided that if you redistribute a -- @@ -15,7 +17,7 @@ with Ada.Containers; -function Ada.Strings.Wide_Unbounded.Hash +function Ada.Strings.Wide_Unbounded.Wide_Hash (Key : Unbounded_Wide_String) return Containers.Hash_Type; -pragma Preelaborate (Ada.Strings.Wide_Unbounded.Hash); +pragma Preelaborate (Ada.Strings.Wide_Unbounded.Wide_Hash); diff --git a/gcc/ada/a-szunha.adb b/gcc/ada/a-szuzha.adb index 68e6056..2f3df5e 100644 --- a/gcc/ada/a-szunha.adb +++ b/gcc/ada/a-szuzha.adb @@ -2,7 +2,7 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- -- -- -- B o d y -- -- -- @@ -35,7 +35,7 @@ -- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) -function Ada.Strings.Wide_Wide_Unbounded.Hash +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type is use Ada.Containers; @@ -50,9 +50,9 @@ is begin Tmp := 0; for J in 1 .. Key.Last loop - Tmp := Rotate_Left (Tmp, 1) + + Tmp := Rotate_Left (Tmp, 3) + Wide_Wide_Character'Pos (Key.Reference (J)); end loop; return Tmp; -end Ada.Strings.Wide_Wide_Unbounded.Hash; +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash; diff --git a/gcc/ada/a-szunha.ads b/gcc/ada/a-szuzha.ads index e1b8721..2aaf66b 100644 --- a/gcc/ada/a-szunha.ads +++ b/gcc/ada/a-szuzha.ads @@ -2,10 +2,12 @@ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- -- -- -- S p e c -- -- -- +-- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- -- -- This specification is adapted from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- -- copy and modify this specification, provided that if you redistribute a -- @@ -15,7 +17,7 @@ with Ada.Containers; -function Ada.Strings.Wide_Wide_Unbounded.Hash +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type; -pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Hash); +pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash); |