diff options
| author | Matthew Heaney <heaney@adacore.com> | 2005-09-05 10:05:32 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-09-05 10:05:32 +0200 |
| commit | ba355842e8ff8cbcb8552b99f6098b333512cc81 (patch) | |
| tree | 7b4be4425a576dfefafcfd6533af08d710bea8f0 /gcc | |
| parent | c1cd0d96753eff81ceba44eaa371931e993e539d (diff) | |
| download | gcc-ba355842e8ff8cbcb8552b99f6098b333512cc81.zip gcc-ba355842e8ff8cbcb8552b99f6098b333512cc81.tar.gz gcc-ba355842e8ff8cbcb8552b99f6098b333512cc81.tar.bz2 | |
a-cihase.adb, [...]: Synchronized with latest draft (Draft 13, August 2005) of Ada Amendment 1.
2005-09-01 Matthew Heaney <heaney@adacore.com>
* a-cihase.adb, a-coorse.ads, a-coorse.adb, a-cohama.adb,
a-ciorse.ads, a-ciorse.adb, a-cihama.adb, a-cdlili.adb,
a-cidlli.adb, a-chtgop.adb, a-cihase.adb, a-cihase.ads,
a-cohase.adb, a-cohase.adb, a-cohase.ads: Synchronized with latest
draft (Draft 13, August 2005) of Ada Amendment 1.
From-SVN: r103892
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/a-cdlili.adb | 727 | ||||
| -rw-r--r-- | gcc/ada/a-chtgop.adb | 292 | ||||
| -rw-r--r-- | gcc/ada/a-cidlli.adb | 845 | ||||
| -rw-r--r-- | gcc/ada/a-cihama.adb | 212 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.adb | 332 | ||||
| -rw-r--r-- | gcc/ada/a-cihase.ads | 102 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.adb | 78 | ||||
| -rw-r--r-- | gcc/ada/a-ciorse.ads | 89 | ||||
| -rw-r--r-- | gcc/ada/a-cohama.adb | 229 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.adb | 303 | ||||
| -rw-r--r-- | gcc/ada/a-cohase.ads | 107 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.adb | 78 | ||||
| -rw-r--r-- | gcc/ada/a-coorse.ads | 80 |
13 files changed, 1751 insertions, 1723 deletions
diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index dcc1829..a0a6f32 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -38,18 +38,19 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Doubly_Linked_Lists is - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - ----------------------- -- Local Subprograms -- ----------------------- + procedure Free (X : in out Node_Access); + procedure Insert_Internal (Container : in out List; Before : Node_Access; New_Node : Node_Access); + function Vet (Position : Cursor) return Boolean; + --------- -- "=" -- --------- @@ -110,7 +111,6 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.Length := 1; Src := Src.Next; - while Src /= null loop Container.Last.Next := new Node_Type'(Element => Src.Element, Prev => Container.Last, @@ -162,9 +162,8 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (X.Next.Prev = Container.First); Container.First := X.Next; - X.Next := null; -- prevent mischief - Container.First.Prev := null; + Container.Length := Container.Length - 1; Free (X); @@ -181,7 +180,7 @@ package body Ada.Containers.Doubly_Linked_Lists is end Clear; -------------- - -- Continue -- + -- Contains -- -------------- function Contains @@ -203,28 +202,16 @@ package body Ada.Containers.Doubly_Linked_Lists is X : Node_Access; begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then - pragma Assert (Position.Container = null); raise Constraint_Error; end if; - if Position.Container /= List_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); - if Position.Node = Container.First then Delete_First (Container, Count); Position := First (Container); @@ -249,7 +236,6 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.Last := X.Prev; Container.Last.Next := null; - X.Prev := null; -- prevent mischief Free (X); return; end if; @@ -259,8 +245,6 @@ package body Ada.Containers.Doubly_Linked_Lists is X.Next.Prev := X.Prev; X.Prev.Next := X.Next; - X.Next := null; - X.Prev := null; Free (X); end loop; end Delete; @@ -298,7 +282,6 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.Length := Container.Length - 1; - X.Next := null; -- prevent mischief Free (X); end loop; end Delete_First; @@ -336,7 +319,6 @@ package body Ada.Containers.Doubly_Linked_Lists is Container.Length := Container.Length - 1; - X.Prev := null; -- prevent mischief Free (X); end loop; end Delete_Last; @@ -347,20 +329,11 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); + pragma Assert (Vet (Position), "bad cursor in Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; return Position.Node.Element; end Element; @@ -379,23 +352,13 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Node = null then Node := Container.First; + else - if Position.Container /= List_Access'(Container'Unchecked_Access) then + pragma Assert (Vet (Position), "bad cursor in Find"); + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); end if; while Node /= null loop @@ -428,9 +391,27 @@ 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; + end if; + return Container.First.Element; end First_Element; + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + X.Prev := X; + X.Next := X; + Deallocate (X); + end Free; + --------------------- -- Generic_Sorting -- --------------------- @@ -605,26 +586,8 @@ package body Ada.Containers.Doubly_Linked_Lists is function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; ------------ @@ -641,23 +604,12 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Node /= null then - if Before.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; + pragma Assert (Vet (Before), "bad cursor in Insert"); - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Container.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Container.Last); + if Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error; end if; if Count = 0 then @@ -704,23 +656,12 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Node /= null then - if Before.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; + pragma Assert (Vet (Before), "bad cursor in Insert"); - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Container.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Container.Last); + if Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error; end if; if Count = 0 then @@ -853,6 +794,10 @@ 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; + end if; + return Container.Last.Element; end Last_Element; @@ -900,25 +845,12 @@ 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 - pragma Assert (Position.Container = null); return; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - Position.Node := Position.Node.Next; if Position.Node = null then @@ -928,25 +860,12 @@ package body Ada.Containers.Doubly_Linked_Lists is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -977,25 +896,12 @@ 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 - pragma Assert (Position.Container = null); return; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - Position.Node := Position.Node.Prev; if Position.Node = null then @@ -1005,25 +911,12 @@ package body Ada.Containers.Doubly_Linked_Lists is function Previous (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Previous"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -1043,42 +936,34 @@ package body Ada.Containers.Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in Element_Type)) is - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - E : Element_Type renames Position.Node.Element; - - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Query_Element; ---------- @@ -1141,29 +1026,18 @@ package body Ada.Containers.Doubly_Linked_Lists is (Position : Cursor; By : Element_Type) is - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - E : Element_Type renames Position.Node.Element; - begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + if Position.Container = null then + raise Constraint_Error; + end if; + if Position.Container.Lock > 0 then raise Program_Error; end if; - E := By; + Position.Node.Element := By; end Replace_Element; ------------------ @@ -1180,23 +1054,13 @@ package body Ada.Containers.Doubly_Linked_Lists is begin if Node = null then Node := Container.Last; + else - if Position.Container /= List_Access'(Container'Unchecked_Access) then + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); end if; while Node /= null loop @@ -1336,23 +1200,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Source : in out List) is begin - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; - - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); + pragma Assert (Vet (Before), "bad cursor in Splice"); - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unrestricted_Access + then + raise Program_Error; end if; if Target'Address = Source'Address @@ -1421,46 +1274,23 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) is begin - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); - - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unchecked_Access + then + raise Program_Error; end if; if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= List_Access'(Target'Unchecked_Access) then + if Position.Container /= Target'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Target.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Target.Last); - if Position.Node = Before.Node or else Position.Node.Next = Before.Node then @@ -1548,46 +1378,23 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); - - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unrestricted_Access + then + raise Program_Error; end if; if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= List_Access'(Source'Unchecked_Access) then + if Position.Container /= Source'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Source.Length >= 1); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last.Next = null); - - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Source.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Source.Last); - if Target.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -1600,12 +1407,14 @@ package body Ada.Containers.Doubly_Linked_Lists is if Position.Node = Source.First then Source.First := Position.Node.Next; - Source.First.Prev := null; if Position.Node = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; + + else + Source.First.Prev := null; end if; elsif Position.Node = Source.Last then @@ -1667,8 +1476,11 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Swap (I, J : Cursor) is begin - if I.Container = null - or else J.Container = null + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + if I.Node = null + or else J.Node = null then raise Constraint_Error; end if; @@ -1677,51 +1489,22 @@ package body Ada.Containers.Doubly_Linked_Lists is raise Program_Error; end if; - declare - C : List renames I.Container.all; - begin - pragma Assert (C.Length >= 1); - pragma Assert (C.First.Prev = null); - pragma Assert (C.Last.Next = null); - - pragma Assert (I.Node /= null); - pragma Assert (I.Node.Prev = null - or else I.Node.Prev.Next = I.Node); - pragma Assert (I.Node.Next = null - or else I.Node.Next.Prev = I.Node); - pragma Assert (I.Node.Prev /= null - or else I.Node = C.First); - pragma Assert (I.Node.Next /= null - or else I.Node = C.Last); - - if I.Node = J.Node then - return; - end if; + if I.Node = J.Node then + return; + end if; - pragma Assert (C.Length >= 2); - pragma Assert (J.Node /= null); - pragma Assert (J.Node.Prev = null - or else J.Node.Prev.Next = J.Node); - pragma Assert (J.Node.Next = null - or else J.Node.Next.Prev = J.Node); - pragma Assert (J.Node.Prev /= null - or else J.Node = C.First); - pragma Assert (J.Node.Next /= null - or else J.Node = C.Last); - - if C.Lock > 0 then - raise Program_Error; - end if; + if I.Container.Lock > 0 then + raise Program_Error; + end if; - declare - EI : Element_Type renames I.Node.Element; - EJ : Element_Type renames J.Node.Element; + declare + EI : Element_Type renames I.Node.Element; + EJ : Element_Type renames J.Node.Element; - EI_Copy : constant Element_Type := EI; - begin - EI := EJ; - EJ := EI_Copy; - end; + EI_Copy : constant Element_Type := EI; + begin + EI := EJ; + EJ := EI_Copy; end; end Swap; @@ -1733,50 +1516,25 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : in out List; I, J : Cursor) is begin - if I.Container = null - or else J.Container = null + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + if I.Node = null + or else J.Node = null then raise Constraint_Error; end if; - if I.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - if J.Container /= I.Container then + if I.Container /= Container'Unrestricted_Access + or else I.Container /= J.Container + then raise Program_Error; end if; - pragma Assert (Container.Length >= 1); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (I.Node /= null); - pragma Assert (I.Node.Prev = null - or else I.Node.Prev.Next = I.Node); - pragma Assert (I.Node.Next = null - or else I.Node.Next.Prev = I.Node); - pragma Assert (I.Node.Prev /= null - or else I.Node = Container.First); - pragma Assert (I.Node.Next /= null - or else I.Node = Container.Last); - if I.Node = J.Node then return; end if; - pragma Assert (Container.Length >= 2); - - pragma Assert (J.Node /= null); - pragma Assert (J.Node.Prev = null - or else J.Node.Prev.Next = J.Node); - pragma Assert (J.Node.Next = null - or else J.Node.Next.Prev = J.Node); - pragma Assert (J.Node.Prev /= null - or else J.Node = Container.First); - pragma Assert (J.Node.Next /= null - or else J.Node = Container.Last); - if Container.Busy > 0 then raise Program_Error; end if; @@ -1813,46 +1571,177 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Update_Element (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) is - - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length >= 1); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - E : Element_Type renames Position.Node.Element; - - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - + Process : not null access procedure (Element : in out Element_Type)) + is begin - B := B + 1; - L := L + 1; + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Update_Element; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + declare + L : List renames Position.Container.all; + begin + if L.Length = 0 then + return False; + end if; + + if L.First = null then + return False; + end if; + + if L.Last = null then + return False; + end if; + + if L.First.Prev /= null then + return False; + end if; + + if L.Last.Next /= null then + return False; + end if; + + if Position.Node.Prev = null + and then Position.Node /= L.First + then + return False; + end if; + + if Position.Node.Next = null + and then Position.Node /= L.Last + then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if L.First.Next = null then + return False; + end if; + + if L.Last.Prev = null then + return False; + end if; + + if L.First.Next.Prev /= L.First then + return False; + end if; + + if L.Last.Prev.Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if L.First.Next /= L.Last then + return False; + end if; + + if L.Last.Prev /= L.First then + return False; + end if; + + return True; + end if; + + if L.First.Next = L.Last then + return False; + end if; + + if L.Last.Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if Position.Node.Next = null then + return False; + end if; + + if Position.Node.Prev = null then + return False; + end if; + + if Position.Node.Next.Prev /= Position.Node then + return False; + end if; + + if Position.Node.Prev.Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if L.First.Next /= Position.Node then + return False; + end if; + + if L.Last.Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + ----------- -- Write -- ----------- diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb index d0f40e8..9793f96 100644 --- a/gcc/ada/a-chtgop.adb +++ b/gcc/ada/a-chtgop.adb @@ -42,14 +42,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is procedure Free is new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access); - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Rehash - (HT : in out Hash_Table_Type; - Size : Hash_Type); - ------------ -- Adjust -- ------------ @@ -405,27 +397,33 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is begin Clear (HT); - declare - B : Buckets_Access := HT.Buckets; - begin - HT.Buckets := null; - HT.Length := 0; - Free (B); -- can this fail??? - end; - Hash_Type'Read (Stream, Last); - -- TODO: don't immediately deallocate the buckets array we - -- already have. Instead, allocate a new buckets array only - -- if it needs to expanded because of the value of Last. + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + if N = 0 then + return; + end if; - if Last /= 0 then + if HT.Buckets = null + or else HT.Buckets'Last /= Last + then + Free (HT.Buckets); HT.Buckets := new Buckets_Type (0 .. Last); end if; - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - while N > 0 loop + -- 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); @@ -454,6 +452,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end loop; N := N - M; + + exit when N = 0; end loop; end Generic_Read; @@ -481,6 +481,8 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return; end if; + -- TODO: see note in Generic_Read??? + for Indx in HT.Buckets'Range loop X := HT.Buckets (Indx); @@ -577,104 +579,6 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is return null; end Next; - ------------ - -- Rehash -- - ------------ - - procedure Rehash - (HT : in out Hash_Table_Type; - Size : Hash_Type) - is - subtype Buckets_Range is Hash_Type range 0 .. Size - 1; - - Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range); - Src_Buckets : Buckets_Access := HT.Buckets; - - L : Count_Type renames HT.Length; - LL : constant Count_Type := L; - - begin - if Src_Buckets = null then - pragma Assert (L = 0); - HT.Buckets := Dst_Buckets; - return; - end if; - - if L = 0 then - HT.Buckets := Dst_Buckets; - Free (Src_Buckets); - return; - end if; - - -- We might want to change this to iter from 1 .. L instead ??? - - for Src_Index in Src_Buckets'Range loop - - declare - Src_Bucket : Node_Access renames Src_Buckets (Src_Index); - begin - while Src_Bucket /= null loop - declare - Src_Node : constant Node_Access := Src_Bucket; - Dst_Index : constant Hash_Type := - Index (Dst_Buckets.all, Src_Node); - Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); - begin - Src_Bucket := Next (Src_Node); - Set_Next (Src_Node, Dst_Bucket); - Dst_Bucket := Src_Node; - end; - - pragma Assert (L > 0); - L := L - 1; - - end loop; - - exception - when others => - - -- NOTE: see todo below. - -- Not clear that we can deallocate the nodes, - -- because they may be designated by outstanding - -- iterators. Which means they're now lost... ??? - - -- for J in NB'Range loop - -- declare - -- Dst : Node_Access renames NB (J); - -- X : Node_Access; - -- begin - -- while Dst /= null loop - -- X := Dst; - -- Dst := Succ (Dst); - -- Free (X); - -- end loop; - -- end; - -- end loop; - - -- TODO: 17 Apr 2005 - -- What I should do instead is go ahead and deallocate the - -- nodes, since when assertions are enabled, we vet the - -- cursors, and we modify the state of a node enough when - -- it is deallocated in order to detect mischief. - -- END TODO. - - Free (Dst_Buckets); - raise; -- TODO: raise Program_Error instead - end; - - -- exit when L = 0; - -- need to bother??? - - end loop; - - pragma Assert (L = 0); - - HT.Buckets := Dst_Buckets; - HT.Length := LL; - - Free (Src_Buckets); - end Rehash; - ---------------------- -- Reserve_Capacity -- ---------------------- @@ -686,74 +590,142 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is NN : Hash_Type; begin - if N = 0 then - if HT.Length = 0 then - Free (HT.Buckets); + if HT.Buckets = null then + if N > 0 then + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := new Buckets_Type (0 .. NN - 1); + end if; - elsif HT.Length < HT.Buckets'Length then - NN := Prime_Numbers.To_Prime (HT.Length); + return; + end if; - -- ASSERT: NN >= HT.Length + if HT.Length = 0 then + if N = 0 then + Free (HT.Buckets); + return; + end if; - if NN < HT.Buckets'Length then - if HT.Busy > 0 then - raise Program_Error; - end if; + if N = HT.Buckets'Length then + return; + end if; - Rehash (HT, Size => NN); - end if; + NN := Prime_Numbers.To_Prime (N); + + if NN = HT.Buckets'Length then + return; end if; + declare + X : Buckets_Access := HT.Buckets; + begin + HT.Buckets := new Buckets_Type (0 .. NN - 1); + Free (X); + end; + return; end if; - if HT.Buckets = null then - NN := Prime_Numbers.To_Prime (N); - - -- ASSERT: NN >= N - - Rehash (HT, Size => NN); + if N = HT.Buckets'Length then return; end if; - if N <= HT.Length then + if N < HT.Buckets'Length then if HT.Length >= HT.Buckets'Length then return; end if; NN := Prime_Numbers.To_Prime (HT.Length); - -- ASSERT: NN >= HT.Length + if NN >= HT.Buckets'Length then + return; + end if; - if NN < HT.Buckets'Length then - if HT.Busy > 0 then - raise Program_Error; - end if; + else + NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length)); - Rehash (HT, Size => NN); + if NN = HT.Buckets'Length then -- can't expand any more + return; end if; + end if; - return; + if HT.Busy > 0 then + raise Program_Error; end if; - -- ASSERT: N > HT.Length + Rehash : declare + Dst_Buckets : Buckets_Access := new Buckets_Type (0 .. NN - 1); + Src_Buckets : Buckets_Access := HT.Buckets; - if N = HT.Buckets'Length then - return; - end if; + L : Count_Type renames HT.Length; + LL : constant Count_Type := L; - NN := Prime_Numbers.To_Prime (N); + Src_Index : Hash_Type := Src_Buckets'First; - -- ASSERT: NN >= N - -- ASSERT: NN > HT.Length + begin + while L > 0 loop + declare + Src_Bucket : Node_Access renames Src_Buckets (Src_Index); - if NN /= HT.Buckets'Length then - if HT.Busy > 0 then - raise Program_Error; - end if; + begin + while Src_Bucket /= null loop + declare + Src_Node : constant Node_Access := Src_Bucket; + + Dst_Index : constant Hash_Type := + Index (Dst_Buckets.all, Src_Node); + + Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); + + begin + Src_Bucket := Next (Src_Node); + + Set_Next (Src_Node, Dst_Bucket); + + Dst_Bucket := Src_Node; + end; + + pragma Assert (L > 0); + L := L - 1; + end loop; + exception + when others => + -- If there's an error computing a hash value during a + -- rehash, then AI-302 says the nodes "become lost." The + -- issue is whether to actually deallocate these lost nodes, + -- since they might be designated by extant cursors. Here + -- we decide to deallocate the nodes, since it's better to + -- solve real problems (storage consumption) rather than + -- imaginary ones (the user might, or might not, dereference + -- a cursor designating a node that has been deallocated), + -- and because we have a way to vet a dangling cursor + -- reference anyway, and hence can actually detect the + -- problem. + + for Dst_Index in Dst_Buckets'Range loop + declare + B : Node_Access renames Dst_Buckets (Dst_Index); + X : Node_Access; + begin + while B /= null loop + X := B; + B := Next (X); + Free (X); + end loop; + end; + end loop; + + Free (Dst_Buckets); + raise Program_Error; + end; - Rehash (HT, Size => NN); - end if; + Src_Index := Src_Index + 1; + end loop; + + HT.Buckets := Dst_Buckets; + HT.Length := LL; + + Free (Src_Buckets); + end Rehash; end Reserve_Capacity; end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index d9bdf8f..becdae2 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -40,20 +40,21 @@ with Ada.Unchecked_Deallocation; package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); ----------------------- -- Local Subprograms -- ----------------------- + procedure Free (X : in out Node_Access); + procedure Insert_Internal (Container : in out List; Before : Node_Access; New_Node : Node_Access); + function Vet (Position : Cursor) return Boolean; + --------- -- "=" -- --------- @@ -188,18 +189,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.First := X.Next; Container.First.Prev := null; - Container.Length := Container.Length - 1; - - X.Next := null; -- prevent mischief - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; + Container.Length := Container.Length - 1; Free (X); end loop; @@ -211,15 +202,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.Last := null; Container.Length := 0; - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; - Free (X); end Clear; @@ -246,28 +228,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is X : Node_Access; begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= List_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); - if Position.Node = Container.First then Delete_First (Container, Count); Position := First (Container); @@ -292,17 +262,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.Last := X.Prev; Container.Last.Next := null; - X.Prev := null; -- prevent mischief - - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; - Free (X); return; end if; @@ -312,18 +271,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is X.Next.Prev := X.Prev; X.Prev.Next := X.Next; - X.Prev := null; - X.Next := null; - - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; - Free (X); end loop; end Delete; @@ -361,17 +308,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.Length := Container.Length - 1; - X.Next := null; -- prevent mischief - - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; - Free (X); end loop; end Delete_First; @@ -409,17 +345,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Container.Length := Container.Length - 1; - X.Prev := null; -- prevent mischief - - begin - Free (X.Element); - exception - when others => - X.Element := null; - Free (X); - raise; - end; - Free (X); end loop; end Delete_Last; @@ -430,21 +355,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); + pragma Assert (Vet (Position), "bad cursor in Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; return Position.Node.Element.all; end Element; @@ -465,23 +380,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.First; else - if Position.Container /= List_Access'(Container'Unchecked_Access) then + pragma Assert (Vet (Position), "bad cursor in Find"); + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); end if; while Node /= null loop @@ -514,9 +417,37 @@ 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; + end if; + return Container.First.Element.all; end First_Element; + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + X.Next := X; + X.Prev := X; + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + --------------------- -- Generic_Sorting -- --------------------- @@ -686,27 +617,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; ------------ @@ -723,24 +635,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is New_Node : Node_Access; begin - if Before.Node /= null then - if Before.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); + pragma Assert (Vet (Before), "bad cursor in Insert"); - pragma Assert (Before.Node.Element /= null); - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Container.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Container.Last); + if Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error; end if; if Count = 0 then @@ -884,32 +784,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Iterate; ---------- - -- Move -- - ---------- - - procedure Move (Target : in out List; Source : in out List) is - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Busy > 0 then - raise Program_Error; - end if; - - Clear (Target); - - Target.First := Source.First; - Source.First := null; - - Target.Last := Source.Last; - Source.Last := null; - - Target.Length := Source.Length; - Source.Length := 0; - end Move; - - ---------- -- Last -- ---------- @@ -928,6 +802,10 @@ 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; + end if; + return Container.Last.Element.all; end Last_Element; @@ -941,31 +819,43 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end Length; ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Busy > 0 then + raise Program_Error; + end if; + + Clear (Target); + + Target.First := Source.First; + Source.First := null; + + Target.Last := Source.Last; + Source.Last := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- -- Next -- ---------- procedure Next (Position : in out Cursor) is begin + pragma Assert (Vet (Position), "bad cursor in procedure Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - Position.Node := Position.Node.Next; if Position.Node = null then @@ -975,26 +865,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - declare Next_Node : constant Node_Access := Position.Node.Next; begin @@ -1025,26 +901,12 @@ 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 - pragma Assert (Position.Container = null); return; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - Position.Node := Position.Node.Prev; if Position.Node = null then @@ -1054,26 +916,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Previous (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Previous"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - declare Prev_Node : constant Node_Access := Position.Node.Prev; begin @@ -1093,43 +941,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in Element_Type)) is - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - E : Element_Type renames Position.Node.Element.all; - - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Query_Element; ---------- @@ -1193,31 +1032,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; By : Element_Type) is - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - X : Element_Access := Position.Node.Element; - begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + if Position.Container = null then + raise Constraint_Error; + end if; + if Position.Container.Lock > 0 then raise Program_Error; end if; - Position.Node.Element := new Element_Type'(By); - Free (X); + declare + X : Element_Access := Position.Node.Element; + begin + Position.Node.Element := new Element_Type'(By); + Free (X); + end; end Replace_Element; ------------------ @@ -1236,23 +1067,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.Last; else - if Position.Container /= List_Access'(Container'Unchecked_Access) then + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - - pragma Assert (Container.Length > 0); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Container.Last); end if; while Node /= null loop @@ -1392,24 +1211,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Source : in out List) is begin - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; - - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); + pragma Assert (Vet (Before), "bad cursor in Splice"); - pragma Assert (Before.Node.Element /= null); - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unrestricted_Access + then + raise Program_Error; end if; if Target'Address = Source'Address @@ -1477,48 +1284,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) is begin - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; - - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - pragma Assert (Before.Node.Element /= null); - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unchecked_Access + then + raise Program_Error; end if; if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= List_Access'(Target'Unchecked_Access) then + if Position.Container /= Target'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Target.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Target.Last); - if Position.Node = Before.Node or else Position.Node.Next = Before.Node then @@ -1606,48 +1388,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if Before.Node /= null then - if Before.Container /= List_Access'(Target'Unchecked_Access) then - raise Program_Error; - end if; - - pragma Assert (Target.Length >= 1); - pragma Assert (Target.First.Prev = null); - pragma Assert (Target.Last.Next = null); + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + pragma Assert (Vet (Position), "bad Position cursor in Splice"); - pragma Assert (Before.Node.Element /= null); - pragma Assert (Before.Node.Prev = null - or else Before.Node.Prev.Next = Before.Node); - pragma Assert (Before.Node.Next = null - or else Before.Node.Next.Prev = Before.Node); - pragma Assert (Before.Node.Prev /= null - or else Before.Node = Target.First); - pragma Assert (Before.Node.Next /= null - or else Before.Node = Target.Last); + if Before.Container /= null + and then Before.Container /= Target'Unrestricted_Access + then + raise Program_Error; end if; if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= List_Access'(Source'Unchecked_Access) then + if Position.Container /= Source'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Source.Length >= 1); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last.Next = null); - - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Source.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Source.Last); - if Target.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -1660,12 +1417,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is if Position.Node = Source.First then Source.First := Position.Node.Next; - Source.First.Prev := null; if Position.Node = Source.Last then pragma Assert (Source.First = null); pragma Assert (Source.Length = 1); Source.Last := null; + + else + Source.First.Prev := null; end if; elsif Position.Node = Source.Last then @@ -1727,8 +1486,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Swap (I, J : Cursor) is begin - if I.Container = null - or else J.Container = null + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + if I.Node = null + or else J.Node = null then raise Constraint_Error; end if; @@ -1737,50 +1499,19 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is raise Program_Error; end if; - declare - C : List renames I.Container.all; - begin - pragma Assert (C.Length > 0); - pragma Assert (C.First.Prev = null); - pragma Assert (C.Last.Next = null); - - pragma Assert (I.Node /= null); - pragma Assert (I.Node.Element /= null); - pragma Assert (I.Node.Prev = null - or else I.Node.Prev.Next = I.Node); - pragma Assert (I.Node.Next = null - or else I.Node.Next.Prev = I.Node); - pragma Assert (I.Node.Prev /= null - or else I.Node = C.First); - pragma Assert (I.Node.Next /= null - or else I.Node = C.Last); - - if I.Node = J.Node then - return; - end if; + if I.Node = J.Node then + return; + end if; - pragma Assert (C.Length > 1); - pragma Assert (J.Node /= null); - pragma Assert (J.Node.Element /= null); - pragma Assert (J.Node.Prev = null - or else J.Node.Prev.Next = J.Node); - pragma Assert (J.Node.Next = null - or else J.Node.Next.Prev = J.Node); - pragma Assert (J.Node.Prev /= null - or else J.Node = C.First); - pragma Assert (J.Node.Next /= null - or else J.Node = C.Last); - - if C.Lock > 0 then - raise Program_Error; - end if; + if I.Container.Lock > 0 then + raise Program_Error; + end if; - declare - EI_Copy : constant Element_Access := I.Node.Element; - begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI_Copy; - end; + declare + EI_Copy : constant Element_Access := I.Node.Element; + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI_Copy; end; end Swap; @@ -1793,51 +1524,25 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - if I.Container = null - or else J.Container = null + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + if I.Node = null + or else J.Node = null then raise Constraint_Error; end if; - if I.Container /= List_Access'(Container'Unchecked_Access) then - raise Program_Error; - end if; - - if J.Container /= I.Container then + if I.Container /= Container'Unrestricted_Access + or else I.Container /= J.Container + then raise Program_Error; end if; - pragma Assert (Container.Length >= 1); - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - pragma Assert (I.Node /= null); - pragma Assert (I.Node.Element /= null); - pragma Assert (I.Node.Prev = null - or else I.Node.Prev.Next = I.Node); - pragma Assert (I.Node.Next = null - or else I.Node.Next.Prev = I.Node); - pragma Assert (I.Node.Prev /= null - or else I.Node = Container.First); - pragma Assert (I.Node.Next /= null - or else I.Node = Container.Last); - if I.Node = J.Node then return; end if; - pragma Assert (Container.Length >= 2); - pragma Assert (J.Node /= null); - pragma Assert (J.Node.Element /= null); - pragma Assert (J.Node.Prev = null - or else J.Node.Prev.Next = J.Node); - pragma Assert (J.Node.Next = null - or else J.Node.Next.Prev = J.Node); - pragma Assert (J.Node.Prev /= null - or else J.Node = Container.First); - pragma Assert (J.Node.Next /= null - or else J.Node = Container.Last); - if Container.Busy > 0 then raise Program_Error; end if; @@ -1878,45 +1583,179 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Position : Cursor; Process : not null access procedure (Element : in out Element_Type)) is - pragma Assert (Position.Container /= null); - pragma Assert (Position.Container.Length > 0); - pragma Assert (Position.Container.First.Prev = null); - pragma Assert (Position.Container.Last.Next = null); - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Position.Node.Prev = null - or else Position.Node.Prev.Next = Position.Node); - pragma Assert (Position.Node.Next = null - or else Position.Node.Next.Prev = Position.Node); - pragma Assert (Position.Node.Prev /= null - or else Position.Node = Position.Container.First); - pragma Assert (Position.Node.Next /= null - or else Position.Node = Position.Container.Last); - - E : Element_Type renames Position.Node.Element.all; - - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; - begin - B := B + 1; - L := L + 1; + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Update_Element; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + L : List renames Position.Container.all; + begin + if L.Length = 0 then + return False; + end if; + + if L.First = null then + return False; + end if; + + if L.Last = null then + return False; + end if; + + if L.First.Prev /= null then + return False; + end if; + + if L.Last.Next /= null then + return False; + end if; + + if Position.Node.Prev = null + and then Position.Node /= L.First + then + return False; + end if; + + if Position.Node.Next = null + and then Position.Node /= L.Last + then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if L.First.Next = null then + return False; + end if; + + if L.Last.Prev = null then + return False; + end if; + + if L.First.Next.Prev /= L.First then + return False; + end if; + + if L.Last.Prev.Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if L.First.Next /= L.Last then + return False; + end if; + + if L.Last.Prev /= L.First then + return False; + end if; + + return True; + end if; + + if L.First.Next = L.Last then + return False; + end if; + + if L.Last.Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if Position.Node.Next = null then + return False; + end if; + + if Position.Node.Prev = null then + return False; + end if; + + if Position.Node.Next.Prev /= Position.Node then + return False; + end if; + + if Position.Node.Prev.Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if L.First.Next /= Position.Node then + return False; + end if; + + if L.Last.Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + ----------- -- Write -- ----------- @@ -1926,8 +1765,10 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Item : List) is Node : Node_Access := Item.First; + begin Count_Type'Base'Write (Stream, Item.Length); + while Node /= null loop Element_Type'Output (Stream, Node.Element.all); -- X.all Node := Node.Next; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 16fcd6e..dc5fa0f8 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -194,19 +194,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then raise Constraint_Error; - return; end if; - if Position.Container /= Map_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Position.Node.Next /= Position.Node); - pragma Assert (Position.Node.Key /= null); - pragma Assert (Position.Node.Element /= null); - if Container.HT.Busy > 0 then raise Program_Error; end if; @@ -222,14 +219,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ------------- function Element (Container : Map; Key : Key_Type) return Element_Type is - C : constant Cursor := Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + begin - return C.Node.Element.all; + if Node = null then + raise Constraint_Error; + end if; + + return Node.Element.all; end Element; function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Vet (Position)); + pragma Assert (Vet (Position), "bad cursor in function Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Position.Node.Element.all; end Element; @@ -251,8 +258,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - pragma Assert (Vet (Left)); - pragma Assert (Vet (Right)); + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); end Equivalent_Keys; @@ -261,7 +275,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Key_Type) return Boolean is begin - pragma Assert (Vet (Left)); + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + if Left.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left.Node.Key.all, Right); end Equivalent_Keys; @@ -270,7 +289,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Right : Cursor) return Boolean is begin - pragma Assert (Vet (Right)); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Right.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left, Right.Node.Key.all); end Equivalent_Keys; @@ -338,6 +362,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function First (Container : Map) return Cursor is Node : constant Node_Access := HT_Ops.First (Container.HT); + begin if Node = null then return No_Element; @@ -396,13 +421,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - pragma Assert (Vet (Position)); - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; --------------- @@ -468,7 +488,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is is function New_Node (Next : Node_Access) return Node_Access; - procedure Insert is + procedure Local_Insert is new Key_Ops.Generic_Conditional_Insert (New_Node); -------------- @@ -478,6 +498,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function New_Node (Next : Node_Access) return Node_Access is K : Key_Access := new Key_Type'(Key); E : Element_Access; + begin E := new Element_Type'(New_Item); return new Node_Type'(K, E, Next); @@ -493,12 +514,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -- Start of processing for Insert begin - if HT.Length >= HT_Ops.Capacity (HT) then - -- TODO: see note in a-cohama.adb. - HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -562,7 +589,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - pragma Assert (Vet (Position)); + pragma Assert (Vet (Position), "bad cursor in function Key"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Position.Node.Key.all; end Key; @@ -603,13 +635,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; declare - pragma Assert (Vet (Position)); HT : Hash_Table_Type renames Position.Container.HT; Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); @@ -631,32 +663,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Process : not null access procedure (Key : Key_Type; Element : Element_Type)) is - pragma Assert (Vet (Position)); - - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; + begin + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + if Position.Node = null then + raise Constraint_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - begin - B := B + 1; - L := L + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Query_Element; ---------- @@ -748,15 +788,24 @@ package body Ada.Containers.Indefinite_Hashed_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is - pragma Assert (Vet (Position)); - X : Element_Access := Position.Node.Element; begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + if Position.Container.HT.Lock > 0 then raise Program_Error; end if; - Position.Node.Element := new Element_Type'(By); - Free_Element (X); + declare + X : Element_Access := Position.Node.Element; + + begin + Position.Node.Element := new Element_Type'(By); + Free_Element (X); + end; end Replace_Element; ---------------------- @@ -789,32 +838,40 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)) is - pragma Assert (Vet (Position)); + begin + pragma Assert (Vet (Position), "bad cursor in Update_Element"); - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; + if Position.Node = null then + raise Constraint_Error; + end if; - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; - - begin - B := B + 1; - L := L + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + declare + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Update_Element; --------- @@ -824,6 +881,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Vet (Position : Cursor) return Boolean is begin if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then return False; end if; @@ -842,12 +903,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare HT : Hash_Table_Type renames Position.Container.HT; X : Node_Access; + begin if HT.Length = 0 then return False; end if; - if HT.Buckets = null then + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then return False; end if; @@ -862,7 +926,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return False; end if; - if X = X.Next then -- weird + if X = X.Next then -- to prevent endless loop return False; end if; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 24f7250..8e747ea 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -84,13 +84,15 @@ package body Ada.Containers.Indefinite_Hashed_Sets is pragma Inline (Read_Node); procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Element : Element_Type); + (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); + function Vet (Position : Cursor) return Boolean; + procedure Write_Node (Stream : access Root_Stream_Type'Class; Node : Node_Access); @@ -217,11 +219,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : in out Cursor) is begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Node.Element = null then + raise Program_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; @@ -232,7 +240,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); Free (Position.Node); - Position.Container := null; end Delete; @@ -351,6 +358,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Vet (Position), "bad cursor in function Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then -- handle dangling reference + raise Program_Error; + end if; + return Position.Node.Element.all; end Element; @@ -370,6 +387,21 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Element = null -- handle dangling cursor reference + or else Right.Node.Element = null + then + raise Program_Error; + end if; + return Equivalent_Elements (Left.Node.Element.all, Right.Node.Element.all); @@ -378,12 +410,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Elements (Left : Cursor; Right : Element_Type) return Boolean is begin + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Element = null then -- handling dangling reference + raise Program_Error; + end if; + return Equivalent_Elements (Left.Node.Element.all, Right); end Equivalent_Elements; function Equivalent_Elements (Left : Element_Type; Right : Cursor) return Boolean is begin + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Element = null then -- handle dangling cursor reference + raise Program_Error; + end if; + return Equivalent_Elements (Left, Right.Node.Element.all); end Equivalent_Elements; @@ -520,6 +572,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return; end if; + X.Next := X; -- detect mischief (in Vet) + begin Free_Element (X.Element); exception @@ -538,12 +592,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; --------------- @@ -597,7 +647,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function New_Node (Next : Node_Access) return Node_Access; pragma Inline (New_Node); - procedure Insert is + procedure Local_Insert is new Element_Keys.Generic_Conditional_Insert (New_Node); -------------- @@ -620,12 +670,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is -- Start of processing for Insert begin - if HT.Length >= HT_Ops.Capacity (HT) then - -- TODO: optimize this (see a-cohase.adb) - HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, New_Item, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Insert (HT, New_Item, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -763,7 +819,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Container.Length = 0; + return Container.HT.Length = 0; end Is_Empty; ----------- @@ -833,22 +889,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Process_Node; HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - B : Natural renames HT.Busy; -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (HT); - exception - when others => - B := B - 1; - raise; - end; + -- TODO: resolve whether HT_Ops.Generic_Iteration should + -- manipulate busy bit. - B := B - 1; + Iterate (HT); end Iterate; ------------ @@ -880,11 +928,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + declare HT : Hash_Table_Type renames Position.Container.HT; Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); @@ -939,29 +992,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element.all; + begin + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - HT : Hash_Table_Type renames - Position.Container'Unrestricted_Access.all.HT; + if Position.Node = null then + raise Constraint_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + if Position.Node.Element = null then + raise Program_Error; + end if; - begin - B := B + 1; - L := L + 1; + declare + HT : Hash_Table_Type renames + Position.Container'Unrestricted_Access.all.HT; + + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; - L := L - 1; - B := B - 1; + begin + Process (Position.Node.Element.all); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; + end; end Query_Element; ---------- @@ -1027,13 +1091,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is --------------------- procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Element : Element_Type) + (HT : in out Hash_Table_Type; + Node : Node_Access; + New_Item : Element_Type) is begin - if Equivalent_Elements (Node.Element.all, Element) then - pragma Assert (Hash (Node.Element.all) = Hash (Element)); + 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; @@ -1042,7 +1106,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is declare X : Element_Access := Node.Element; begin - Node.Element := new Element_Type'(Element); -- OK if fails + Node.Element := new Element_Type'(New_Item); -- OK if fails Free_Element (X); end; @@ -1068,7 +1132,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function New_Node (Next : Node_Access) return Node_Access is begin - Node.Element := new Element_Type'(Element); -- OK if fails + Node.Element := new Element_Type'(New_Item); -- OK if fails Node.Next := Next; return Node; end New_Node; @@ -1084,7 +1148,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Attempt_Insert : begin Insert (HT => HT, - Key => Element, + Key => New_Item, Node => Result, Inserted => Inserted); exception @@ -1093,7 +1157,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Attempt_Insert; if Inserted then - pragma Assert (Result = Node); Free_Element (X); -- Just propagate if fails return; end if; @@ -1137,22 +1200,26 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Replace_Element; procedure Replace_Element - (Container : Set; + (Container : in out Set; Position : Cursor; - By : Element_Type) + New_Item : Element_Type) is - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unrestricted_Access) then + if Position.Node.Element = null then + raise Program_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Replace_Element (HT, Position.Node, By); + Replace_Element (Container.HT, Position.Node, New_Item); end Replace_Element; ---------------------- @@ -1613,6 +1680,65 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return (Controlled with HT => (Buckets, Length, 0, 0)); end Union; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + ----------- -- Write -- ----------- @@ -1714,29 +1840,9 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Key : Key_Type; Node : Node_Access) return Boolean is begin - return Equivalent_Keys (Key, Node.Element.all); + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all)); end Equivalent_Key_Node; - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean - is - begin - return Equivalent_Keys (Right, Left.Node.Element.all); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean - is - begin - return Equivalent_Keys (Left, Right.Node.Element.all); - end Equivalent_Keys; - ------------- -- Exclude -- ------------- @@ -1775,6 +1881,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin + pragma Assert (Vet (Position), "bad cursor in function Key"); + + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + return Key (Position.Node.Element.all); end Key; @@ -1804,20 +1920,40 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process : not null access procedure (Element : in out Element_Type)) is - HT : Hash_Table_Type renames Container.HT; + HT : Hash_Table_Type renames Container.HT; + Indx : Hash_Type; begin + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Node.Element = null + or else Position.Node.Next = Position.Node + then raise Program_Error; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0 + then + raise Program_Error; + end if; + + Indx := HT_Ops.Index (HT, Position.Node); + declare E : Element_Type renames Position.Node.Element.all; - K : Key_Type renames Key (E); + K : constant Key_Type := Key (E); B : Natural renames HT.Busy; L : Natural renames HT.Lock; @@ -1838,16 +1974,38 @@ package body Ada.Containers.Indefinite_Hashed_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, E) then + if Equivalent_Keys (K, Key (E)) then pragma Assert (Hash (K) = Hash (E)); return; end if; end; + if HT.Buckets (Indx) = Position.Node then + HT.Buckets (Indx) := Position.Node.Next; + + else + declare + Prev : Node_Access := HT.Buckets (Indx); + + begin + while Prev.Next /= Position.Node loop + Prev := Prev.Next; + + if Prev = null then + raise Program_Error; + end if; + end loop; + + Prev.Next := Position.Node.Next; + end; + end if; + + HT.Length := HT.Length - 1; + declare X : Node_Access := Position.Node; + begin - HT_Ops.Delete_Node_Sans_Free (HT, X); Free (X); end; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index 6227710..4ecca1c 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -49,8 +49,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Hashed_Sets is - - pragma Preelaborate (Indefinite_Hashed_Sets); + pragma Preelaborate; type Set is tagged private; @@ -64,6 +63,12 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function Capacity (Container : Set) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type); + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -72,15 +77,15 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - procedure Replace_Element - (Container : Set; - Position : Cursor; - By : Element_Type); - procedure Move (Target : in out Set; Source : in out Set); @@ -97,37 +102,11 @@ package Ada.Containers.Indefinite_Hashed_Sets is procedure Replace (Container : in out Set; New_Item : Element_Type); - procedure Delete (Container : in out Set; Item : Element_Type); - - procedure Delete (Container : in out Set; Position : in out Cursor); - procedure Exclude (Container : in out Set; Item : Element_Type); - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function Find (Container : Set; Item : Element_Type) return Cursor; - - function First (Container : Set) return Cursor; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Has_Element (Position : Cursor) return Boolean; - - function Equivalent_Elements (Left, Right : Cursor) return Boolean; - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean; - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean; + procedure Delete (Container : in out Set; Item : Element_Type); - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); + procedure Delete (Container : in out Set; Position : in out Cursor); procedure Union (Target : in out Set; Source : Set); @@ -158,41 +137,59 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - function Capacity (Container : Set) return Count_Type; + function First (Container : Set) return Cursor; - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type); + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); generic - type Key_Type (<>) is limited private; + type Key_Type (<>) is private; with function Key (Element : Element_Type) return Key_Type; with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys - (Key : Key_Type; - Element : Element_Type) return Boolean; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; package Generic_Keys is - function Contains (Container : Set; Key : Key_Type) return Boolean; - - function Find (Container : Set; Key : Key_Type) return Cursor; - function Key (Position : Cursor) return Key_Type; function Element (Container : Set; Key : Key_Type) return Element_Type; - procedure Replace + procedure Replace -- TODO: ask Randy why this is still here (Container : in out Set; Key : Key_Type; New_Item : Element_Type); + procedure Exclude (Container : in out Set; Key : Key_Type); + procedure Delete (Container : in out Set; Key : Key_Type); - procedure Exclude (Container : in out Set; Key : Key_Type); + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; procedure Update_Element_Preserving_Key (Container : in out Set; @@ -200,13 +197,6 @@ package Ada.Containers.Indefinite_Hashed_Sets is Process : not null access procedure (Element : in out Element_Type)); - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean; end Generic_Keys; private diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index ed42d01..2de8cda 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -369,6 +369,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Position.Node.Element.all; end Element; + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + --------------------- -- Equivalent_Sets -- --------------------- @@ -528,34 +543,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - --------- - -- "<" -- - --------- - - function "<" (Left : Key_Type; Right : Cursor) return Boolean is - begin - return Left < Right.Node.Element.all; - end "<"; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean is - begin - return Right > Left.Node.Element.all; - end "<"; - - --------- - -- ">" -- - --------- - - function ">" (Left : Key_Type; Right : Cursor) return Boolean is - begin - return Left > Right.Node.Element.all; - end ">"; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean is - begin - return Right < Left.Node.Element.all; - end ">"; - ------------- -- Ceiling -- ------------- @@ -609,6 +596,21 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Node.Element.all; end Element; + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + ------------- -- Exclude -- ------------- @@ -663,7 +665,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Left : Key_Type; Right : Node_Access) return Boolean is begin - return Left > Right.Element.all; + return Key (Right.Element.all) < Left; end Is_Greater_Key_Node; ---------------------- @@ -674,7 +676,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Left : Key_Type; Right : Node_Access) return Boolean is begin - return Left < Right.Element.all; + return Left < Key (Right.Element.all); end Is_Less_Key_Node; --------- @@ -728,7 +730,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is declare E : Element_Type renames Position.Node.Element.all; - K : Key_Type renames Key (E); + K : constant Key_Type := Key (E); B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; @@ -749,11 +751,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is L := L - 1; B := B - 1; - if K < E - or else K > E - then - null; - else + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1365,12 +1363,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end Replace_Element; procedure Replace_Element - (Container : Set; + (Container : in out Set; Position : Cursor; - By : Element_Type) + New_Item : Element_Type) is - Tree : Tree_Type renames Position.Container.Tree'Unrestricted_Access.all; - begin if Position.Node = null then raise Constraint_Error; @@ -1380,7 +1376,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error; end if; - Replace_Element (Tree, Position.Node, By); + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; --------------------- diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index 2936070..7634960 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -45,7 +45,9 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Ordered_Sets is -pragma Preelaborate (Indefinite_Ordered_Sets); + pragma Preelaborate; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; type Set is tagged private; @@ -67,15 +69,15 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - procedure Replace_Element - (Container : Set; -- TODO: need ruling from ARG - Position : Cursor; - By : Element_Type); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -96,6 +98,10 @@ pragma Preelaborate (Indefinite_Ordered_Sets); (Container : in out Set; New_Item : Element_Type); + procedure Exclude + (Container : in out Set; + Item : Element_Type); + procedure Delete (Container : in out Set; Item : Element_Type); @@ -108,10 +114,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets); procedure Delete_Last (Container : in out Set); - procedure Exclude - (Container : in out Set; - Item : Element_Type); - procedure Union (Target : in out Set; Source : Set); function Union (Left, Right : Set) return Set; @@ -124,8 +126,7 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function "and" (Left, Right : Set) return Set renames Intersection; - procedure Difference (Target : in out Set; - Source : Set); + procedure Difference (Target : in out Set; Source : Set); function Difference (Left, Right : Set) return Set; @@ -141,14 +142,6 @@ pragma Preelaborate (Indefinite_Ordered_Sets); function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function Find (Container : Set; Item : Element_Type) return Cursor; - - function Floor (Container : Set; Item : Element_Type) return Cursor; - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - function First (Container : Set) return Cursor; function First_Element (Container : Set) return Element_Type; @@ -165,6 +158,14 @@ pragma Preelaborate (Indefinite_Ordered_Sets); procedure Previous (Position : in out Cursor); + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + function Has_Element (Position : Cursor) return Boolean; function "<" (Left, Right : Cursor) return Boolean; @@ -188,21 +189,28 @@ pragma Preelaborate (Indefinite_Ordered_Sets); Process : not null access procedure (Position : Cursor)); generic - type Key_Type (<>) is limited private; + type Key_Type (<>) is private; with function Key (Element : Element_Type) return Key_Type; - with function "<" (Left : Key_Type; Right : Element_Type) - return Boolean is <>; - - with function ">" (Left : Key_Type; Right : Element_Type) - return Boolean is <>; + with function "<" (Left, Right : Key_Type) return Boolean is <>; package Generic_Keys is - function Contains - (Container : Set; - Key : Key_Type) return Boolean; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); function Find (Container : Set; @@ -216,28 +224,9 @@ pragma Preelaborate (Indefinite_Ordered_Sets); (Container : Set; Key : Key_Type) return Cursor; - function Key (Position : Cursor) return Key_Type; - - function Element + function Contains (Container : Set; - Key : Key_Type) return Element_Type; - - procedure Replace - (Container : in out Set; -- TODO: need ruling from ARG - Key : Key_Type; - New_Item : Element_Type); - - procedure Delete (Container : in out Set; Key : Key_Type); - - procedure Exclude (Container : in out Set; Key : Key_Type); - - function "<" (Left : Cursor; Right : Key_Type) return Boolean; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean; + Key : Key_Type) return Boolean; procedure Update_Element_Preserving_Key (Container : in out Set; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index c204685..1a16549 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -188,16 +188,16 @@ package body Ada.Containers.Hashed_Maps is procedure Delete (Container : in out Map; Position : in out Cursor) is begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Map_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - pragma Assert (Position.Node.Next /= Position.Node); - if Container.HT.Busy > 0 then raise Program_Error; end if; @@ -213,14 +213,24 @@ package body Ada.Containers.Hashed_Maps is ------------- function Element (Container : Map; Key : Key_Type) return Element_Type is - C : constant Cursor := Find (Container, Key); + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + begin - return C.Node.Element; + if Node = null then + raise Constraint_Error; + end if; + + return Node.Element; end Element; function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Vet (Position)); + pragma Assert (Vet (Position), "bad cursor in function Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Position.Node.Element; end Element; @@ -242,20 +252,37 @@ package body Ada.Containers.Hashed_Maps is function Equivalent_Keys (Left, Right : Cursor) return Boolean is begin - pragma Assert (Vet (Left)); - pragma Assert (Vet (Right)); + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left.Node.Key, Right.Node.Key); end Equivalent_Keys; function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is begin - pragma Assert (Vet (Left)); + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + if Left.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left.Node.Key, Right); end Equivalent_Keys; function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is begin - pragma Assert (Vet (Right)); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Right.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Keys (Left, Right.Node.Key); end Equivalent_Keys; @@ -352,13 +379,8 @@ package body Ada.Containers.Hashed_Maps is function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - pragma Assert (Vet (Position)); - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; --------------- @@ -435,25 +457,18 @@ package body Ada.Containers.Hashed_Maps is -- Start of processing for Insert begin - if HT.Length >= HT_Ops.Capacity (HT) then + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; - -- TODO: 17 Apr 2005 - -- We should defer the expansion until we're sure that the - -- element was successfully inserted. We can do that by - -- first performing the insertion attempt, and allowing the - -- invariant len <= cap to be violated temporarily. After - -- the insertion we can restore the invariant. The - -- worst that can happen is that the insertion succeeds - -- (new element is added to the map), but the - -- invariant is broken (len > cap). But it's only - -- broken by a little (since len = cap + 1), so the - -- effect is benign. - -- END TODO. + Local_Insert (HT, Key, Position.Node, Inserted); - HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Local_Insert (HT, Key, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -485,12 +500,18 @@ package body Ada.Containers.Hashed_Maps is -- Start of processing for Insert begin - if HT.Length >= HT_Ops.Capacity (HT) then - -- TODO: see note above. - HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); end if; Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + Position.Container := Container'Unchecked_Access; end Insert; @@ -553,7 +574,12 @@ package body Ada.Containers.Hashed_Maps is function Key (Position : Cursor) return Key_Type is begin - pragma Assert (Vet (Position)); + pragma Assert (Vet (Position), "bad cursor in function Key"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Position.Node.Key; end Key; @@ -589,16 +615,15 @@ package body Ada.Containers.Hashed_Maps is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; declare - pragma Assert (Vet (Position)); HT : Hash_Table_Type renames Position.Container.HT; Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); - begin if Node = null then return No_Element; @@ -621,34 +646,41 @@ package body Ada.Containers.Hashed_Maps is (Position : Cursor; Process : not null access procedure (Key : Key_Type; Element : Element_Type)) - is - pragma Assert (Vet (Position)); - - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; + begin + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + if Position.Node = null then + raise Constraint_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - begin - B := B + 1; - L := L + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end; - - L := L - 1; - B := B - 1; end Query_Element; ---------- @@ -712,15 +744,18 @@ package body Ada.Containers.Hashed_Maps is --------------------- procedure Replace_Element (Position : Cursor; By : Element_Type) is - pragma Assert (Vet (Position)); - E : Element_Type renames Position.Node.Element; - begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + if Position.Container.HT.Lock > 0 then raise Program_Error; end if; - E := By; + Position.Node.Element := By; end Replace_Element; ---------------------- @@ -753,32 +788,40 @@ package body Ada.Containers.Hashed_Maps is Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)) is - pragma Assert (Vet (Position)); - - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; + begin + pragma Assert (Vet (Position), "bad cursor in Update_Element"); - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + if Position.Node = null then + raise Constraint_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - begin - B := B + 1; - L := L + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; + B := B + 1; + L := L + 1; + + declare + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + + begin + Process (K, E); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; + + L := L - 1; + B := B - 1; end; - - L := L - 1; - B := B - 1; end Update_Element; --------- @@ -788,34 +831,32 @@ package body Ada.Containers.Hashed_Maps is function Vet (Position : Cursor) return Boolean is begin if Position.Node = null then - return False; + return Position.Container = null; end if; - if Position.Node.Next = Position.Node then + if Position.Container = null then return False; end if; - if Position.Container = null then + if Position.Node.Next = Position.Node then return False; end if; declare HT : Hash_Table_Type renames Position.Container.HT; X : Node_Access; + begin if HT.Length = 0 then return False; end if; - if HT.Buckets = null then + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then return False; end if; --- NOTE: see notes in Insert. --- if HT.Length > HT.Buckets'Length then --- return False; --- end if; - X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key)); for J in 1 .. HT.Length loop @@ -827,7 +868,7 @@ package body Ada.Containers.Hashed_Maps is return False; end if; - if X = X.Next then -- weird + if X = X.Next then -- to prevent endless loop return False; end if; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 93be385..05a2416 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -67,6 +67,8 @@ package body Ada.Containers.Hashed_Sets is (R_HT : Hash_Table_Type; L_Node : Node_Access) return Boolean; + procedure Free (X : in out Node_Access); + function Hash_Node (Node : Node_Access) return Hash_Type; pragma Inline (Hash_Node); @@ -83,13 +85,15 @@ package body Ada.Containers.Hashed_Sets is pragma Inline (Read_Node); procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Element : Element_Type); + (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); + function Vet (Position : Cursor) return Boolean; + procedure Write_Node (Stream : access Root_Stream_Type'Class; Node : Node_Access); @@ -99,9 +103,6 @@ package body Ada.Containers.Hashed_Sets is -- Local Instantiations -- -------------------------- - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package HT_Ops is new Hash_Tables.Generic_Operations (HT_Types => HT_Types, @@ -211,11 +212,13 @@ package body Ada.Containers.Hashed_Sets is Position : in out Cursor) is begin + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; @@ -226,7 +229,6 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); Free (Position.Node); - Position.Container := null; end Delete; @@ -345,6 +347,12 @@ package body Ada.Containers.Hashed_Sets is function Element (Position : Cursor) return Element_Type is begin + pragma Assert (Vet (Position), "bad cursor in function Element"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Position.Node.Element; end Element; @@ -364,18 +372,39 @@ package body Ada.Containers.Hashed_Sets is function Equivalent_Elements (Left, Right : Cursor) return Boolean is begin + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + return Equivalent_Elements (Left.Node.Element, Right.Node.Element); end Equivalent_Elements; function Equivalent_Elements (Left : Cursor; Right : Element_Type) return Boolean is begin + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + if Left.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Elements (Left.Node.Element, Right); end Equivalent_Elements; function Equivalent_Elements (Left : Element_Type; Right : Cursor) return Boolean is begin + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + if Right.Node = null then + raise Constraint_Error; + end if; + return Equivalent_Elements (Left, Right.Node.Element); end Equivalent_Elements; @@ -499,18 +528,29 @@ package body Ada.Containers.Hashed_Sets is return Cursor'(Container'Unrestricted_Access, Node); end First; + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + ----------------- -- Has_Element -- ----------------- function Has_Element (Position : Cursor) return Boolean is begin - if Position.Node = null then - pragma Assert (Position.Container = null); - return False; - end if; - - return True; + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; end Has_Element; --------------- @@ -576,18 +616,18 @@ package body Ada.Containers.Hashed_Sets is -- Start of processing for Insert begin - if HT.Length >= HT_Ops.Capacity (HT) then + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; - -- TODO: - -- Perform the insertion first, and then reserve - -- capacity, but only if the insertion succeeds and - -- the (new) length is greater then current capacity. - -- END TODO. + Local_Insert (HT, New_Item, Position.Node, Inserted); - HT_Ops.Reserve_Capacity (HT, HT.Length + 1); + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Local_Insert (HT, New_Item, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; end Insert; @@ -725,7 +765,7 @@ package body Ada.Containers.Hashed_Sets is function Is_Empty (Container : Set) return Boolean is begin - return Container.Length = 0; + return Container.HT.Length = 0; end Is_Empty; ----------- @@ -790,23 +830,13 @@ package body Ada.Containers.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 HT.Busy; - -- Start of processing for Iterate begin - B := B + 1; - - begin - Iterate (HT); - exception - when others => - B := B - 1; - raise; - end; + -- TODO: resolve whether HT_Ops.Generic_Iteration should + -- manipulate busy bit. - B := B - 1; + Iterate (Container.HT); end Iterate; ------------ @@ -838,8 +868,9 @@ package body Ada.Containers.Hashed_Sets is function Next (Position : Cursor) return Cursor is begin + pragma Assert (Vet (Position), "bad cursor in function Next"); + if Position.Node = null then - pragma Assert (Position.Container = null); return No_Element; end if; @@ -896,28 +927,35 @@ package body Ada.Containers.Hashed_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element; + begin + pragma Assert (Vet (Position), "bad cursor in Query_Element"); - HT : Hash_Table_Type renames Position.Container.HT; + if Position.Node = null then + raise Constraint_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + declare + HT : Hash_Table_Type renames Position.Container.HT; - begin - B := B + 1; - L := L + 1; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; + B := B + 1; + L := L + 1; + + begin + Process (Position.Node.Element); + exception + when others => + L := L - 1; + B := B - 1; + raise; + end; - L := L - 1; - B := B - 1; + L := L - 1; + B := B - 1; + end; end Query_Element; ---------- @@ -955,7 +993,7 @@ package body Ada.Containers.Hashed_Sets is ------------- procedure Replace - (Container : in out Set; -- TODO: need ruling from ARG + (Container : in out Set; New_Item : Element_Type) is Node : constant Node_Access := @@ -978,19 +1016,19 @@ package body Ada.Containers.Hashed_Sets is --------------------- procedure Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Element : Element_Type) + (HT : in out Hash_Table_Type; + Node : Node_Access; + New_Item : Element_Type) is begin - if Equivalent_Elements (Node.Element, Element) then - pragma Assert (Hash (Node.Element) = Hash (Element)); + if Equivalent_Elements (Node.Element, New_Item) then + pragma Assert (Hash (Node.Element) = Hash (New_Item)); if HT.Lock > 0 then raise Program_Error; end if; - Node.Element := Element; -- Note that this assignment can fail + Node.Element := New_Item; -- Note that this assignment can fail return; end if; @@ -1013,7 +1051,7 @@ package body Ada.Containers.Hashed_Sets is function New_Node (Next : Node_Access) return Node_Access is begin - Node.Element := Element; -- Note that this assignment can fail + Node.Element := New_Item; -- Note that this assignment can fail Node.Next := Next; return Node; end New_Node; @@ -1026,12 +1064,11 @@ package body Ada.Containers.Hashed_Sets is begin Local_Insert (HT => HT, - Key => Element, + Key => New_Item, Node => Result, Inserted => Inserted); if Inserted then - pragma Assert (Result = Node); return; end if; exception @@ -1076,22 +1113,22 @@ package body Ada.Containers.Hashed_Sets is end Replace_Element; procedure Replace_Element - (Container : Set; + (Container : in out Set; Position : Cursor; - By : Element_Type) + New_Item : Element_Type) is - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - begin + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unrestricted_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Replace_Element (HT, Position.Node, By); + Replace_Element (Container.HT, Position.Node, New_Item); end Replace_Element; ---------------------- @@ -1491,6 +1528,61 @@ package body Ada.Containers.Hashed_Sets is return (Controlled with HT => (Buckets, Length, 0, 0)); end Union; + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + ----------- -- Write -- ----------- @@ -1594,27 +1686,9 @@ package body Ada.Containers.Hashed_Sets is Node : Node_Access) return Boolean is begin - return Equivalent_Keys (Key, Node.Element); + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); end Equivalent_Key_Node; - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean is - begin - return Equivalent_Keys (Right, Left.Node.Element); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean is - begin - return Equivalent_Keys (Left, Right.Node.Element); - end Equivalent_Keys; - ------------- -- Exclude -- ------------- @@ -1654,6 +1728,12 @@ package body Ada.Containers.Hashed_Sets is function Key (Position : Cursor) return Key_Type is begin + pragma Assert (Vet (Position), "bad cursor in function Key"); + + if Position.Node = null then + raise Constraint_Error; + end if; + return Key (Position.Node.Element); end Key; @@ -1687,20 +1767,35 @@ package body Ada.Containers.Hashed_Sets is Process : not null access procedure (Element : in out Element_Type)) is - HT : Hash_Table_Type renames Container.HT; + HT : Hash_Table_Type renames Container.HT; + Indx : Hash_Type; begin + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Set_Access'(Container'Unchecked_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + if HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0 + or else Position.Node.Next = Position.Node + then + raise Program_Error; + end if; + + Indx := HT_Ops.Index (HT, Position.Node); + declare E : Element_Type renames Position.Node.Element; - K : Key_Type renames Key (E); + K : constant Key_Type := Key (E); B : Natural renames HT.Busy; L : Natural renames HT.Lock; @@ -1721,16 +1816,38 @@ package body Ada.Containers.Hashed_Sets is L := L - 1; B := B - 1; - if Equivalent_Keys (K, E) then + if Equivalent_Keys (K, Key (E)) then pragma Assert (Hash (K) = Hash (E)); return; end if; end; + if HT.Buckets (Indx) = Position.Node then + HT.Buckets (Indx) := Position.Node.Next; + + else + declare + Prev : Node_Access := HT.Buckets (Indx); + + begin + while Prev.Next /= Position.Node loop + Prev := Prev.Next; + + if Prev = null then + raise Program_Error; + end if; + end loop; + + Prev.Next := Position.Node.Next; + end; + end if; + + HT.Length := HT.Length - 1; + declare X : Node_Access := Position.Node; + begin - HT_Ops.Delete_Node_Sans_Free (HT, X); Free (X); end; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 67a92f5..e4734c8 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -48,7 +48,7 @@ generic with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Hashed_Sets is -pragma Preelaborate (Hashed_Sets); + pragma Preelaborate; type Set is tagged private; @@ -62,6 +62,12 @@ pragma Preelaborate (Hashed_Sets); function Equivalent_Sets (Left, Right : Set) return Boolean; + function Capacity (Container : Set) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type); + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -70,15 +76,15 @@ pragma Preelaborate (Hashed_Sets); function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - procedure Replace_Element - (Container : Set; - Position : Cursor; - By : Element_Type); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -93,39 +99,11 @@ pragma Preelaborate (Hashed_Sets); procedure Replace (Container : in out Set; New_Item : Element_Type); - procedure Delete (Container : in out Set; Item : Element_Type); - - procedure Delete (Container : in out Set; Position : in out Cursor); - procedure Exclude (Container : in out Set; Item : Element_Type); - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function Find - (Container : Set; - Item : Element_Type) return Cursor; - - function First (Container : Set) return Cursor; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Has_Element (Position : Cursor) return Boolean; - - function Equivalent_Elements (Left, Right : Cursor) return Boolean; - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean; - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean; + procedure Delete (Container : in out Set; Item : Element_Type); - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); + procedure Delete (Container : in out Set; Position : in out Cursor); procedure Union (Target : in out Set; Source : Set); @@ -156,41 +134,61 @@ pragma Preelaborate (Hashed_Sets); function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - function Capacity (Container : Set) return Count_Type; + function First (Container : Set) return Cursor; - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type); + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Has_Element (Position : Cursor) return Boolean; + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); generic - type Key_Type (<>) is limited private; + type Key_Type (<>) is private; with function Key (Element : Element_Type) return Key_Type; with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys - (Key : Key_Type; - Element : Element_Type) return Boolean; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; package Generic_Keys is - function Contains (Container : Set; Key : Key_Type) return Boolean; - - function Find (Container : Set; Key : Key_Type) return Cursor; - function Key (Position : Cursor) return Key_Type; function Element (Container : Set; Key : Key_Type) return Element_Type; - procedure Replace + procedure Replace -- TODO: ask Randy why this wasn't removed (Container : in out Set; Key : Key_Type; New_Item : Element_Type); + procedure Exclude (Container : in out Set; Key : Key_Type); + procedure Delete (Container : in out Set; Key : Key_Type); - procedure Exclude (Container : in out Set; Key : Key_Type); + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; procedure Update_Element_Preserving_Key (Container : in out Set; @@ -198,18 +196,9 @@ pragma Preelaborate (Hashed_Sets); Process : not null access procedure (Element : in out Element_Type)); - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean; - end Generic_Keys; private - type Node_Type; type Node_Access is access Node_Type; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index d088672..04652f8 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -359,6 +359,21 @@ package body Ada.Containers.Ordered_Sets is return Position.Node.Element; end Element; + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + --------------------- -- Equivalent_Sets -- --------------------- @@ -490,34 +505,6 @@ package body Ada.Containers.Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); - --------- - -- "<" -- - --------- - - function "<" (Left : Key_Type; Right : Cursor) return Boolean is - begin - return Left < Right.Node.Element; - end "<"; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean is - begin - return Right > Left.Node.Element; - end "<"; - - --------- - -- ">" -- - --------- - - function ">" (Left : Key_Type; Right : Cursor) return Boolean is - begin - return Left > Right.Node.Element; - end ">"; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean is - begin - return Right < Left.Node.Element; - end ">"; - ------------- -- Ceiling -- ------------- @@ -573,6 +560,21 @@ package body Ada.Containers.Ordered_Sets is return Node.Element; end Element; + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + ------------- -- Exclude -- ------------- @@ -626,7 +628,7 @@ package body Ada.Containers.Ordered_Sets is Right : Node_Access) return Boolean is begin - return Left > Right.Element; + return Key (Right.Element) < Left; end Is_Greater_Key_Node; ---------------------- @@ -638,7 +640,7 @@ package body Ada.Containers.Ordered_Sets is Right : Node_Access) return Boolean is begin - return Left < Right.Element; + return Left < Key (Right.Element); end Is_Less_Key_Node; --------- @@ -691,7 +693,7 @@ package body Ada.Containers.Ordered_Sets is declare E : Element_Type renames Position.Node.Element; - K : Key_Type renames Key (E); + K : constant Key_Type := Key (E); B : Natural renames Tree.Busy; L : Natural renames Tree.Lock; @@ -712,11 +714,7 @@ package body Ada.Containers.Ordered_Sets is L := L - 1; B := B - 1; - if K < E - or else K > E - then - null; - else + if Equivalent_Keys (K, Key (E)) then return; end if; end; @@ -1319,12 +1317,10 @@ package body Ada.Containers.Ordered_Sets is end Replace_Element; procedure Replace_Element - (Container : Set; + (Container : in out Set; Position : Cursor; - By : Element_Type) + New_Item : Element_Type) is - Tree : Tree_Type renames Container.Tree'Unrestricted_Access.all; - begin if Position.Node = null then raise Constraint_Error; @@ -1334,7 +1330,7 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error; end if; - Replace_Element (Tree, Position.Node, By); + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; --------------------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 8ba0498..db5cfe5 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -38,14 +38,15 @@ with Ada.Finalization; with Ada.Streams; generic - type Element_Type is private; with function "<" (Left, Right : Element_Type) return Boolean is <>; with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Ordered_Sets is -pragma Preelaborate (Ordered_Sets); + pragma Preelaborate; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; type Set is tagged private; @@ -67,18 +68,16 @@ pragma Preelaborate (Ordered_Sets); function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); - procedure Replace_Element - (Container : Set; -- TODO: need ARG ruling - Position : Cursor; - By : Element_Type); - - procedure Move - (Target : in out Set; - Source : in out Set); + procedure Move (Target : in out Set; Source : in out Set); procedure Insert (Container : in out Set; @@ -95,9 +94,13 @@ pragma Preelaborate (Ordered_Sets); New_Item : Element_Type); procedure Replace - (Container : in out Set; -- TODO: need ARG ruling + (Container : in out Set; New_Item : Element_Type); + procedure Exclude + (Container : in out Set; + Item : Element_Type); + procedure Delete (Container : in out Set; Item : Element_Type); @@ -110,10 +113,6 @@ pragma Preelaborate (Ordered_Sets); procedure Delete_Last (Container : in out Set); - procedure Exclude - (Container : in out Set; - Item : Element_Type); - procedure Union (Target : in out Set; Source : Set); function Union (Left, Right : Set) return Set; @@ -126,8 +125,7 @@ pragma Preelaborate (Ordered_Sets); function "and" (Left, Right : Set) return Set renames Intersection; - procedure Difference (Target : in out Set; - Source : Set); + procedure Difference (Target : in out Set; Source : Set); function Difference (Left, Right : Set) return Set; @@ -143,14 +141,6 @@ pragma Preelaborate (Ordered_Sets); function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function Find (Container : Set; Item : Element_Type) return Cursor; - - function Floor (Container : Set; Item : Element_Type) return Cursor; - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - function First (Container : Set) return Cursor; function First_Element (Container : Set) return Element_Type; @@ -167,6 +157,14 @@ pragma Preelaborate (Ordered_Sets); procedure Previous (Position : in out Cursor); + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + function Has_Element (Position : Cursor) return Boolean; function "<" (Left, Right : Cursor) return Boolean; @@ -190,48 +188,36 @@ pragma Preelaborate (Ordered_Sets); Process : not null access procedure (Position : Cursor)); generic - type Key_Type (<>) is limited private; + type Key_Type (<>) is private; with function Key (Element : Element_Type) return Key_Type; - with function "<" - (Left : Key_Type; - Right : Element_Type) return Boolean is <>; - - with function ">" - (Left : Key_Type; - Right : Element_Type) return Boolean is <>; + with function "<" (Left, Right : Key_Type) return Boolean is <>; package Generic_Keys is - function Contains (Container : Set; Key : Key_Type) return Boolean; - - function Find (Container : Set; Key : Key_Type) return Cursor; - - function Floor (Container : Set; Key : Key_Type) return Cursor; - - function Ceiling (Container : Set; Key : Key_Type) return Cursor; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; function Key (Position : Cursor) return Key_Type; function Element (Container : Set; Key : Key_Type) return Element_Type; procedure Replace - (Container : in out Set; -- TODO: need ARG ruling + (Container : in out Set; Key : Key_Type; New_Item : Element_Type); - procedure Delete (Container : in out Set; Key : Key_Type); - procedure Exclude (Container : in out Set; Key : Key_Type); - function "<" (Left : Cursor; Right : Key_Type) return Boolean; + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; - function ">" (Left : Cursor; Right : Key_Type) return Boolean; + function Floor (Container : Set; Key : Key_Type) return Cursor; - function "<" (Left : Key_Type; Right : Cursor) return Boolean; + function Ceiling (Container : Set; Key : Key_Type) return Cursor; - function ">" (Left : Key_Type; Right : Cursor) return Boolean; + function Contains (Container : Set; Key : Key_Type) return Boolean; procedure Update_Element_Preserving_Key (Container : in out Set; |