diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-10-31 18:13:22 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2006-10-31 18:13:22 +0000 |
| commit | d9e74e050bd1ae08f4be72f63784a42c0973a94a (patch) | |
| tree | 1a5cb845f084a8360d6f2bc2dd674427a1a51b02 /gcc | |
| parent | ad67c992e9102a7a00351747f46956e56b6f0c3f (diff) | |
| download | gcc-d9e74e050bd1ae08f4be72f63784a42c0973a94a.tar.gz | |
2006-10-31 Matt Heaney <heaney@adacore.com>
* a-crbtgo.ads: Commented each subprogram
* a-crbtgo.adb: Added reference to book from which algorithms were
adapted.
* a-crbtgk.ads, a-crbtgk.adb (Generic_Insert_Post): pass flag to
indicate which child.
(Generic_Conditional_Insert): changed parameter name from "Success" to
"Inserted".
(Generic_Unconditional_Insert_With_Hint): improved algorithm
* a-coorse.adb (Replace_Element): changed parameter name in call to
conditional insert operation.
* a-convec.adb, a-coinve.adb (Insert): removed obsolete comment
* a-cohama.adb (Iterate): manipulate busy-bit here, instead of in
Generic_Iteration
* a-ciorse.adb (Replace_Element): changed parameter name in call to
conditional insert operation.
* a-cihama.adb (Iterate): manipulate busy-bit here, instead of in
Generic_Iteration.
* a-cidlli.ads, a-cidlli.adb (Splice): Position param is now mode in
instead of mode inout.
* a-chtgop.adb (Adjust): modified comments to reflect current AI-302
draft
(Generic_Read): preserve existing buckets array if possible
(Generic_Write): don't send buckets array length anymore
* a-cdlili.ads, a-cdlili.adb (Splice): Position param is now mode in
instead of mode inout.
* a-cihase.adb (Difference): iterate over smaller of Tgt and Src sets
(Iterate): manipulate busy-bit here, instead of in Generic_Iteration
* a-cohase.adb (Difference): iterate over smaller of Tgt and Src sets
(Iterate): manipulate busy-bit here, instead of in Generic_Iteration
(Replace_Element): local operation is now an instantiation
* a-chtgke.ads, a-chtgke.adb (Generic_Conditional_Insert): manually
check current length.
(Generic_Replace_Element): new operation
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@118324 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/a-cdlili.adb | 245 | ||||
| -rw-r--r-- | gcc/ada/a-cdlili.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/a-chtgke.adb | 127 | ||||
| -rw-r--r-- | gcc/ada/a-chtgke.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/a-chtgop.adb | 189 | ||||
| -rw-r--r-- | gcc/ada/a-cidlli.adb | 273 | ||||
| -rw-r--r-- | gcc/ada/a-cidlli.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/a-cihama.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.adb | 215 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 163 | ||||
| -rw-r--r-- | gcc/ada/a-cohama.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.adb | 207 | ||||
| -rw-r--r-- | gcc/ada/a-coinve.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/a-convec.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 147 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgk.adb | 347 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgk.ads | 127 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgo.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/a-crbtgo.ads | 47 |
19 files changed, 1098 insertions, 1163 deletions
diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index af83a6db73b..611bfb09b5d 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -8,10 +8,6 @@ -- -- -- Copyright (C) 2004-2006, 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- -- @@ -156,7 +152,8 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; while Container.Length > 1 loop @@ -206,11 +203,13 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -227,7 +226,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for Index in 1 .. Count loop @@ -276,7 +276,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for I in 1 .. Count loop @@ -313,7 +314,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for I in 1 .. Count loop @@ -336,7 +338,8 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Element"); @@ -361,7 +364,8 @@ package body Ada.Containers.Doubly_Linked_Lists is else if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Find"); @@ -398,7 +402,7 @@ package body Ada.Containers.Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin if Container.First = null then - raise Constraint_Error; + raise Constraint_Error with "list is empty"; end if; return Container.First.Element; @@ -451,20 +455,25 @@ package body Ada.Containers.Doubly_Linked_Lists is (Target : in out List; Source : in out List) is - LI : Cursor := First (Target); - RI : Cursor := First (Source); + LI, RI : Cursor; begin if Target'Address = Source'Address then return; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; + LI := First (Target); + RI := First (Source); while RI.Node /= null loop pragma Assert (RI.Node.Next = null or else not (RI.Node.Next.Element < @@ -578,7 +587,8 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; Sort (Front => null, Back => null); @@ -615,7 +625,8 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then if Before.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; pragma Assert (Vet (Before), "bad cursor in Insert"); @@ -627,11 +638,12 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Length > Count_Type'Last - Count then - raise Constraint_Error; + raise Constraint_Error with "new length exceeds maximum"; end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; New_Node := new Node_Type'(New_Item, null, null); @@ -667,7 +679,8 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then if Before.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong list"; end if; pragma Assert (Vet (Before), "bad cursor in Insert"); @@ -679,11 +692,12 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Length > Count_Type'Last - Count then - raise Constraint_Error; + raise Constraint_Error with "new length exceeds maximum"; end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; New_Node := new Node_Type; @@ -804,7 +818,7 @@ package body Ada.Containers.Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin if Container.Last = null then - raise Constraint_Error; + raise Constraint_Error with "list is empty"; end if; return Container.Last.Element; @@ -833,7 +847,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; Clear (Target); @@ -854,27 +869,17 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Next (Position : in out Cursor) is begin - pragma Assert (Vet (Position), "bad cursor in procedure Next"); - - if Position.Node = null then - return; - end if; - - Position.Node := Position.Node.Next; - - if Position.Node = null then - Position.Container := null; - end if; + Position := Next (Position); end Next; function Next (Position : Cursor) return Cursor is begin - pragma Assert (Vet (Position), "bad cursor in function Next"); - if Position.Node = null then return No_Element; end if; + pragma Assert (Vet (Position), "bad cursor in Next"); + declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -905,27 +910,17 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Previous (Position : in out Cursor) is begin - pragma Assert (Vet (Position), "bad cursor in procedure Previous"); - - if Position.Node = null then - return; - end if; - - Position.Node := Position.Node.Prev; - - if Position.Node = null then - Position.Container := null; - end if; + Position := Previous (Position); end Previous; function Previous (Position : Cursor) return Cursor is begin - pragma Assert (Vet (Position), "bad cursor in function Previous"); - if Position.Node = null then return No_Element; end if; + pragma Assert (Vet (Position), "bad cursor in Previous"); + declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -947,7 +942,8 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Query_Element"); @@ -980,7 +976,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ---------- procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out List) is N : Count_Type'Base; @@ -1028,11 +1024,11 @@ package body Ada.Containers.Doubly_Linked_Lists is end Read; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream list cursor"; end Read; --------------------- @@ -1046,15 +1042,17 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; end if; pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1121,7 +1119,8 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; Container.First := J; @@ -1165,7 +1164,8 @@ package body Ada.Containers.Doubly_Linked_Lists is else if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); @@ -1225,7 +1225,8 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad cursor in Splice"); @@ -1241,13 +1242,17 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Source.Last.Next = null); if Target.Length > Count_Type'Last - Source.Length then - raise Constraint_Error; + raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; if Target.Length = 0 then @@ -1294,23 +1299,25 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Splice (Container : in out List; Before : Cursor; - Position : in out Cursor) + Position : Cursor) is begin if Before.Container /= null then if Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); @@ -1324,7 +1331,8 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; if Before.Node = null then @@ -1404,30 +1412,36 @@ package body Ada.Containers.Doubly_Linked_Lists is if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Source'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); if Target.Length = Count_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "Target is full"; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; if Position.Node = Source.First then @@ -1504,16 +1518,20 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null - or else J.Node = null - then - raise Constraint_Error; + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access - or else J.Container /= Container'Unchecked_Access - then - raise Program_Error; + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if J.Container /= Container'Unchecked_Access then + raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then @@ -1521,7 +1539,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap"); @@ -1548,16 +1567,20 @@ package body Ada.Containers.Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null - or else J.Node = null - then - raise Constraint_Error; + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access - or else I.Container /= J.Container - then - raise Program_Error; + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then @@ -1565,7 +1588,8 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap_Links"); @@ -1573,26 +1597,24 @@ package body Ada.Containers.Doubly_Linked_Lists is declare I_Next : constant Cursor := Next (I); - J_Copy : Cursor := J; begin if I_Next = J then - Splice (Container, Before => I, Position => J_Copy); + Splice (Container, Before => I, Position => J); else declare J_Next : constant Cursor := Next (J); - I_Copy : Cursor := I; begin if J_Next = I then - Splice (Container, Before => J, Position => I_Copy); + Splice (Container, Before => J, Position => I); else pragma Assert (Container.Length >= 3); - Splice (Container, Before => I_Next, Position => J_Copy); - Splice (Container, Before => J_Next, Position => I_Copy); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); end if; end; end if; @@ -1610,11 +1632,12 @@ package body Ada.Containers.Doubly_Linked_Lists is is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Update_Element"); @@ -1785,7 +1808,7 @@ package body Ada.Containers.Doubly_Linked_Lists is ----------- procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : List) is Node : Node_Access := Item.First; @@ -1800,11 +1823,11 @@ package body Ada.Containers.Doubly_Linked_Lists is end Write; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream list cursor"; end Write; end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 41f8606079b..c5d81f78532 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2006, 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 -- @@ -46,8 +46,10 @@ package Ada.Containers.Doubly_Linked_Lists is pragma Preelaborate; type List is tagged private; + pragma Preelaborable_Initialization (List); type Cursor is private; + pragma Preelaborable_Initialization (Cursor); Empty_List : constant List; @@ -147,7 +149,7 @@ package Ada.Containers.Doubly_Linked_Lists is procedure Splice (Container : in out List; Before : Cursor; - Position : in out Cursor); + Position : Cursor); function First (Container : List) return Cursor; @@ -230,13 +232,13 @@ private use Ada.Streams; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out List); for List'Read use Read; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : List); for List'Write use Write; @@ -253,13 +255,13 @@ private end record; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out Cursor); for Cursor'Read use Read; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : Cursor); for Cursor'Write use Write; diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index 5203890a594..ba6ae2376f4 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -7,11 +7,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -131,23 +127,21 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is Indx : constant Hash_Type := Index (HT, Key); B : Node_Access renames HT.Buckets (Indx); - subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1; - begin 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); - Inserted := True; + if HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; - B := Node; - HT.Length := Length + 1; - end; + Node := New_Node (Next => null); + Inserted := True; + + B := Node; + HT.Length := HT.Length + 1; return; end if; @@ -168,15 +162,15 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is raise Program_Error; end if; - declare - Length : constant Length_Subtype := HT.Length; - begin - Node := New_Node (Next => B); - Inserted := True; + if HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; - B := Node; - HT.Length := Length + 1; - end; + Node := New_Node (Next => B); + Inserted := True; + + B := Node; + HT.Length := HT.Length + 1; end Generic_Conditional_Insert; ----------- @@ -190,4 +184,91 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is return Hash (Key) mod HT.Buckets'Length; end Index; + --------------------- + -- Replace_Element -- + --------------------- + + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Key : Key_Type) + is + begin + pragma Assert (HT.Length > 0); + + if Equivalent_Keys (Key, Node) then + pragma Assert (Hash (Key) = Hash (Node)); + + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is locked)"; + end if; + + Assign (Node, Key); + return; + end if; + + declare + J : Hash_Type; + K : constant Hash_Type := Index (HT, Key); + B : Node_Access renames HT.Buckets (K); + N : Node_Access := B; + M : Node_Access; + + begin + while N /= null loop + if Equivalent_Keys (Key, N) then + raise Program_Error with + "attempt to replace existing element"; + end if; + + N := Next (N); + end loop; + + J := Hash (Node); + + if J = K then + if HT.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (container is locked)"; + end if; + + Assign (Node, Key); + return; + end if; + + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (container is busy)"; + end if; + + Assign (Node, Key); + + N := HT.Buckets (J); + pragma Assert (N /= null); + + if N = Node then + HT.Buckets (J) := Next (Node); + + else + pragma Assert (HT.Length > 1); + + loop + M := Next (N); + pragma Assert (M /= null); + + if M = Node then + Set_Next (Node => N, Next => Next (Node)); + exit; + end if; + + N := M; + end loop; + end if; + + Set_Next (Node => Node, Next => B); + B := Node; + end; + end Generic_Replace_Element; + end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads index de91de72c07..259b0126df2 100644 --- a/gcc/ada/a-chtgke.ads +++ b/gcc/ada/a-chtgke.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2006, 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,15 +67,22 @@ package Ada.Containers.Hash_Tables.Generic_Keys is Key : Key_Type; X : out Node_Access); - function Find (HT : Hash_Table_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; + with function New_Node (Next : Node_Access) return Node_Access; procedure Generic_Conditional_Insert (HT : in out Hash_Table_Type; Key : Key_Type; Node : out Node_Access; Inserted : out Boolean); + generic + with function Hash (Node : Node_Access) return Hash_Type; + with procedure Assign (Node : Node_Access; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Key : Key_Type); + end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index 137b27c0061..c22be825a48 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2006, 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- -- @@ -30,8 +30,6 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- This body needs commenting ??? - with Ada.Containers.Prime_Numbers; with Ada.Unchecked_Deallocation; @@ -60,40 +58,15 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; + -- Technically it isn't necessary to allocate the exact same length + -- buckets array, because our only requirement is that following + -- assignment the source and target containers compare equal (that is, + -- operator "=" returns True). We can satisfy this requirement with any + -- hash table length, but we decide here to match the length of the + -- source table. This has the benefit that when iterating, elements of + -- the target are delivered in the exact same order as for the source. + 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 - - -- Dst := Src; - -- Dst = Src is true - - -- The only quirk is that we depend on the hash value of a dst key - -- to be the same as the src key from which it was copied. - -- 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); @@ -102,7 +75,7 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is declare Dst_Node : constant Node_Access := Copy_Node (Src_Node); - -- See note above + -- See note above pragma Assert (Index (HT, Dst_Node) = Src_Index); @@ -353,32 +326,20 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is ----------------------- procedure Generic_Iteration (HT : Hash_Table_Type) is - Busy : Natural renames HT'Unrestricted_Access.all.Busy; + Node : Node_Access; begin if HT.Length = 0 then return; end if; - 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; + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= null loop + Process (Node); + Node := Next (Node); end loop; - exception - when others => - Busy := Busy - 1; - raise; - end; - - Busy := Busy - 1; + end loop; end Generic_Iteration; ------------------ @@ -389,71 +350,41 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is (Stream : access Root_Stream_Type'Class; HT : out Hash_Table_Type) is - X, Y : Node_Access; - - Last, I : Hash_Type; - N, M : Count_Type'Base; + N : Count_Type'Base; + NN : Hash_Type; begin Clear (HT); - Hash_Type'Read (Stream, Last); - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); + + if N < 0 then + raise Program_Error; + end if; if N = 0 then return; end if; if HT.Buckets = null - or else HT.Buckets'Last /= Last + or else HT.Buckets'Length < N then Free (HT.Buckets); - HT.Buckets := new Buckets_Type (0 .. Last); + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := new Buckets_Type (0 .. NN - 1); end if; - -- TODO: should we rewrite this algorithm so that it doesn't - -- depend on preserving the exactly length of the hash table - -- array? We would prefer to not have to (re)allocate a - -- buckets array (the array that HT already has might be large - -- enough), and to not have to stream the count of the number - -- of nodes in each bucket. The algorithm below is vestigial, - -- as it was written prior to the meeting in Palma, when the - -- semantics of equality were changed (and which obviated the - -- need to preserve the hash table length). - - loop - Hash_Type'Read (Stream, I); - pragma Assert (I in HT.Buckets'Range); - 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); - pragma Assert (Next (HT.Buckets (I)) = null); - - Y := HT.Buckets (I); + for J in 1 .. N loop + declare + Node : constant Node_Access := New_Node (Stream); + Indx : constant Hash_Type := Index (HT, Node); + B : Node_Access renames HT.Buckets (Indx); + begin + Set_Next (Node => Node, Next => B); + B := Node; + end; HT.Length := HT.Length + 1; - - for J in Count_Type range 2 .. M loop - X := New_Node (Stream); - pragma Assert (X /= null); - pragma Assert (Next (X) = null); - - Set_Next (Node => Y, Next => X); - Y := X; - - HT.Length := HT.Length + 1; - end loop; - - N := N - M; - - exit when N = 0; end loop; end Generic_Read; @@ -465,47 +396,23 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is (Stream : access Root_Stream_Type'Class; HT : Hash_Table_Type) is - M : Count_Type'Base; - X : Node_Access; - - begin - if HT.Buckets = null then - Hash_Type'Write (Stream, 0); - else - Hash_Type'Write (Stream, HT.Buckets'Last); - end if; + procedure Write (Node : Node_Access); + pragma Inline (Write); - Count_Type'Base'Write (Stream, HT.Length); + procedure Write is new Generic_Iteration (Write); - if HT.Length = 0 then - return; - end if; + ----------- + -- Write -- + ----------- - -- TODO: see note in Generic_Read??? - - for Indx in HT.Buckets'Range loop - X := HT.Buckets (Indx); - - if X /= null then - M := 1; - loop - X := Next (X); - exit when X = null; - M := M + 1; - end loop; - - Hash_Type'Write (Stream, Indx); - Count_Type'Base'Write (Stream, M); - - X := HT.Buckets (Indx); - for J in Count_Type range 1 .. M loop - Write (Stream, X); - X := Next (X); - end loop; + procedure Write (Node : Node_Access) is + begin + Write (Stream, Node); + end Write; - pragma Assert (X = null); - end if; - end loop; + begin + Count_Type'Base'Write (Stream, HT.Length); + Write (HT); end Generic_Write; ----------- diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index f34c9e52986..cf9cdcfc39d 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -9,10 +9,6 @@ -- -- -- Copyright (C) 2004-2006, 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- -- @@ -180,7 +176,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; while Container.Length > 1 loop @@ -230,15 +227,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Delete"); @@ -255,7 +255,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for Index in 1 .. Count loop @@ -304,7 +305,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for I in 1 .. Count loop @@ -341,7 +343,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; for I in 1 .. Count loop @@ -364,11 +367,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Element"); @@ -397,7 +402,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Find"); @@ -434,7 +440,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function First_Element (Container : List) return Element_Type is begin if Container.First = null then - raise Constraint_Error; + raise Constraint_Error with "list is empty"; end if; return Container.First.Element.all; @@ -497,18 +503,21 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Target : in out List; Source : in out List) is - LI : Cursor; - RI : Cursor; + LI, RI : Cursor; begin if Target'Address = Source'Address then return; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; LI := First (Target); @@ -624,7 +633,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; Sort (Front => null, Back => null); @@ -661,13 +671,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Before.Container /= null then if Before.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; if Before.Node = null or else Before.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Before cursor has no element"; end if; pragma Assert (Vet (Before), "bad cursor in Insert"); @@ -679,11 +691,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Length > Count_Type'Last - Count then - raise Constraint_Error; + raise Constraint_Error with "new length exceeds maximum"; end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; declare @@ -833,7 +846,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type is begin if Container.Last = null then - raise Constraint_Error; + raise Constraint_Error with "list is empty"; end if; return Container.Last.Element.all; @@ -859,7 +872,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Source.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; Clear (Target); @@ -880,27 +894,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Next (Position : in out Cursor) is begin - pragma Assert (Vet (Position), "bad cursor in procedure Next"); - - if Position.Node = null then - return; - end if; - - Position.Node := Position.Node.Next; - - if Position.Node = null then - Position.Container := null; - end if; + Position := Next (Position); end Next; function Next (Position : Cursor) return Cursor is begin - pragma Assert (Vet (Position), "bad cursor in function Next"); - if Position.Node = null then return No_Element; end if; + pragma Assert (Vet (Position), "bad cursor in Next"); + declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -931,27 +935,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Previous (Position : in out Cursor) is begin - pragma Assert (Vet (Position), "bad cursor in procedure Previous"); - - if Position.Node = null then - return; - end if; - - Position.Node := Position.Node.Prev; - - if Position.Node = null then - Position.Container := null; - end if; + Position := Previous (Position); end Previous; function Previous (Position : Cursor) return Cursor is begin - pragma Assert (Vet (Position), "bad cursor in function Previous"); - if Position.Node = null then return No_Element; end if; + pragma Assert (Vet (Position), "bad cursor in Previous"); + declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -973,11 +967,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with + "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Query_Element"); @@ -1010,7 +1006,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ---------- procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out List) is N : Count_Type'Base; @@ -1059,11 +1055,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Read; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream list cursor"; end Read; --------------------- @@ -1077,19 +1073,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Position.Container = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; - if Position.Container.Lock > 0 then - raise Program_Error; + if Container.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -1162,7 +1161,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Last.Next = null); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; Container.First := J; @@ -1206,11 +1206,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is else if Node.Element = null then - raise Program_Error; + raise Program_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); @@ -1269,13 +1270,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; if Before.Node = null or else Before.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Before cursor has no element"; end if; pragma Assert (Vet (Before), "bad cursor in Splice"); @@ -1291,13 +1294,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Source.Last.Next = null); if Target.Length > Count_Type'Last - Source.Length then - raise Constraint_Error; + raise Constraint_Error with "new length exceeds maximum"; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; if Target.Length = 0 then @@ -1343,33 +1350,36 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Splice (Container : in out List; Before : Cursor; - Position : in out Cursor) + Position : Cursor) is begin if Before.Container /= null then if Before.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; if Before.Node = null or else Before.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Before cursor has no element"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with "Position cursor has no element"; end if; if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); @@ -1383,7 +1393,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.Length >= 2); if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; if Before.Node = null then @@ -1463,40 +1474,48 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Before.Container /= null then if Before.Container /= Target'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Before cursor designates wrong container"; end if; if Before.Node = null or else Before.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Before cursor has no element"; end if; pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; if Position.Container /= Source'Unrestricted_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad Position cursor in Splice"); if Target.Length = Count_Type'Last then - raise Constraint_Error; + raise Constraint_Error with "Target is full"; end if; - if Target.Busy > 0 - or else Source.Busy > 0 - then - raise Program_Error; + if Target.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Target (list is busy)"; + end if; + + if Source.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements of Source (list is busy)"; end if; if Position.Node = Source.First then @@ -1573,16 +1592,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null - or else J.Node = null - then - raise Constraint_Error; + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unchecked_Access - or else J.Container /= Container'Unchecked_Access - then - raise Program_Error; + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if J.Container /= Container'Unchecked_Access then + raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then @@ -1590,7 +1613,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Lock > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with cursors (list is locked)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap"); @@ -1614,16 +1638,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Node = null - or else J.Node = null - then - raise Constraint_Error; + if I.Node = null then + raise Constraint_Error with "I cursor has no element"; end if; - if I.Container /= Container'Unrestricted_Access - or else I.Container /= J.Container - then - raise Program_Error; + if J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor designates wrong container"; end if; if I.Node = J.Node then @@ -1631,7 +1659,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; if Container.Busy > 0 then - raise Program_Error; + raise Program_Error with + "attempt to tamper with elements (list is busy)"; end if; pragma Assert (Vet (I), "bad I cursor in Swap_Links"); @@ -1639,26 +1668,24 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is declare I_Next : constant Cursor := Next (I); - J_Copy : Cursor := J; begin if I_Next = J then - Splice (Container, Before => I, Position => J_Copy); + Splice (Container, Before => I, Position => J); else declare J_Next : constant Cursor := Next (J); - I_Copy : Cursor := I; begin if J_Next = I then - Splice (Container, Before => J, Position => I_Copy); + Splice (Container, Before => J, Position => I); else pragma Assert (Container.Length >= 3); - Splice (Container, Before => I_Next, Position => J_Copy); - Splice (Container, Before => J_Next, Position => I_Copy); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); end if; end; end if; @@ -1679,15 +1706,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is is begin if Position.Node = null then - raise Constraint_Error; + raise Constraint_Error with "Position cursor has no element"; end if; if Position.Node.Element = null then - raise Program_Error; + raise Program_Error with + "Position cursor has no element"; end if; if Position.Container /= Container'Unchecked_Access then - raise Program_Error; + raise Program_Error with + "Position cursor designates wrong container"; end if; pragma Assert (Vet (Position), "bad cursor in Update_Element"); @@ -1862,7 +1891,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is ----------- procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : List) is Node : Node_Access := Item.First; @@ -1871,17 +1900,17 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Count_Type'Base'Write (Stream, Item.Length); while Node /= null loop - Element_Type'Output (Stream, Node.Element.all); -- X.all + Element_Type'Output (Stream, Node.Element.all); Node := Node.Next; end loop; end Write; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : Cursor) is begin - raise Program_Error; + raise Program_Error with "attempt to stream list cursor"; end Write; end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index e6fbf7694cf..ff354ccf1e2 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2006, 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 -- @@ -47,8 +47,10 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Preelaborate; type List is tagged private; + pragma Preelaborable_Initialization (List); type Cursor is private; + pragma Preelaborable_Initialization (Cursor); Empty_List : constant List; @@ -138,7 +140,7 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Splice (Container : in out List; Before : Cursor; - Position : in out Cursor); + Position : Cursor); function First (Container : List) return Cursor; @@ -223,13 +225,13 @@ private use Ada.Streams; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out List); for List'Read use Read; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : List); for List'Write use Write; @@ -246,13 +248,13 @@ private end record; procedure Read - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : out Cursor); for Cursor'Read use Read; procedure Write - (Stream : access Root_Stream_Type'Class; + (Stream : not null access Root_Stream_Type'Class; Item : Cursor); for Cursor'Write use Write; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 04c9c6b0e76..24ca33bdb2c 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -7,11 +7,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -603,7 +599,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Process_Node (Node : Node_Access); pragma Inline (Process_Node); - procedure Iterate is + procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); ------------------ @@ -615,10 +611,22 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Process (Cursor'(Container'Unchecked_Access, Node)); end Process_Node; + B : Natural renames Container'Unrestricted_Access.HT.Busy; + -- Start of processing Iterate begin - Iterate (Container.HT); + B := B + 1; + + begin + Local_Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 0bb8cb73f75..1731ea708d1 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -9,10 +9,6 @@ -- -- -- Copyright (C) 2004-2006, 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- -- @@ -52,6 +48,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Local Subprograms -- ----------------------- + procedure Assign (Node : Node_Access; Item : Element_Type); + pragma Inline (Assign); + function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); @@ -89,11 +88,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return Node_Access; pragma Inline (Read_Node); - procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type); - procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); @@ -138,6 +132,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); @@ -159,6 +156,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + X : Element_Access := Node.Element; + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end Assign; + -------------- -- Capacity -- -------------- @@ -266,7 +274,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; - if Source.Length = 0 then + if Source.HT.Length = 0 then return; end if; @@ -275,24 +283,41 @@ package body Ada.Containers.Indefinite_Hashed_Sets is "attempt to tamper with elements (set is busy)"; end if; - -- TODO: This can be written in terms of a loop instead as - -- active-iterator style, sort of like a passive iterator. + if Source.HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; - 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; + begin + Src_Node := HT_Ops.First (Source.HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); - else - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - end if; - end loop; + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Source.HT, Src_Node); + end loop; + end; + + else + 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; + + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end if; end Difference; function Difference (Left, Right : Set) return Set is @@ -757,15 +782,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is "attempt to tamper with elements (set is busy)"; 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 @@ -890,9 +906,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return False; end if; - -- TODO: rewrite this to loop in the - -- style of a passive iterator. - Subset_Node := HT_Ops.First (Subset.HT); while Subset_Node /= null loop if not Is_In (Of_Set.HT, Subset_Node) then @@ -928,15 +941,22 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + B : Natural renames Container'Unrestricted_Access.HT.Busy; -- Start of processing for Iterate begin - -- TODO: resolve whether HT_Ops.Generic_Iteration should - -- manipulate busy bit. + B := B + 1; + + begin + Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; - Iterate (HT); + B := B - 1; end Iterate; ------------ @@ -1142,117 +1162,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is --------------------- procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type) - is - begin - if Equivalent_Elements (Node.Element.all, New_Item) then - pragma Assert (Hash (Node.Element.all) = Hash (New_Item)); - - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - - declare - X : Element_Access := Node.Element; - begin - Node.Element := new Element_Type'(New_Item); -- OK if fails - Free_Element (X); - end; - - return; - end if; - - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - 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); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - ------------------------ - -- Insert_New_Element -- - ------------------------ - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Element := new Element_Type'(New_Item); -- OK if fails - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - X : Element_Access := Node.Element; - - -- Start of processing for Insert_New_Element - - begin - Attempt_Insert : begin - Insert - (HT => HT, - Key => New_Item, - Node => Result, - Inserted => Inserted); - exception - when others => - Inserted := False; -- Assignment failed - end Attempt_Insert; - - if Inserted then - Free_Element (X); -- Just propagate if fails - return; - end if; - end Insert_New_Element; - - Reinsert_Old_Element : - declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - -- Start of processing for Reinsert_Old_Element - - begin - Insert - (HT => HT, - Key => Node.Element.all, - Node => Result, - Inserted => Inserted); - exception - when others => - null; - end Reinsert_Old_Element; - - raise Program_Error with "attempt to replace existing element"; - end Replace_Element; - - procedure Replace_Element (Container : in out Set; Position : Cursor; New_Item : Element_Type) diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 0e11e6506ed..adc34abf950 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -7,11 +7,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -1463,121 +1459,100 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Node : Node_Access; Item : Element_Type) is + pragma Assert (Node /= null); + pragma Assert (Node.Element /= null); + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := new Element_Type'(Item); -- OK if fails + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + + return Node; + end New_Node; + + Hint : Node_Access; + Result : Node_Access; + Inserted : Boolean; + + X : Element_Access := Node.Element; + + -- Start of processing for Insert + begin if Item < Node.Element.all or else Node.Element.all < Item then null; + else if Tree.Lock > 0 then raise Program_Error with "attempt to tamper with cursors (set is locked)"; end if; - declare - X : Element_Access := Node.Element; - begin - Node.Element := new Element_Type'(Item); - Free_Element (X); - end; + Node.Element := new Element_Type'(Item); + Free_Element (X); 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 - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - - return Node; - end New_Node; + Hint := Element_Keys.Ceiling (Tree, Item); - Result : Node_Access; - Inserted : Boolean; - - X : Element_Access := Node.Element; + if Hint = null then + null; - -- Start of processing for Insert_New_Item + elsif Item < Hint.Element.all then + if Hint = Node then + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; - 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; + Node.Element := new Element_Type'(Item); + Free_Element (X); - 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 - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - return Node; - end New_Node; + else + pragma Assert (not (Hint.Element.all < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; - Result : Node_Access; - Inserted : Boolean; + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - -- Start of processing for Reinsert_Old_Element + Local_Insert_With_Hint + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); - 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; + pragma Assert (Inserted); + pragma Assert (Result = Node); - raise Program_Error with "attempt to replace existing element"; + Free_Element (X); end Replace_Element; procedure Replace_Element diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 59ae2a5cd58..01058cd2fc6 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,11 +6,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -566,10 +562,22 @@ package body Ada.Containers.Hashed_Maps is Process (Cursor'(Container'Unchecked_Access, Node)); end Process_Node; + B : Natural renames Container'Unrestricted_Access.HT.Busy; + -- Start of processing for Iterate begin - Local_Iterate (Container.HT); + B := B + 1; + + begin + Local_Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; end Iterate; --------- diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index a54683e36ff..0f0552a941d 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,11 +6,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -51,6 +47,9 @@ package body Ada.Containers.Hashed_Sets is -- Local Subprograms -- ----------------------- + procedure Assign (Node : Node_Access; Item : Element_Type); + pragma Inline (Assign); + function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); @@ -90,11 +89,6 @@ package body Ada.Containers.Hashed_Sets is return Node_Access; pragma Inline (Read_Node); - procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type); - procedure Set_Next (Node : Node_Access; Next : Node_Access); pragma Inline (Set_Next); @@ -136,6 +130,9 @@ package body Ada.Containers.Hashed_Sets is procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); @@ -157,6 +154,15 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Adjust (Container.HT); end Adjust; + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + begin + Node.Element := Item; + end Assign; + -------------- -- Capacity -- -------------- @@ -264,24 +270,41 @@ package body Ada.Containers.Hashed_Sets is "attempt to tamper with elements (set is busy)"; end if; - -- TODO: This can be written in terms of a loop instead as - -- active-iterator style, sort of like a passive iterator. + if Source.HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; - 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; + begin + Src_Node := HT_Ops.First (Source.HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); - else - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - end if; - end loop; + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Source.HT, Src_Node); + end loop; + end; + + else + 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; + + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end if; end Difference; function Difference (Left, Right : Set) return Set is @@ -685,7 +708,7 @@ package body Ada.Containers.Hashed_Sets is return; end if; - if Source.Length = 0 then + if Source.HT.Length = 0 then Clear (Target); return; end if; @@ -695,15 +718,6 @@ package body Ada.Containers.Hashed_Sets is "attempt to tamper with elements (set is busy)"; 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 @@ -818,9 +832,6 @@ package body Ada.Containers.Hashed_Sets is return False; end if; - -- TODO: rewrite this to loop in the - -- style of a passive iterator. - Subset_Node := HT_Ops.First (Subset.HT); while Subset_Node /= null loop if not Is_In (Of_Set.HT, Subset_Node) then @@ -855,13 +866,22 @@ package body Ada.Containers.Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; + B : Natural renames Container'Unrestricted_Access.HT.Busy; + -- Start of processing for Iterate begin - -- TODO: resolve whether HT_Ops.Generic_Iteration should - -- manipulate busy bit. + B := B + 1; + + begin + Iterate (Container.HT); + exception + when others => + B := B - 1; + raise; + end; - Iterate (Container.HT); + B := B - 1; end Iterate; ------------ @@ -1047,109 +1067,6 @@ package body Ada.Containers.Hashed_Sets is Node.Element := New_Item; end Replace; - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - New_Item : Element_Type) - is - begin - if Equivalent_Elements (Node.Element, New_Item) then - pragma Assert (Hash (Node.Element) = Hash (New_Item)); - - if HT.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - - Node.Element := New_Item; -- Note that this assignment can fail - return; - end if; - - if HT.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - 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); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Element := New_Item; -- Note that this assignment can fail - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - -- Start of processing for Insert_New_Element - - begin - Local_Insert - (HT => HT, - Key => New_Item, - Node => Result, - Inserted => Inserted); - - if Inserted then - return; - end if; - exception - when others => - null; -- Assignment must have failed - end Insert_New_Element; - - Reinsert_Old_Element : declare - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - Node.Next := Next; - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - -- Start of processing for Reinsert_Old_Element - - begin - Local_Insert - (HT => HT, - Key => Node.Element, - Node => Result, - Inserted => Inserted); - exception - when others => - null; - end Reinsert_Old_Element; - - raise Program_Error with "attempt to replace existing element"; - end Replace_Element; - procedure Replace_Element (Container : in out Set; Position : Cursor; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 121ee3f9788..bccd95145f8 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -8,10 +8,6 @@ -- -- -- Copyright (C) 2004-2006, 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- -- @@ -1052,7 +1048,7 @@ package body Ada.Containers.Indefinite_Vectors is Old_Last_As_Int : constant Int := Int (Container.Last); begin - if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? + if Old_Last_As_Int > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; @@ -1514,7 +1510,7 @@ package body Ada.Containers.Indefinite_Vectors is Old_Last_As_Int : constant Int := Int (Container.Last); begin - if Old_Last_As_Int > Int'Last - N then -- see a-convec.adb ??? + if Old_Last_As_Int > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; @@ -2586,12 +2582,6 @@ package body Ada.Containers.Indefinite_Vectors is begin for Indx 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. ??? - if E (Indx) = null then Boolean'Write (Stream, False); else diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index ecffd32b90c..f08b70416a7 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -8,10 +8,6 @@ -- -- -- Copyright (C) 2004-2006 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- -- @@ -799,34 +795,6 @@ package body Ada.Containers.Vectors is begin if Old_Last_As_Int > Int'Last - N then - - -- ??? - - -- The purpose of this test is to ensure that the calculation of - -- New_Last_As_Int (see below) doesn't overflow. - - -- This isn't quite right, since the only requirements are: - -- V.Last <= Index_Type'Last - -- V.Length <= Count_Type'Last - - -- To be strictly correct there's no (explicit) requirement that - -- Old_Last + N <= Int'Last - - -- However, there might indeed be an implied requirement, since - -- machine constraints dictate that - -- Index_Type'Last <= Int'Last - -- and so this check is perhaps proper after all. - - -- This shouldn't be an issue in practice, since it can only - -- happen when N is very large, or V.Last is near Int'Last. - - -- N isn't likely to be large, since there's probably not enough - -- storage. - - -- V.Last would only be large if IT'First is very large (and - -- V.Length has some "normal" size). But typically IT'First is - -- either 0 or 1. - raise Constraint_Error with "new length is out of range"; end if; @@ -1282,7 +1250,7 @@ package body Ada.Containers.Vectors is Old_Last_As_Int : constant Int := Int (Container.Last); begin - if Old_Last_As_Int > Int'Last - N then -- see Insert ??? + if Old_Last_As_Int > Int'Last - N then raise Constraint_Error with "new length is out of range"; end if; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 552987329d7..d407feadfd1 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,11 +6,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -1375,11 +1371,49 @@ package body Ada.Containers.Ordered_Sets is Node : Node_Access; Item : Element_Type) is + pragma Assert (Node /= null); + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := Item; + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + + return Node; + end New_Node; + + Hint : Node_Access; + Result : Node_Access; + Inserted : Boolean; + + -- Start of processing for Insert + begin if Item < Node.Element or else Node.Element < Item then null; + else if Tree.Lock > 0 then raise Program_Error with @@ -1390,95 +1424,38 @@ package body Ada.Containers.Ordered_Sets is 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); + Hint := Element_Keys.Ceiling (Tree, Item); - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); + if Hint = null then + null; - -------------- - -- New_Node -- - -------------- + elsif Item < Hint.Element then + if Hint = Node then + if Tree.Lock > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is locked)"; + end if; - function New_Node return Node_Access is - begin Node.Element := Item; - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - - 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 - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - - return Node; - end New_Node; - - Result : Node_Access; - Inserted : Boolean; - - -- Start of processing for Reinsert_Old_Element + else + pragma Assert (not (Hint.Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; - 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; + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - raise Program_Error with "attempt to replace existing element"; + Local_Insert_With_Hint + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Node); end Replace_Element; procedure Replace_Element diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb index 7fe8e3b5f67..f90568d33ec 100644 --- a/gcc/ada/a-crbtgk.adb +++ b/gcc/ada/a-crbtgk.adb @@ -7,11 +7,7 @@ -- -- -- B o d y -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -44,11 +40,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -- AKA Lower_Bound - function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is + function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is Y : Node_Access; - X : Node_Access := Tree.Root; + X : Node_Access; begin + X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then X := Ops.Right (X); @@ -67,9 +64,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is Y : Node_Access; - X : Node_Access := Tree.Root; + X : Node_Access; begin + X := Tree.Root; while X /= null loop if Is_Greater_Key_Node (Key, X) then X := Ops.Right (X); @@ -96,9 +94,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is Y : Node_Access; - X : Node_Access := Tree.Root; + X : Node_Access; begin + X := Tree.Root; while X /= null loop if Is_Less_Key_Node (Key, X) then X := Ops.Left (X); @@ -116,45 +115,55 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is -------------------------------- procedure Generic_Conditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean) + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) is Y : Node_Access := null; X : Node_Access := Tree.Root; begin - Success := True; + Inserted := True; while X /= null loop Y := X; - Success := Is_Less_Key_Node (Key, X); + Inserted := Is_Less_Key_Node (Key, X); - if Success then + if Inserted then X := Ops.Left (X); else X := Ops.Right (X); end if; end loop; - Node := Y; + -- If Inserted is True, then this means either that Tree is + -- empty, or there was a least one node (strictly) greater than + -- Key. Otherwise, it means that Key is equal to or greater than + -- every node. - if Success then - if Node = Tree.First then - Insert_Post (Tree, X, Y, Key, Node); + if Inserted then + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); return; end if; - Node := Ops.Previous (Node); + Node := Ops.Previous (Y); + + else + Node := Y; end if; + -- Here Node has a value that is less than or equal to Key. We + -- now have to resolve whether Key is equal to or greater than + -- Node, which determines whether the insertion succeeds. + if Is_Greater_Key_Node (Key, Node) then - Insert_Post (Tree, X, Y, Key, Node); - Success := True; + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; return; end if; - Success := False; + Inserted := False; end Generic_Conditional_Insert; ------------------------------------------ @@ -162,21 +171,33 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ------------------------------------------ procedure Generic_Conditional_Insert_With_Hint - (Tree : in out Tree_Type; - Position : Node_Access; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean) + (Tree : in out Tree_Type; + Position : Node_Access; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) is begin + -- The purpose of a hint is to avoid a search from the root of + -- tree. If we have it hint it means we only need to traverse the + -- subtree rooted at the hint to find the nearest neighbor. Note + -- that finding the neighbor means merely walking the tree; this + -- is not a search and the only comparisons that occur are with + -- the hint and its neighbor. + + -- If Position is null, this is intepreted to mean that Key is + -- large relative to the nodes in the tree. If the tree is empty, + -- or Key is greater than the last node in the tree, then we're + -- done; otherwise the hint was "wrong" and we must search. + if Position = null then -- largest - if Tree.Length > 0 - and then Is_Greater_Key_Node (Key, Tree.Last) + if Tree.Last = null + or else Is_Greater_Key_Node (Key, Tree.Last) then - Insert_Post (Tree, null, Tree.Last, Key, Node); - Success := True; + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); end if; return; @@ -184,64 +205,88 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is pragma Assert (Tree.Length > 0); - if Is_Less_Key_Node (Key, Position) then - if Position = Tree.First then - Insert_Post (Tree, Position, Position, Key, Node); - Success := True; - return; - end if; + -- A hint can either name the node that immediately follows Key, + -- or immediately precedes Key. We first test whether Key is is + -- less than the hint, and if so we compare Key to the node that + -- precedes the hint. If Key is both less than the hint and + -- greater than the hint's preceding neighbor, then we're done; + -- otherwise we must search. + + -- Note also that a hint can either be an anterior node or a leaf + -- node. A new node is always inserted at the bottom of the tree + -- (at least prior to rebalancing), becoming the new left or + -- right child of leaf node (which prior to the insertion must + -- necessarily be null, since this is a leaf). If the hint names + -- an anterior node then its neighbor must be a leaf, and so + -- (here) we insert after the neighbor. If the hint names a leaf + -- then its neighbor must be anterior and so we insert before the + -- hint. + if Is_Less_Key_Node (Key, Position) then declare Before : constant Node_Access := Ops.Previous (Position); begin - if Is_Greater_Key_Node (Key, Before) then + if Before = null then + Insert_Post (Tree, Tree.First, True, Node); + Inserted := True; + + elsif Is_Greater_Key_Node (Key, Before) then if Ops.Right (Before) = null then - Insert_Post (Tree, null, Before, Key, Node); + Insert_Post (Tree, Before, False, Node); else - Insert_Post (Tree, Position, Position, Key, Node); + Insert_Post (Tree, Position, True, Node); end if; - Success := True; + Inserted := True; else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); end if; end; return; end if; - if Is_Greater_Key_Node (Key, Position) then - if Position = Tree.Last then - Insert_Post (Tree, null, Tree.Last, Key, Node); - Success := True; - return; - end if; + -- We know that Key isn't less than the hint so we try again, + -- this time to see if it's greater than the hint. If so we + -- compare Key to the node that follows the hint. If Key is both + -- greater than the hint and less than the hint's next neighbor, + -- then we're done; otherwise we must search. + if Is_Greater_Key_Node (Key, Position) then declare After : constant Node_Access := Ops.Next (Position); begin - if Is_Less_Key_Node (Key, After) then + if After = null then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + + elsif Is_Less_Key_Node (Key, After) then if Ops.Right (Position) = null then - Insert_Post (Tree, null, Position, Key, Node); + Insert_Post (Tree, Position, False, Node); else - Insert_Post (Tree, After, After, Key, Node); + Insert_Post (Tree, After, True, Node); end if; - Success := True; + Inserted := True; else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); end if; end; return; end if; + -- We know that Key is neither less than the hint nor greater + -- than the hint, and that's the definition of equivalence. + -- There's nothing else we need to do, since a search would just + -- reach the same conclusion. + Node := Position; - Success := False; + Inserted := False; end Generic_Conditional_Insert_With_Hint; ------------------------- @@ -249,10 +294,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ------------------------- procedure Generic_Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access) + (Tree : in out Tree_Type; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access) is begin if Tree.Length = Count_Type'Last then @@ -264,50 +309,32 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is "attempt to tamper with cursors (container is busy)"; end if; - if Y = null - or else X /= null - or else Is_Less_Key_Node (Key, Y) - then - pragma Assert (Y = null - or else Ops.Left (Y) = null); + Z := New_Node; + pragma Assert (Z /= null); + pragma Assert (Ops.Color (Z) = Red); - -- Delay allocation as long as we can, in order to defend - -- against exceptions propagated by relational operators. + if Y = null then + pragma Assert (Tree.Length = 0); + pragma Assert (Tree.Root = null); + pragma Assert (Tree.First = null); + pragma Assert (Tree.Last = null); - Z := New_Node; + Tree.Root := Z; + Tree.First := Z; + Tree.Last := Z; - pragma Assert (Z /= null); - pragma Assert (Ops.Color (Z) = Red); + elsif Before then + pragma Assert (Ops.Left (Y) = null); - if Y = null then - pragma Assert (Tree.Length = 0); - pragma Assert (Tree.Root = null); - pragma Assert (Tree.First = null); - pragma Assert (Tree.Last = null); + Ops.Set_Left (Y, Z); - Tree.Root := Z; + if Y = Tree.First then Tree.First := Z; - Tree.Last := Z; - - else - Ops.Set_Left (Y, Z); - - if Y = Tree.First then - Tree.First := Z; - end if; end if; else 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 /= null); - pragma Assert (Ops.Color (Z) = Red); - Ops.Set_Right (Y, Z); if Y = Tree.Last then @@ -335,8 +362,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ------------- procedure Iterate (Node : Node_Access) is - N : Node_Access := Node; + N : Node_Access; begin + N := Node; while N /= null loop if Is_Less_Key_Node (Key, N) then N := Ops.Left (N); @@ -371,8 +399,9 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is ------------- procedure Iterate (Node : Node_Access) is - N : Node_Access := Node; + N : Node_Access; begin + N := Node; while N /= null loop if Is_Less_Key_Node (Key, N) then N := Ops.Left (N); @@ -401,21 +430,28 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Key : Key_Type; Node : out Node_Access) is - Y : Node_Access := null; - X : Node_Access := Tree.Root; + Y : Node_Access; + X : Node_Access; + + Before : Boolean; begin + Y := null; + Before := False; + + X := Tree.Root; while X /= null loop Y := X; + Before := Is_Less_Key_Node (Key, X); - if Is_Less_Key_Node (Key, X) then + if Before then X := Ops.Left (X); else X := Ops.Right (X); end if; end loop; - Insert_Post (Tree, X, Y, Key, Node); + Insert_Post (Tree, Y, Before, Node); end Generic_Unconditional_Insert; -------------------------------------------- @@ -428,22 +464,34 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Key : Key_Type; Node : out Node_Access) is - -- TODO: verify this algorithm. It was (quickly) adapted it from the - -- same algorithm for conditional_with_hint. It may be that the test - -- Key > Hint should be something like a Key >= Hint, to handle the - -- case when Hint is The Last Item of A (Contiguous) sequence of - -- Equivalent Items. (The Key < Hint Test is probably OK. It is not - -- clear that you can use Key <= Hint, since new items are always - -- inserted last in the sequence of equivalent items.) ??? - begin + -- There are fewer constraints for an unconditional insertion + -- than for a conditional insertion, since we allow duplicate + -- keys. So instead of having to check (say) whether Key is + -- (strictly) greater than the hint's previous neighbor, here we + -- allow Key to be equal to or greater than the previous node. + + -- There is the issue of what to do if Key is equivalent to the + -- hint. Does the new node get inserted before or after the hint? + -- We decide that it gets inserted after the hint, reasoning that + -- this is consistent with behavior for non-hint insertion, which + -- inserts a new node after existing nodes with equivalent keys. + + -- First we check whether the hint is null, which is interpreted + -- to mean that Key is large relative to existing nodes. + -- Following our rule above, if Key is equal to or greater than + -- the last node, then we insert the new node immediately after + -- last. (We don't have an operation for testing whether a key is + -- "equal to or greater than" a node, so we must say instead "not + -- less than", which is equivalent.) + if Hint = null then -- largest - if Tree.Length > 0 - and then Is_Greater_Key_Node (Key, Tree.Last) - then - Insert_Post (Tree, null, Tree.Last, Key, Node); - else + if Tree.Last = null then + Insert_Post (Tree, null, False, Node); + elsif Is_Less_Key_Node (Key, Tree.Last) then Unconditional_Insert_Sans_Hint (Tree, Key, Node); + else + Insert_Post (Tree, Tree.Last, False, Node); end if; return; @@ -451,53 +499,53 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is pragma Assert (Tree.Length > 0); - if Is_Less_Key_Node (Key, Hint) then - if Hint = Tree.First then - Insert_Post (Tree, Hint, Hint, Key, Node); - return; - end if; + -- We decide here whether to insert the new node prior to the + -- hint. Key could be equivalent to the hint, so in theory we + -- could write the following test as "not greater than" (same as + -- "less than or equal to"). If Key were equivalent to the hint, + -- that would mean that the new node gets inserted before an + -- equivalent node. That wouldn't break any container invariants, + -- but our rule above says that new nodes always get inserted + -- after equivalent nodes. So here we test whether Key is both + -- less than the hint and and equal to or greater than the hint's + -- previous neighbor, and if so insert it before the hint. + if Is_Less_Key_Node (Key, Hint) then declare Before : constant Node_Access := Ops.Previous (Hint); begin - if Is_Greater_Key_Node (Key, Before) then - if Ops.Right (Before) = null then - Insert_Post (Tree, null, Before, Key, Node); - else - Insert_Post (Tree, Hint, Hint, Key, Node); - end if; - else + if Before = null then + Insert_Post (Tree, Hint, True, Node); + elsif Is_Less_Key_Node (Key, Before) then Unconditional_Insert_Sans_Hint (Tree, Key, Node); - end if; - end; - - return; - end if; - - if Is_Greater_Key_Node (Key, Hint) then - if Hint = Tree.Last then - Insert_Post (Tree, null, Tree.Last, Key, Node); - return; - end if; - - declare - After : constant Node_Access := Ops.Next (Hint); - begin - if Is_Less_Key_Node (Key, After) then - if Ops.Right (Hint) = null then - Insert_Post (Tree, null, Hint, Key, Node); - else - Insert_Post (Tree, After, After, Key, Node); - end if; + elsif Ops.Right (Before) = null then + Insert_Post (Tree, Before, False, Node); else - Unconditional_Insert_Sans_Hint (Tree, Key, Node); + Insert_Post (Tree, Hint, True, Node); end if; end; return; end if; - Unconditional_Insert_Sans_Hint (Tree, Key, Node); + -- We know that Key isn't less than the hint, so it must be equal + -- or greater. So we just test whether Key is less than or equal + -- to (same as "not greater than") the hint's next neighbor, and + -- if so insert it after the hint. + + declare + After : constant Node_Access := Ops.Next (Hint); + begin + if After = null then + Insert_Post (Tree, Hint, False, Node); + elsif Is_Greater_Key_Node (Key, After) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (Hint) = null then + Insert_Post (Tree, Hint, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + end; end Generic_Unconditional_Insert_With_Hint; ----------------- @@ -509,9 +557,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Keys is Key : Key_Type) return Node_Access is Y : Node_Access; - X : Node_Access := Tree.Root; + X : Node_Access; begin + X := Tree.Root; while X /= null loop if Is_Less_Key_Node (Key, X) then Y := X; diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads index e1a3824a953..1e8c4fd9eb2 100644 --- a/gcc/ada/a-crbtgk.ads +++ b/gcc/ada/a-crbtgk.ads @@ -7,13 +7,32 @@ -- -- -- 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-2006, 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- -- +-- 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, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, 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. -- ------------------------------------------------------------------------------ +-- Tree_Type is used to implement ordered containers. This package declares +-- the tree operations that depend on keys. + with Ada.Containers.Red_Black_Trees.Generic_Operations; generic @@ -37,42 +56,58 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is generic with function New_Node return Node_Access; procedure Generic_Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access); + (Tree : in out Tree_Type; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access); + -- Completes an insertion after the insertion position has been + -- determined. On output Z contains a pointer to the newly inserted + -- node, allocated using New_Node. If Tree is busy then + -- Program_Error is raised. If Y is null, then Tree must be empty. + -- Otherwise Y denotes the insertion position, and Before specifies + -- whether the new node is Y's left (True) or right (False) child. generic with procedure Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access); + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); procedure Generic_Conditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean); + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Inserts a new node in Tree, but only if the tree does not already + -- contain Key. Generic_Conditional_Insert first searches for a key + -- equivalent to Key in Tree. If an equivalent key is found, then on + -- output Node designates the node with that key and Inserted is + -- False; there is no allocation and Tree is not modified. Otherwise + -- Node designates a new node allocated using Insert_Post, and + -- Inserted is True. generic with procedure Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access); + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); procedure Generic_Unconditional_Insert (Tree : in out Tree_Type; Key : Key_Type; Node : out Node_Access); + -- Inserts a new node in Tree. On output Node designates the new + -- node, which is allocated using Insert_Post. The node is inserted + -- immediately after already-existing equivalent keys. generic with procedure Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access); + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); with procedure Unconditional_Insert_Sans_Hint (Tree : in out Tree_Type; @@ -84,53 +119,77 @@ package Ada.Containers.Red_Black_Trees.Generic_Keys is Hint : Node_Access; Key : Key_Type; Node : out Node_Access); + -- Inserts a new node in Tree near position Hint, to avoid having to + -- search from the root for the insertion position. If Hint is null + -- then Generic_Unconditional_Insert_With_Hint attempts to insert + -- the new node after Tree.Last. If Hint is non-null then if Key is + -- less than Hint, it attempts to insert the new node immediately + -- prior to Hint. Otherwise it attempts to insert the node + -- immediately following Hint. We say "attempts" above to emphasize + -- that insertions always preserve invariants with respect to key + -- order, even when there's a hint. So if Key can't be inserted + -- immediately near Hint, then the new node is inserted in the + -- normal way, by searching for the correct position starting from + -- the root. generic with procedure Insert_Post - (Tree : in out Tree_Type; - X, Y : Node_Access; - Key : Key_Type; - Z : out Node_Access); + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); with procedure Conditional_Insert_Sans_Hint - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Success : out Boolean); + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); procedure Generic_Conditional_Insert_With_Hint (Tree : in out Tree_Type; - Position : Node_Access; + Position : Node_Access; -- the hint Key : Key_Type; Node : out Node_Access; - Success : out Boolean); + Inserted : out Boolean); + -- Inserts a new node in Tree if the tree does not already contain + -- Key, using Position as a hint about where to insert the new node. + -- See Generic_Unconditional_Insert_With_Hint for more details about + -- hint semantics. function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equivalent to Key function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equal to or greater than Key function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access; + -- Searches Tree for the largest node less than or equal to Key function Upper_Bound (Tree : Tree_Type; Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node greater than Key generic with procedure Process (Node : Node_Access); procedure Generic_Iteration (Tree : Tree_Type; Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, in order + -- from earliest in range to latest. generic with procedure Process (Node : Node_Access); procedure Generic_Reverse_Iteration (Tree : Tree_Type; Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, but in + -- order from largest in range to earliest. end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index b0b7ca09bc6..a9f63942fe1 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -9,10 +9,6 @@ -- -- -- Copyright (C) 2004-2006, 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- -- @@ -34,6 +30,13 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Operations is @@ -141,7 +144,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is - -- CLR p274 ??? + -- CLR p274 X : Node_Access := Node; W : Node_Access; @@ -237,7 +240,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is (Tree : in out Tree_Type; Node : Node_Access) is - -- CLR p273 ??? + -- CLR p273 X, Y : Node_Access; @@ -804,7 +807,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is - -- CLR p266 ??? + -- CLR p266 Y : constant Node_Access := Right (X); pragma Assert (Y /= null); @@ -837,7 +840,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Max (Node : Node_Access) return Node_Access is - -- CLR p248 ??? + -- CLR p248 X : Node_Access := Node; Y : Node_Access; @@ -860,7 +863,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Min (Node : Node_Access) return Node_Access is - -- CLR p248 ??? + -- CLR p248 X : Node_Access := Node; Y : Node_Access; @@ -883,7 +886,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is function Next (Node : Node_Access) return Node_Access is begin - -- CLR p249 ??? + -- CLR p249 if Node = null then return null; @@ -905,14 +908,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Y := Parent (Y); end loop; - -- Why is this code commented out ??? - --- if Right (X) /= Y then --- return Y; --- else --- return X; --- end if; - return Y; end; end Next; @@ -943,14 +938,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Y := Parent (Y); end loop; - -- Why is this code commented out ??? - --- if Left (X) /= Y then --- return Y; --- else --- return X; --- end if; - return Y; end; end Previous; @@ -963,7 +950,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is (Tree : in out Tree_Type; Node : Node_Access) is - -- CLR p.268 ??? + -- CLR p.268 X : Node_Access := Node; pragma Assert (X /= null); diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads index a213a283010..0415f5be2de 100644 --- a/gcc/ada/a-crbtgo.ads +++ b/gcc/ada/a-crbtgo.ads @@ -7,11 +7,7 @@ -- -- -- S p e c -- -- -- --- 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. -- +-- Copyright (C) 2004-2006, 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- -- @@ -34,6 +30,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +-- Tree_Type is used to implement the ordered containers. This package +-- declares the tree operations that do not depend on keys. + with Ada.Streams; use Ada.Streams; generic @@ -53,8 +52,10 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is pragma Pure; function Min (Node : Node_Access) return Node_Access; + -- Returns the smallest-valued node of the subtree rooted at Node function Max (Node : Node_Access) return Node_Access; + -- Returns the largest-valued node of the subtree rooted at Node -- NOTE: The Check_Invariant operation was used during early -- development of the red-black tree. Now that the tree type @@ -64,47 +65,75 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is -- procedure Check_Invariant (Tree : Tree_Type); function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; + -- Inspects Node to determine (to the extent possible) whether + -- the node is valid; used to detect if the node is dangling. function Next (Node : Node_Access) return Node_Access; + -- Returns the smallest node greater than Node function Previous (Node : Node_Access) return Node_Access; + -- Returns the largest node less than Node generic with function Is_Equal (L, R : Node_Access) return Boolean; function Generic_Equal (Left, Right : Tree_Type) return Boolean; + -- Uses Is_Equal to perform a node-by-node comparison of the + -- Left and Right trees; processing stops as soon as the first + -- non-equal node is found. procedure Delete_Node_Sans_Free (Tree : in out Tree_Type; Node : Node_Access); + -- Removes Node from Tree without deallocating the node. If Tree + -- is busy then Program_Error is raised. generic with procedure Free (X : in out Node_Access); procedure Generic_Delete_Tree (X : in out Node_Access); + -- Deallocates the tree rooted at X, calling Free on each node 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; + -- Copies the tree rooted at Source_Root, using Copy_Node to copy each + -- node of the source tree. If Copy_Node propagates an exception + -- (e.g. Storage_Error), then Delete_Tree is first used to deallocate + -- the target tree, and then the exception is propagated. generic with function Copy_Tree (Root : Node_Access) return Node_Access; procedure Generic_Adjust (Tree : in out Tree_Type); + -- Used to implement controlled Adjust. On input to Generic_Adjust, Tree + -- holds a bitwise (shallow) copy of the source tree (as would be the case + -- when controlled Adjust is called). On output, Tree holds its own (deep) + -- copy of the source tree, which is constructed by calling Copy_Tree. generic with procedure Delete_Tree (X : in out Node_Access); procedure Generic_Clear (Tree : in out Tree_Type); + -- Clears Tree by deallocating all of its nodes. If Tree is busy then + -- Program_Error is raised. generic with procedure Clear (Tree : in out Tree_Type); procedure Generic_Move (Target, Source : in out Tree_Type); + -- Moves the tree belonging to Source onto Target. If Source is busy then + -- Program_Error is raised. Otherwise Target is first cleared (by calling + -- Clear, to deallocate its existing tree), then given the Source tree, and + -- then finally Source is cleared (by setting its pointers to null). generic with procedure Process (Node : Node_Access) is <>; procedure Generic_Iteration (Tree : Tree_Type); + -- Calls Process for each node in Tree, in order from smallest-valued + -- node to largest-valued node. generic with procedure Process (Node : Node_Access) is <>; procedure Generic_Reverse_Iteration (Tree : Tree_Type); + -- Calls Process for each node in Tree, in order from largest-valued + -- node to smallest-valued node. generic with procedure Write_Node @@ -113,6 +142,9 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Write (Stream : access Root_Stream_Type'Class; Tree : Tree_Type); + -- Used to implement stream attribute T'Write. Generic_Write + -- first writes the number of nodes into Stream, then calls + -- Write_Node for each node in Tree. generic with procedure Clear (Tree : in out Tree_Type); @@ -121,9 +153,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Generic_Read (Stream : access Root_Stream_Type'Class; Tree : in out Tree_Type); + -- Used to implement stream attribute T'Read. Generic_Read + -- first clears Tree. It then reads the number of nodes out of + -- Stream, and calls Read_Node for each node in Stream. procedure Rebalance_For_Insert (Tree : in out Tree_Type; Node : Node_Access); + -- This rebalances Tree to complete the insertion of Node (which + -- must already be linked in at its proper insertion position). end Ada.Containers.Red_Black_Trees.Generic_Operations; |