diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-11-15 13:54:02 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-11-15 13:54:02 +0000 |
| commit | 2c3d0a6d737c0b55769f8e2169bc210b85575f72 (patch) | |
| tree | 129bc8844811a17598b415668a54b3f7b4c278d7 /gcc | |
| parent | 2223c320c98d0169cd39be0b8842e53b93656706 (diff) | |
| download | gcc-2c3d0a6d737c0b55769f8e2169bc210b85575f72.tar.gz | |
2005-11-14 Matthew Heaney <heaney@adacore.com>
* a-crbtgo.ads, a-crbtgo.adb, a-coorse.ads, a-coorse.adb, a-convec.ads,
a-convec.adb, a-coinve.ads, a-coinve.adb, a-cohama.ads, a-cohama.adb,
a-ciorse.ads, a-ciorse.adb, a-cihama.ads, a-cihama.adb, a-cidlli.ads,
a-cidlli.adb, a-cdlili.ads, a-cdlili.adb, a-coormu.adb, a-ciormu.adb,
a-cihase.adb, a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads,
a-coorma.ads, a-ciormu.ads, a-coormu.ads, a-ciorma.adb, a-coorma.adb:
Compiles against the spec for ordered maps described in sections
A.18.6 of the most recent (August 2005) AI-302 draft.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106962 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
30 files changed, 3270 insertions, 1367 deletions
diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index a0a6f3277f5..958a105a734 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -34,6 +34,7 @@ ------------------------------------------------------------------------------ with System; use type System.Address; + with Ada.Unchecked_Deallocation; package body Ada.Containers.Doubly_Linked_Lists is @@ -129,7 +130,8 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Append (Container : in out List; New_Item : Element_Type; - Count : Count_Type := 1) is + Count : Count_Type := 1) + is begin Insert (Container, No_Element, New_Item, Count); end Append; @@ -185,7 +187,8 @@ package body Ada.Containers.Doubly_Linked_Lists is function Contains (Container : List; - Item : Element_Type) return Boolean is + Item : Element_Type) return Boolean + is begin return Find (Container, Item) /= No_Element; end Contains; @@ -202,8 +205,6 @@ 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 raise Constraint_Error; end if; @@ -212,13 +213,16 @@ package body Ada.Containers.Doubly_Linked_Lists is raise Program_Error; end if; + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = Container.First then Delete_First (Container, Count); - Position := First (Container); + Position := No_Element; -- Post-York behavior return; end if; if Count = 0 then + Position := No_Element; -- Post-York behavior return; end if; @@ -247,6 +251,8 @@ package body Ada.Containers.Doubly_Linked_Lists is Free (X); end loop; + + Position := No_Element; -- Post-York behavior end Delete; ------------------ @@ -329,12 +335,12 @@ package body Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Vet (Position), "bad cursor in Element"); - if Position.Node = null then raise Constraint_Error; end if; + pragma Assert (Vet (Position), "bad cursor in Element"); + return Position.Node.Element; end Element; @@ -354,11 +360,11 @@ package body Ada.Containers.Doubly_Linked_Lists is Node := Container.First; else - pragma Assert (Vet (Position), "bad cursor in Find"); - if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; while Node /= null loop @@ -604,12 +610,12 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - pragma Assert (Vet (Before), "bad cursor in Insert"); + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error; + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -656,12 +662,12 @@ package body Ada.Containers.Doubly_Linked_Lists is New_Node : Node_Access; begin - pragma Assert (Vet (Before), "bad cursor in Insert"); + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error; + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -937,12 +943,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Process : not null access procedure (Element : in Element_Type)) is begin - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - if Position.Node = null then raise Constraint_Error; end if; + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + declare C : List renames Position.Container.all'Unrestricted_Access.all; B : Natural renames C.Busy; @@ -1018,97 +1024,46 @@ package body Ada.Containers.Doubly_Linked_Lists is end loop; end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- procedure Replace_Element - (Position : Cursor; - By : Element_Type) + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) is 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 + if Position.Container /= Container'Unchecked_Access then raise Program_Error; end if; - Position.Node.Element := By; - end Replace_Element; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.Last; - - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; + if Container.Lock > 0 then + raise Program_Error; end if; - while Node /= null loop - if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); - end if; - - Node := Node.Prev; - end loop; - - return No_Element; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - - Node : Node_Access := Container.Last; - - begin - B := B + 1; - - begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; - end; + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - B := B - 1; - end Reverse_Iterate; + Position.Node.Element := New_Item; + end Replace_Element; - ------------------ - -- Reverse_List -- - ------------------ + ---------------------- + -- Reverse_Elements -- + ---------------------- - procedure Reverse_List (Container : in out List) is + procedure Reverse_Elements (Container : in out List) is I : Node_Access := Container.First; J : Node_Access := Container.Last; @@ -1152,7 +1107,7 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; end Swap; - -- Start of processing for Reverse_List + -- Start of processing for Reverse_Elements begin if Container.Length <= 1 then @@ -1188,7 +1143,72 @@ package body Ada.Containers.Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - end Reverse_List; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + + else + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + + Node : Node_Access := Container.Last; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; ------------ -- Splice -- @@ -1200,12 +1220,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Source : in out List) is begin - pragma Assert (Vet (Before), "bad cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unrestricted_Access - then - raise Program_Error; + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address @@ -1274,13 +1294,12 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) is begin - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unchecked_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unchecked_Access - then - raise Program_Error; + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then @@ -1291,6 +1310,8 @@ package body Ada.Containers.Doubly_Linked_Lists is raise Program_Error; end if; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Position.Node = Before.Node or else Position.Node.Next = Before.Node then @@ -1378,13 +1399,12 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unrestricted_Access - then - raise Program_Error; + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then @@ -1395,6 +1415,8 @@ package body Ada.Containers.Doubly_Linked_Lists is raise Program_Error; end if; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Target.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -1474,18 +1496,20 @@ package body Ada.Containers.Doubly_Linked_Lists is -- Swap -- ---------- - procedure Swap (I, J : Cursor) is + procedure Swap + (Container : in out List; + I, J : Cursor) + is begin - 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; - if I.Container /= J.Container then + if I.Container /= Container'Unchecked_Access + or else J.Container /= Container'Unchecked_Access + then raise Program_Error; end if; @@ -1493,15 +1517,19 @@ package body Ada.Containers.Doubly_Linked_Lists is return; end if; - if I.Container.Lock > 0 then + if Container.Lock > 0 then raise Program_Error; end if; + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + 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; @@ -1514,11 +1542,9 @@ package body Ada.Containers.Doubly_Linked_Lists is procedure Swap_Links (Container : in out List; - I, J : Cursor) is + I, J : Cursor) + is begin - 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 @@ -1539,6 +1565,9 @@ package body Ada.Containers.Doubly_Linked_Lists is raise Program_Error; end if; + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + declare I_Next : constant Cursor := Next (I); @@ -1570,20 +1599,24 @@ package body Ada.Containers.Doubly_Linked_Lists is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) is begin - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - if Position.Node = null then raise Constraint_Error; end if; + if Position.Container /= Container'Unchecked_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; @@ -1761,4 +1794,12 @@ package body Ada.Containers.Doubly_Linked_Lists is end loop; end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 70c0f806f5b..3682104cba9 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -63,49 +63,51 @@ package Ada.Containers.Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Replace_Element - (Position : Cursor; - By : Element_Type); + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); procedure Move (Target : in out List; Source : in out List); - procedure Prepend + procedure Insert (Container : in out List; + Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1); - procedure Append + procedure Insert (Container : in out List; + Before : Cursor; New_Item : Element_Type; + Position : out Cursor; Count : Count_Type := 1); procedure Insert (Container : in out List; Before : Cursor; - New_Item : Element_Type; + Position : out Cursor; Count : Count_Type := 1); - procedure Insert + procedure Prepend (Container : in out List; - Before : Cursor; New_Item : Element_Type; - Position : out Cursor; Count : Count_Type := 1); - procedure Insert + procedure Append (Container : in out List; - Before : Cursor; - Position : out Cursor; + New_Item : Element_Type; Count : Count_Type := 1); procedure Delete @@ -121,21 +123,11 @@ package Ada.Containers.Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1); - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - - procedure Sort (Container : in out List); + procedure Reverse_Elements (Container : in out List); - procedure Merge (Target, Source : in out List); - - end Generic_Sorting; - - procedure Reverse_List (Container : in out List); - - procedure Swap (I, J : Cursor); + procedure Swap + (Container : in out List; + I, J : Cursor); procedure Swap_Links (Container : in out List; @@ -149,13 +141,13 @@ package Ada.Containers.Doubly_Linked_Lists is procedure Splice (Target : in out List; Before : Cursor; - Position : Cursor); + Source : in out List; + Position : in out Cursor); procedure Splice (Target : in out List; Before : Cursor; - Source : in out List; - Position : in out Cursor); + Position : Cursor); function First (Container : List) return Cursor; @@ -165,9 +157,13 @@ package Ada.Containers.Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type; - function Contains - (Container : List; - Item : Element_Type) return Boolean; + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); function Find (Container : List; @@ -179,13 +175,9 @@ package Ada.Containers.Doubly_Linked_Lists is Item : Element_Type; Position : Cursor := No_Element) return Cursor; - function Next (Position : Cursor) return Cursor; - - function Previous (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - procedure Previous (Position : in out Cursor); + function Contains + (Container : List; + Item : Element_Type) return Boolean; function Has_Element (Position : Cursor) return Boolean; @@ -197,6 +189,18 @@ package Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)); + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + private type Node_Type; type Node_Access is access Node_Type; @@ -248,6 +252,18 @@ private Node : Node_Access; end record; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + No_Element : constant Cursor := Cursor'(null, null); end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index becdae2ecb5..46d94449b03 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -211,7 +211,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Contains (Container : List; - Item : Element_Type) return Boolean is + Item : Element_Type) return Boolean + is begin return Find (Container, Item) /= No_Element; end Contains; @@ -228,23 +229,28 @@ 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.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Position), "bad cursor in Delete"); + if Position.Node = Container.First then Delete_First (Container, Count); - Position := First (Container); + Position := No_Element; -- Post-York behavior return; end if; if Count = 0 then + Position := No_Element; -- Post-York behavior return; end if; @@ -273,6 +279,8 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Free (X); end loop; + + Position := No_Element; -- Post-York behavior end Delete; ------------------ @@ -355,12 +363,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Element (Position : Cursor) return Element_Type is begin - pragma Assert (Vet (Position), "bad cursor in Element"); - if Position.Node = null then raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + return Position.Node.Element.all; end Element; @@ -380,11 +392,15 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Node := Container.First; else - pragma Assert (Vet (Position), "bad cursor in Find"); + if Node.Element = null then + raise Program_Error; + end if; if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); end if; while Node /= null loop @@ -635,12 +651,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is New_Node : Node_Access; begin - pragma Assert (Vet (Before), "bad cursor in Insert"); + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error; + if Before.Node = null + or else Before.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); end if; if Count = 0 then @@ -942,12 +964,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Process : not null access procedure (Element : in Element_Type)) is begin - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - if Position.Node = null then raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + declare C : List renames Position.Container.all'Unrestricted_Access.all; B : Natural renames C.Busy; @@ -1024,102 +1050,56 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end loop; end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- procedure Replace_Element - (Position : Cursor; - By : Element_Type) + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) is 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 + if Position.Container /= Container'Unchecked_Access then raise Program_Error; end if; - declare - X : Element_Access := Position.Node.Element; - begin - Position.Node.Element := new Element_Type'(By); - Free (X); - end; - end Replace_Element; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.Last; - - else - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; + if Position.Container.Lock > 0 then + raise Program_Error; end if; - while Node /= null loop - if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); - end if; - - Node := Node.Prev; - end loop; - - return No_Element; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : in Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; + if Position.Node.Element = null then + raise Program_Error; + end if; - Node : Node_Access := Container.Last; + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - begin - B := B + 1; + declare + X : Element_Access := Position.Node.Element; begin - while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); - Node := Node.Prev; - end loop; - exception - when others => - B := B - 1; - raise; + Position.Node.Element := new Element_Type'(New_Item); + Free (X); end; + end Replace_Element; - B := B - 1; - end Reverse_Iterate; - - ------------------ - -- Reverse_List -- - ------------------ + ---------------------- + -- Reverse_Elements -- + ---------------------- - procedure Reverse_List (Container : in out List) is + procedure Reverse_Elements (Container : in out List) is I : Node_Access := Container.First; J : Node_Access := Container.Last; @@ -1163,7 +1143,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end if; end Swap; - -- Start of processing for Reverse_List + -- Start of processing for Reverse_Elements begin if Container.Length <= 1 then @@ -1199,7 +1179,75 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is pragma Assert (Container.First.Prev = null); pragma Assert (Container.Last.Next = null); - end Reverse_List; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + + else + if Node.Element = null then + raise Program_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + while Node /= null loop + if Node.Element.all = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : in Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + B : Natural renames C.Busy; + + Node : Node_Access := Container.Last; + + begin + B := B + 1; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Reverse_Iterate; ------------ -- Splice -- @@ -1211,12 +1259,18 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Source : in out List) is begin - pragma Assert (Vet (Before), "bad cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unrestricted_Access - then - raise Program_Error; + if Before.Node = null + or else Before.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); end if; if Target'Address = Source'Address @@ -1284,23 +1338,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is Position : Cursor) is begin - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unchecked_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unchecked_Access - then - raise Program_Error; + if Before.Node = null + or else Before.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Target'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Position.Node = Before.Node or else Position.Node.Next = Before.Node then @@ -1388,23 +1453,34 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Before.Container /= null then + if Before.Container /= Target'Unrestricted_Access then + raise Program_Error; + end if; - if Before.Container /= null - and then Before.Container /= Target'Unrestricted_Access - then - raise Program_Error; + if Before.Node = null + or else Before.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); end if; if Position.Node = null then raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Source'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + if Target.Length = Count_Type'Last then raise Constraint_Error; end if; @@ -1484,18 +1560,20 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -- Swap -- ---------- - procedure Swap (I, J : Cursor) is + procedure Swap + (Container : in out List; + I, J : Cursor) + is begin - 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; - if I.Container /= J.Container then + if I.Container /= Container'Unchecked_Access + or else J.Container /= Container'Unchecked_Access + then raise Program_Error; end if; @@ -1503,12 +1581,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return; end if; - if I.Container.Lock > 0 then + if Container.Lock > 0 then raise Program_Error; end if; + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + declare EI_Copy : constant Element_Access := I.Node.Element; + begin I.Node.Element := J.Node.Element; J.Node.Element := EI_Copy; @@ -1524,9 +1606,6 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is I, J : Cursor) is begin - 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 @@ -1547,6 +1626,9 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is raise Program_Error; end if; + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + declare I_Next : constant Cursor := Next (I); @@ -1580,20 +1662,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) is begin - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - if Position.Node = null then raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + + if Position.Container /= Container'Unchecked_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + declare - C : List renames Position.Container.all'Unrestricted_Access.all; - B : Natural renames C.Busy; - L : Natural renames C.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin B := B + 1; @@ -1775,4 +1865,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is end loop; end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index eb8657fe4fd..9e2d2351268 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -62,46 +62,47 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Clear (Container : in out List); - function Element (Position : Cursor) - return Element_Type; + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); procedure Query_Element (Position : Cursor; Process : not null access procedure (Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Replace_Element - (Position : Cursor; - By : Element_Type); + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); procedure Move (Target : in out List; Source : in out List); - procedure Prepend + procedure Insert (Container : in out List; + Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1); - procedure Append + procedure Insert (Container : in out List; + Before : Cursor; New_Item : Element_Type; + Position : out Cursor; Count : Count_Type := 1); - procedure Insert + procedure Prepend (Container : in out List; - Before : Cursor; New_Item : Element_Type; Count : Count_Type := 1); - procedure Insert + procedure Append (Container : in out List; - Before : Cursor; New_Item : Element_Type; - Position : out Cursor; Count : Count_Type := 1); procedure Delete @@ -117,21 +118,9 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : in out List; Count : Count_Type := 1); - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - - procedure Sort (Container : in out List); - - procedure Merge (Target, Source : in out List); - - end Generic_Sorting; + procedure Reverse_Elements (Container : in out List); - procedure Reverse_List (Container : in out List); - - procedure Swap (I, J : Cursor); + procedure Swap (Container : in out List; I, J : Cursor); procedure Swap_Links (Container : in out List; I, J : Cursor); @@ -143,13 +132,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Splice (Target : in out List; Before : Cursor; - Position : Cursor); + Source : in out List; + Position : in out Cursor); procedure Splice (Target : in out List; Before : Cursor; - Source : in out List; - Position : in out Cursor); + Position : Cursor); function First (Container : List) return Cursor; @@ -159,9 +148,13 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is function Last_Element (Container : List) return Element_Type; - function Contains - (Container : List; - Item : Element_Type) return Boolean; + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); function Find (Container : List; @@ -173,13 +166,9 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is Item : Element_Type; Position : Cursor := No_Element) return Cursor; - function Next (Position : Cursor) return Cursor; - - function Previous (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - procedure Previous (Position : in out Cursor); + function Contains + (Container : List; + Item : Element_Type) return Boolean; function Has_Element (Position : Cursor) return Boolean; @@ -191,6 +180,18 @@ package Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)); + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + private type Node_Type; type Node_Access is access Node_Type; @@ -244,6 +245,18 @@ private Node : Node_Access; end record; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + No_Element : constant Cursor := Cursor'(null, null); end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index dc5fa0f82cb..3836f7eb035 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -713,6 +713,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Read_Nodes (Stream, Container.HT); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------- -- Read_Node -- --------------- @@ -787,7 +795,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -- Replace_Element -- --------------------- - procedure Replace_Element (Position : Cursor; By : Element_Type) is + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is begin pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -795,6 +807,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Constraint_Error; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + if Position.Container.HT.Lock > 0 then raise Program_Error; end if; @@ -803,7 +819,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is X : Element_Access := Position.Node.Element; begin - Position.Node.Element := new Element_Type'(By); + Position.Node.Element := new Element_Type'(New_Item); Free_Element (X); end; end Replace_Element; @@ -834,9 +850,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is begin pragma Assert (Vet (Position), "bad cursor in Update_Element"); @@ -845,9 +862,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is raise Constraint_Error; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + HT : Hash_Table_Type renames Container.HT; B : Natural renames HT.Busy; L : Natural renames HT.Lock; @@ -859,7 +879,6 @@ package body Ada.Containers.Indefinite_Hashed_Maps is declare K : Key_Type renames Position.Node.Key.all; E : Element_Type renames Position.Node.Element.all; - begin Process (K, E); exception @@ -951,6 +970,14 @@ package body Ada.Containers.Indefinite_Hashed_Maps is Write_Nodes (Stream, Container.HT); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + ---------------- -- Write_Node -- ---------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 93bdd81e8a2..18963d5048c 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -57,6 +57,12 @@ package Ada.Containers.Indefinite_Hashed_Maps is function "=" (Left, Right : Map) return Boolean; + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type); + function Length (Container : Map) return Count_Type; function Is_Empty (Container : Map) return Boolean; @@ -67,20 +73,22 @@ package Ada.Containers.Indefinite_Hashed_Maps is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Key : Key_Type; Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Replace_Element - (Position : Cursor; - By : Element_Type); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -105,29 +113,11 @@ package Ada.Containers.Indefinite_Hashed_Maps is Key : Key_Type; New_Item : Element_Type); - procedure Delete - (Container : in out Map; - Key : Key_Type); + procedure Exclude (Container : in out Map; Key : Key_Type); - procedure Delete - (Container : in out Map; - Position : in out Cursor); + procedure Delete (Container : in out Map; Key : Key_Type); - procedure Exclude - (Container : in out Map; - Key : Key_Type); - - function Contains - (Container : Map; - Key : Key_Type) return Boolean; - - function Find - (Container : Map; - Key : Key_Type) return Cursor; - - function Element - (Container : Map; - Key : Key_Type) return Element_Type; + procedure Delete (Container : in out Map; Position : in out Cursor); function First (Container : Map) return Cursor; @@ -135,29 +125,24 @@ package Ada.Containers.Indefinite_Hashed_Maps is procedure Next (Position : in out Cursor); + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + function Has_Element (Position : Cursor) return Boolean; - function Equivalent_Keys (Left, Right : Cursor) - return Boolean; + function Equivalent_Keys (Left, Right : Cursor) return Boolean; - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean; + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean; + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; procedure Iterate (Container : Map; Process : not null access procedure (Position : Cursor)); - function Capacity (Container : Map) return Count_Type; - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type); - private pragma Inline ("="); pragma Inline (Length); @@ -194,6 +179,7 @@ private use HT_Types; use Ada.Finalization; + use Ada.Streams; procedure Adjust (Container : in out Map); @@ -208,12 +194,22 @@ private Node : Node_Access; end record; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + No_Element : constant Cursor := (Container => null, Node => null); - use Ada.Streams; - procedure Write (Stream : access Root_Stream_Type'Class; Container : Map); diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 8e747eadf08..9503e8859a2 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -73,6 +73,12 @@ package body Ada.Containers.Indefinite_Hashed_Sets is function Hash_Node (Node : Node_Access) return Hash_Type; pragma Inline (Hash_Node); + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; pragma Inline (Is_In); @@ -326,13 +332,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if not Is_In (Right.HT, L_Node) then declare - Indx : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; - + Src : Element_Type renames L_Node.Element.all; + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (Indx); - + Tgt : Element_Access := new Element_Type'(Src); begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end; Length := Length + 1; @@ -644,6 +653,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : out Cursor; Inserted : out Boolean) is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is function New_Node (Next : Node_Access) return Node_Access; pragma Inline (New_Node); @@ -665,8 +700,6 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise; end New_Node; - HT : Hash_Table_Type renames Container.HT; - -- Start of processing for Insert begin @@ -674,30 +707,13 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; - Local_Insert (HT, New_Item, Position.Node, Inserted); + Local_Insert (HT, New_Item, 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; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error; - end if; end Insert; ------------------ @@ -787,13 +803,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Is_In (Right.HT, L_Node) then declare - Indx : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; + Src : Element_Type renames L_Node.Element.all; + + Indx : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (Indx); + Tgt : Element_Access := new Element_Type'(Src); + begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end; Length := Length + 1; @@ -1040,6 +1063,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Read_Nodes (Stream, Container.HT); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------- -- Read_Node -- --------------- @@ -1502,6 +1533,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is return (Controlled with HT => (Buckets, Length, 0, 0)); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + Node : Node_Access; + Inserted : Boolean; + + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + ----------- -- Union -- ----------- @@ -1609,13 +1654,20 @@ package body Ada.Containers.Indefinite_Hashed_Sets is ------------- procedure Process (L_Node : Node_Access) is - J : constant Hash_Type := - Hash (L_Node.Element.all) mod Buckets'Length; + Src : Element_Type renames L_Node.Element.all; + + J : constant Hash_Type := Hash (Src) mod Buckets'Length; Bucket : Node_Access renames Buckets (J); + Tgt : Element_Access := new Element_Type'(Src); + begin - Bucket := new Node_Type'(L_Node.Element, Bucket); + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; end Process; -- Start of processing for Process @@ -1751,6 +1803,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Write_Nodes (Stream, Container.HT); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + ---------------- -- Write_Node -- ---------------- diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads index 4ecca1ca0bf..bde7917ff37 100644 --- a/gcc/ada/a-cihase.ads +++ b/gcc/ada/a-cihase.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -63,6 +63,8 @@ package Ada.Containers.Indefinite_Hashed_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Capacity (Container : Set) return Count_Type; procedure Reserve_Capacity @@ -225,6 +227,7 @@ private use HT_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -235,12 +238,22 @@ private Node : Node_Access; end record; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + No_Element : constant Cursor := (Container => null, Node => null); - use Ada.Streams; - procedure Write (Stream : access Root_Stream_Type'Class; Container : Set); diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index 9847aaad7a8..256304281a8 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -135,16 +135,56 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Key = null + or else Right.Node.Key = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Key.all < Right.Node.Key.all; end "<"; function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Key = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Key.all < Right; end "<"; function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Key = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Key.all; end "<"; @@ -163,16 +203,56 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Key = null + or else Right.Node.Key = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Key.all < Left.Node.Key.all; end ">"; function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Key = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + return Right < Left.Node.Key.all; end ">"; function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Key = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Key.all < Left; end ">"; @@ -194,12 +274,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Ceiling (Container : Map; Key : Key_Type) return Cursor is Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); + begin if Node = null then return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); end if; + + return Cursor'(Container'Unrestricted_Access, Node); end Ceiling; ----------- @@ -268,11 +349,20 @@ package body Ada.Containers.Indefinite_Ordered_Maps is raise Constraint_Error; end if; - if Position.Container /= Map_Access'(Container'Unrestricted_Access) then + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Delete_Node_Sans_Free (Container.Tree, Position.Node); + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -280,13 +370,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Delete (Container : in out Map; Key : Key_Type) is X : Node_Access := Key_Ops.Find (Container.Tree, Key); + begin if X = null then raise Constraint_Error; - else - Delete_Node_Sans_Free (Container.Tree, X); - Free (X); end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); end Delete; ------------------ @@ -295,6 +386,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Delete_First (Container : in out Map) is X : Node_Access := Container.Tree.First; + begin if X /= null then Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); @@ -308,6 +400,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Delete_Last (Container : in out Map) is X : Node_Access := Container.Tree.Last; + begin if X /= null then Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); @@ -321,15 +414,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + return Position.Node.Element.all; end Element; function Element (Container : Map; Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + if Node = null then + raise Constraint_Error; + end if; + 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 -- ------------- @@ -339,7 +463,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -350,12 +474,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Find (Container : Map; Key : Key_Type) return Cursor is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin if Node = null then return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); end if; + + return Cursor'(Container'Unrestricted_Access, Node); end Find; ----------- @@ -363,12 +488,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ----------- function First (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin - if Container.Tree.First = null then + if T.First = null then return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Tree.First); end if; + + return Cursor'(Container'Unrestricted_Access, T.First); end First; ------------------- @@ -376,8 +503,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ------------------- function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.First.Element.all; + if T.First = null then + raise Constraint_Error; + end if; + + return T.First.Element.all; end First_Element; --------------- @@ -385,8 +518,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is --------------- function First_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.First.Key.all; + if T.First = null then + raise Constraint_Error; + end if; + + return T.First.Key.all; end First_Key; ----------- @@ -395,12 +534,13 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Floor (Container : Map; Key : Key_Type) return Cursor is Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); + begin if Node = null then return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); end if; + + return Cursor'(Container'Unrestricted_Access, Node); end Floor; ---------- @@ -410,11 +550,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is procedure Free (X : in out Node_Access) is procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin if X = null then return; end if; + X.Parent := X; + X.Left := X; + X.Right := X; + begin Free_Key (X.Key); exception @@ -664,6 +809,17 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Key = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Position.Node.Key.all; end Key; @@ -672,12 +828,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ---------- function Last (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin - if Container.Tree.Last = null then + if T.Last = null then return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); end if; + + return Cursor'(Container'Unrestricted_Access, T.Last); end Last; ------------------ @@ -685,8 +843,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ------------------ function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.Last.Element.all; + if T.Last = null then + raise Constraint_Error; + end if; + + return T.Last.Element.all; end Last_Element; -------------- @@ -694,8 +858,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -------------- function Last_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.Last.Key.all; + if T.Last = null then + raise Constraint_Error; + end if; + + return T.Last.Key.all; end Last_Key; ---------- @@ -738,8 +908,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Key /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare - Node : constant Node_Access := Tree_Operations.Next (Position.Node); + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin if Node = null then return No_Element; @@ -773,9 +951,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is return No_Element; end if; + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Key /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); + Tree_Operations.Previous (Position.Node); + begin if Node = null then return No_Element; @@ -799,29 +984,46 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : Element_Type)) is - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - T : Tree_Type renames Position.Container.Tree; + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error; + end if; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - begin - B := B + 1; - L := L + 1; + declare + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.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; ---------- @@ -863,6 +1065,14 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + ------------- -- Replace -- ------------- @@ -908,15 +1118,40 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -- Replace_Element -- --------------------- - procedure Replace_Element (Position : Cursor; By : Element_Type) is - X : Element_Access := Position.Node.Element; + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is begin - if Position.Container.Tree.Lock > 0 then + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Position.Node.Element := new Element_Type'(By); - Free_Element (X); + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + declare + X : Element_Access := Position.Node.Element; + + begin + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; end Replace_Element; --------------------- @@ -1010,33 +1245,55 @@ package body Ada.Containers.Indefinite_Ordered_Maps is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - T : Tree_Type renames Position.Container.Tree; + if Position.Node.Key = null + or else Position.Node.Element = null + then + raise Program_Error; + end if; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - begin - B := B + 1; - L := L + 1; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element"); + + declare + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.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; ----------- @@ -1074,4 +1331,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 4815ebd2e35..8837e048e00 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -40,16 +40,16 @@ with Ada.Streams; generic type Key_Type (<>) is private; - type Element_Type (<>) is private; with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Indefinite_Ordered_Maps is pragma Preelaborate; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + type Map is tagged private; type Cursor is private; @@ -70,17 +70,21 @@ package Ada.Containers.Indefinite_Ordered_Maps is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Key : Key_Type; Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)); - - procedure Replace_Element (Position : Cursor; By : Element_Type); + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); procedure Move (Target : in out Map; Source : in out Map); @@ -106,54 +110,28 @@ package Ada.Containers.Indefinite_Ordered_Maps is Key : Key_Type; New_Item : Element_Type); - procedure Delete - (Container : in out Map; - Key : Key_Type); + procedure Exclude (Container : in out Map; Key : Key_Type); - procedure Delete - (Container : in out Map; - Position : in out Cursor); + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); procedure Delete_First (Container : in out Map); procedure Delete_Last (Container : in out Map); - procedure Exclude - (Container : in out Map; - Key : Key_Type); - - function Contains - (Container : Map; - Key : Key_Type) return Boolean; - - function Find - (Container : Map; - Key : Key_Type) return Cursor; - - function Element - (Container : Map; - Key : Key_Type) return Element_Type; - - function Floor - (Container : Map; - Key : Key_Type) return Cursor; - - function Ceiling - (Container : Map; - Key : Key_Type) return Cursor; - function First (Container : Map) return Cursor; - function First_Key (Container : Map) return Key_Type; - function First_Element (Container : Map) return Element_Type; - function Last (Container : Map) return Cursor; + function First_Key (Container : Map) return Key_Type; - function Last_Key (Container : Map) return Key_Type; + function Last (Container : Map) return Cursor; function Last_Element (Container : Map) return Element_Type; + function Last_Key (Container : Map) return Key_Type; + function Next (Position : Cursor) return Cursor; procedure Next (Position : in out Cursor); @@ -162,6 +140,16 @@ package Ada.Containers.Indefinite_Ordered_Maps is procedure Previous (Position : in out Cursor); + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + function Has_Element (Position : Cursor) return Boolean; function "<" (Left, Right : Cursor) return Boolean; @@ -216,8 +204,9 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; - type Map_Access is access Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record @@ -225,9 +214,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 9e24d3e7973..458e42e4225 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -87,6 +87,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Free (X : in out Node_Access); + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access); + procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -157,16 +162,56 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Element = null + or else Right.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Element.all < Right.Node.Element.all; end "<"; function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Element.all < Right; end "<"; function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Element.all; end "<"; @@ -183,20 +228,60 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is -- ">" -- --------- - function ">" (Left : Cursor; Right : Element_Type) return Boolean is - begin - return Right < Left.Node.Element.all; - end ">"; - function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Element = null + or else Right.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + -- L > R same as R < L return Right.Node.Element.all < Left.Node.Element.all; end ">"; + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Node.Element.all; + end ">"; + function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Element.all < Left; end ">"; @@ -313,6 +398,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); @@ -375,9 +463,35 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + 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 -- --------------------- @@ -420,6 +534,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Node : Node_Access := Element_Keys.Ceiling (Tree, Item); Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); X : Node_Access; + begin while Node /= Done loop X := Node; @@ -464,6 +579,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function First_Element (Container : Set) return Element_Type is begin + if Container.Tree.First = null then + raise Constraint_Error; + end if; + + if Container.Tree.First.Element = null then + raise Program_Error; + end if; + return Container.Tree.First.Element.all; end First_Element; @@ -490,11 +613,16 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is procedure Free (X : in out Node_Access) is procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin if X = null then return; end if; + X.Parent := X; + X.Left := X; + X.Right := X; + begin Free_Element (X.Element); exception @@ -538,34 +666,6 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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 -- ------------- @@ -621,11 +721,32 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is ------------- function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + begin + if Node = null then + raise Constraint_Error; + end if; + 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 -- ------------- @@ -681,9 +802,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Is_Greater_Key_Node (Left : Key_Type; - Right : Node_Access) return Boolean is + Right : Node_Access) return Boolean + is begin - return Left > Right.Element.all; + return Key (Right.Element.all) < Left; end Is_Greater_Key_Node; ---------------------- @@ -692,9 +814,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Is_Less_Key_Node (Left : Key_Type; - Right : Node_Access) return Boolean is + Right : Node_Access) return Boolean + is begin - return Left < Right.Element.all; + return Left < Key (Right.Element.all); end Is_Less_Key_Node; ------------- @@ -746,6 +869,17 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Key (Position.Node.Element.all); end Key; @@ -812,13 +946,20 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + 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; @@ -839,11 +980,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is L := L - 1; B := B - 1; - if K < E - or else K > E - then - null; - else + if Equivalent_Keys (Left => K, Right => Key (E)) then return; end if; end; @@ -884,6 +1021,24 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is New_Item : Element_Type; Position : out Cursor) is + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access) + is function New_Node return Node_Access; pragma Inline (New_Node); @@ -904,7 +1059,7 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return new Node_Type'(Parent => null, Left => null, Right => null, - Color => Red, + Color => Red_Black_Trees.Red, Element => X); exception @@ -913,16 +1068,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise; end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert_Sans_Hint begin Unconditional_Insert_Sans_Hint - (Container.Tree, + (Tree, New_Item, - Position.Node); - - Position.Container := Container'Unrestricted_Access; - end Insert; + Node); + end Insert_Sans_Hint; ---------------------- -- Insert_With_Hint -- @@ -1156,6 +1309,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function Last_Element (Container : Set) return Element_Type is begin + if Container.Tree.Last = null then + raise Constraint_Error; + end if; + return Container.Tree.Last.Element.all; end Last_Element; @@ -1199,6 +1356,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare Node : constant Node_Access := Tree_Operations.Next (Position.Node); @@ -1245,6 +1405,9 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := Tree_Operations.Previous (Position.Node); @@ -1271,29 +1434,40 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element.all; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - S : Set renames Position.Container.all; - T : Tree_Type renames S.Tree'Unrestricted_Access.all; + if Position.Node.Element = null then + raise Program_Error; + end if; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - begin - B := B + 1; - L := L + 1; + declare + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.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; ---------- @@ -1334,6 +1508,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- @@ -1382,6 +1564,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is function New_Node return Node_Access is begin Node.Element := new Element_Type'(Item); -- OK if fails + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + return Node; end New_Node; @@ -1403,22 +1590,27 @@ package body Ada.Containers.Indefinite_Ordered_Multisets 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; end if; + 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 (Tree, Position.Node, By); + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; --------------------- @@ -1563,6 +1755,19 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Set'(Controlled with Tree); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + + begin + Insert_Sans_Hint (Tree, New_Item, Node); + return Set'(Controlled with Tree); + end To_Set; + ----------- -- Union -- ----------- @@ -1613,4 +1818,12 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index d2bf68dfd68..1240aca4d66 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -47,6 +47,8 @@ generic package Ada.Containers.Indefinite_Ordered_Multisets is pragma Preelaborate; + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + type Set is tagged private; type Cursor is private; @@ -59,6 +61,8 @@ package Ada.Containers.Indefinite_Ordered_Multisets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -67,15 +71,15 @@ package Ada.Containers.Indefinite_Ordered_Multisets 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); procedure Insert @@ -85,6 +89,14 @@ package Ada.Containers.Indefinite_Ordered_Multisets is procedure Insert (Container : in out Set; New_Item : Element_Type); +-- TODO: include Replace too??? +-- +-- procedure Replace +-- (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); procedure Delete (Container : in out Set; Position : in out Cursor); @@ -93,10 +105,7 @@ package Ada.Containers.Indefinite_Ordered_Multisets is procedure Delete_Last (Container : in out Set); - procedure Exclude (Container : in out Set; Item : Element_Type); - - procedure Union (Target : in out Set; - Source : Set); + procedure Union (Target : in out Set; Source : Set); function Union (Left, Right : Set) return Set; @@ -124,14 +133,6 @@ package Ada.Containers.Indefinite_Ordered_Multisets is 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; @@ -148,6 +149,14 @@ package Ada.Containers.Indefinite_Ordered_Multisets is 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; @@ -181,42 +190,31 @@ package Ada.Containers.Indefinite_Ordered_Multisets is 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 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 ">" (Left : Cursor; Right : Key_Type) return Boolean; + function Find (Container : Set; Key : Key_Type) return Cursor; - function "<" (Left : Key_Type; Right : Cursor) 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 Contains (Container : Set; Key : Key_Type) return Boolean; procedure Update_Element_Preserving_Key (Container : in out Set; @@ -266,6 +264,7 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -275,9 +274,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; Container : Set); diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 2de8cda37e3..bb441a3201c 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -59,6 +59,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is procedure Free (X : in out Node_Access); + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -144,16 +150,56 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Element = null + or else Right.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Element.all < Right.Node.Element.all; end "<"; function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Element.all < Right; end "<"; function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Element.all; end "<"; @@ -190,6 +236,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + if Left.Node.Element = null + or else Right.Node.Element = null + then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + -- L > R same as R < L return Right.Node.Element.all < Left.Node.Element.all; @@ -197,11 +261,33 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + if Left.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + return Right < Left.Node.Element.all; end ">"; function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + if Right.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Element.all < Left; end ">"; @@ -296,6 +382,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -310,7 +399,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end Delete; @@ -366,6 +455,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + return Position.Node.Element.all; end Element; @@ -467,6 +567,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin + if Container.Tree.First = null then + raise Constraint_Error; + end if; + return Container.Tree.First.Element.all; end First_Element; @@ -491,7 +595,6 @@ package body Ada.Containers.Indefinite_Ordered_Sets is ---------- procedure Free (X : in out Node_Access) is - procedure Deallocate is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); @@ -500,6 +603,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return; end if; + X.Parent := X; + X.Left := X; + X.Right := X; + begin Free_Element (X.Element); exception @@ -593,6 +700,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Key_Keys.Find (Container.Tree, Key); begin + if Node = null then + raise Constraint_Error; + end if; + return Node.Element.all; end Element; @@ -685,6 +796,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Node.Element = null then + raise Program_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Key (Position.Node.Element.all); end Key; @@ -724,10 +846,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + declare E : Element_Type renames Position.Node.Element.all; K : constant Key_Type := Key (E); @@ -811,13 +940,44 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Position : out Cursor; Inserted : out Boolean) is + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is function New_Node return Node_Access; pragma Inline (New_Node); procedure Insert_Post is new Element_Keys.Generic_Insert_Post (New_Node); - procedure Insert_Sans_Hint is + procedure Conditional_Insert_Sans_Hint is new Element_Keys.Generic_Conditional_Insert (Insert_Post); -------------- @@ -826,11 +986,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function New_Node return Node_Access is Element : Element_Access := new Element_Type'(New_Item); + begin return new Node_Type'(Parent => null, Left => null, Right => null, - Color => Red, + Color => Red_Black_Trees.Red, Element => Element); exception when others => @@ -838,28 +999,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise; end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert_Sans_Hint begin - Insert_Sans_Hint - (Container.Tree, + Conditional_Insert_Sans_Hint + (Tree, New_Item, - Position.Node, + Node, Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error; - end if; - end Insert; + end Insert_Sans_Hint; ---------------------- -- Insert_With_Hint -- @@ -1047,6 +1195,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin + if Container.Tree.Last = null then + raise Constraint_Error; + end if; + return Container.Tree.Last.Element.all; end Last_Element; @@ -1095,6 +1247,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare Node : constant Node_Access := Tree_Operations.Next (Position.Node); @@ -1141,6 +1296,9 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := Tree_Operations.Previous (Position.Node); @@ -1162,29 +1320,40 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element.all; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - S : Set renames Position.Container.all; - T : Tree_Type renames S.Tree'Unrestricted_Access.all; + if Position.Node.Element = null then + raise Program_Error; + end if; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - begin - B := B + 1; - L := L + 1; + declare + T : Tree_Type renames Position.Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.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; ---------- @@ -1227,6 +1396,14 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + ------------- -- Replace -- ------------- @@ -1242,6 +1419,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + X := Node.Element; Node.Element := new Element_Type'(New_Item); Free_Element (X); @@ -1295,6 +1476,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function New_Node return Node_Access is begin Node.Element := new Element_Type'(Item); -- OK if fails + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; end New_Node; @@ -1340,6 +1526,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function New_Node return Node_Access is begin + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; end New_Node; @@ -1372,10 +1563,17 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Constraint_Error; end if; + if Position.Node.Element = null then + raise Program_Error; + end if; + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; @@ -1482,6 +1680,20 @@ package body Ada.Containers.Indefinite_Ordered_Sets is return Set'(Controlled with Tree); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + Inserted : Boolean; + + begin + Insert_Sans_Hint (Tree, New_Item, Node, Inserted); + return Set'(Controlled with Tree); + end To_Set; + ----------- -- Union -- ----------- @@ -1532,4 +1744,12 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index 76349600060..1c1c7860332 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -61,6 +61,8 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -266,6 +268,7 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -275,9 +278,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 1a165499f90..d235d0b0c79 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -624,6 +624,7 @@ package body Ada.Containers.Hashed_Maps is declare HT : Hash_Table_Type renames Position.Container.HT; Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); + begin if Node = null then return No_Element; @@ -695,6 +696,14 @@ package body Ada.Containers.Hashed_Maps is Read_Nodes (Stream, Container.HT); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------- -- Read_Node -- --------------- @@ -743,7 +752,11 @@ package body Ada.Containers.Hashed_Maps is -- Replace_Element -- --------------------- - procedure Replace_Element (Position : Cursor; By : Element_Type) is + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is begin pragma Assert (Vet (Position), "bad cursor in Replace_Element"); @@ -751,11 +764,15 @@ package body Ada.Containers.Hashed_Maps is raise Constraint_Error; end if; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + if Position.Container.HT.Lock > 0 then raise Program_Error; end if; - Position.Node.Element := By; + Position.Node.Element := New_Item; end Replace_Element; ---------------------- @@ -784,9 +801,10 @@ package body Ada.Containers.Hashed_Maps is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is begin pragma Assert (Vet (Position), "bad cursor in Update_Element"); @@ -795,12 +813,14 @@ package body Ada.Containers.Hashed_Maps is raise Constraint_Error; end if; - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - B : Natural renames HT.Busy; - L : Natural renames HT.Lock; + declare + HT : Hash_Table_Type renames Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; begin B := B + 1; @@ -809,7 +829,6 @@ package body Ada.Containers.Hashed_Maps is declare K : Key_Type renames Position.Node.Key; E : Element_Type renames Position.Node.Element; - begin Process (K, E); exception @@ -891,6 +910,14 @@ package body Ada.Containers.Hashed_Maps is Write_Nodes (Stream, Container.HT); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + ---------------- -- Write_Node -- ---------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 0c74943506e..42b1cada502 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -39,13 +39,10 @@ with Ada.Finalization; generic type Key_Type is private; - type Element_Type is private; with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - with function "=" (Left, Right : Element_Type) return Boolean is <>; package Ada.Containers.Hashed_Maps is @@ -61,6 +58,11 @@ package Ada.Containers.Hashed_Maps is function "=" (Left, Right : Map) return Boolean; + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity (Container : in out Map; + Capacity : Count_Type); + function Length (Container : Map) return Count_Type; function Is_Empty (Container : Map) return Boolean; @@ -71,18 +73,22 @@ package Ada.Containers.Hashed_Maps is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Key : Key_Type; Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Replace_Element (Position : Cursor; By : Element_Type); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -113,17 +119,11 @@ package Ada.Containers.Hashed_Maps is Key : Key_Type; New_Item : Element_Type); - procedure Delete (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Position : in out Cursor); - procedure Exclude (Container : in out Map; Key : Key_Type); - function Contains (Container : Map; Key : Key_Type) return Boolean; - - function Find (Container : Map; Key : Key_Type) return Cursor; + procedure Delete (Container : in out Map; Key : Key_Type); - function Element (Container : Map; Key : Key_Type) return Element_Type; + procedure Delete (Container : in out Map; Position : in out Cursor); function First (Container : Map) return Cursor; @@ -131,6 +131,12 @@ package Ada.Containers.Hashed_Maps is procedure Next (Position : in out Cursor); + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + function Has_Element (Position : Cursor) return Boolean; function Equivalent_Keys (Left, Right : Cursor) return Boolean; @@ -143,11 +149,6 @@ package Ada.Containers.Hashed_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)); - function Capacity (Container : Map) return Count_Type; - - procedure Reserve_Capacity (Container : in out Map; - Capacity : Count_Type); - private pragma Inline ("="); pragma Inline (Length); @@ -211,6 +212,18 @@ private Node : Node_Access; end record; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + No_Element : constant Cursor := (Container => null, Node => null); end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 05a2416c7b5..afb219055d5 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -72,6 +72,12 @@ package body Ada.Containers.Hashed_Sets is function Hash_Node (Node : Node_Access) return Hash_Type; pragma Inline (Hash_Node); + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + function Is_In (HT : Hash_Table_Type; Key : Node_Access) return Boolean; @@ -595,6 +601,32 @@ package body Ada.Containers.Hashed_Sets is Position : out Cursor; Inserted : out Boolean) is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is function New_Node (Next : Node_Access) return Node_Access; pragma Inline (New_Node); @@ -606,13 +638,10 @@ package body Ada.Containers.Hashed_Sets is -------------- function New_Node (Next : Node_Access) return Node_Access is - Node : constant Node_Access := new Node_Type'(New_Item, Next); begin - return Node; + return new Node_Type'(New_Item, Next); end New_Node; - HT : Hash_Table_Type renames Container.HT; - -- Start of processing for Insert begin @@ -620,30 +649,13 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; - Local_Insert (HT, New_Item, Position.Node, Inserted); + Local_Insert (HT, New_Item, 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; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error; - end if; end Insert; ------------------ @@ -970,6 +982,14 @@ package body Ada.Containers.Hashed_Sets is Read_Nodes (Stream, Container.HT); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------- -- Read_Node -- --------------- @@ -1366,6 +1386,20 @@ package body Ada.Containers.Hashed_Sets is return (Controlled with HT => (Buckets, Length, 0, 0)); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + Node : Node_Access; + Inserted : Boolean; + + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + ----------- -- Union -- ----------- @@ -1595,6 +1629,14 @@ package body Ada.Containers.Hashed_Sets is Write_Nodes (Stream, Container.HT); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + ---------------- -- Write_Node -- ---------------- diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index e4734c885cc..19aad2911fa 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -62,6 +62,8 @@ package Ada.Containers.Hashed_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Capacity (Container : Set) return Count_Type; procedure Reserve_Capacity @@ -222,6 +224,7 @@ private use HT_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -232,9 +235,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := (Container => null, Node => null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := (Container => null, Node => null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index 8af2f4c7302..b3c7cd8e910 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -475,44 +475,6 @@ package body Ada.Containers.Indefinite_Vectors is Count); end Append; - ------------ - -- Assign -- - ------------ - - procedure Assign - (Target : in out Vector; - Source : Vector) - is - N : constant Count_Type := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - Clear (Target); - - if N = 0 then - return; - end if; - - if N > Capacity (Target) then - Reserve_Capacity (Target, Capacity => N); - end if; - - for J in Index_Type'First .. Source.Last loop - declare - EA : constant Element_Access := Source.Elements (J); - begin - if EA /= null then - Target.Elements (J) := new Element_Type'(EA.all); - end if; - end; - - Target.Last := J; - end loop; - end Assign; - -------------- -- Capacity -- -------------- @@ -553,7 +515,8 @@ package body Ada.Containers.Indefinite_Vectors is function Contains (Container : Vector; - Item : Element_Type) return Boolean is + Item : Element_Type) return Boolean + is begin return Find_Index (Container, Item) /= No_Index; end Contains; @@ -649,8 +612,7 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error; end if; - if Position.Container /= - Vector_Access'(Container'Unchecked_Access) + if Position.Container /= Container'Unchecked_Access or else Position.Index > Container.Last then raise Program_Error; @@ -658,11 +620,7 @@ package body Ada.Containers.Indefinite_Vectors is Delete (Container, Position.Index, Count); - if Position.Index <= Container.Last then - Position := (Container'Unchecked_Access, Position.Index); - else - Position := No_Element; - end if; + Position := No_Element; -- See comment in a-convec.adb end Delete; ------------------ @@ -738,7 +696,16 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error; end if; - return Container.Elements (Index).all; + declare + EA : constant Element_Access := Container.Elements (Index); + + begin + if EA = null then + raise Constraint_Error; + end if; + + return EA.all; + end; end Element; function Element (Position : Cursor) return Element_Type is @@ -773,13 +740,12 @@ package body Ada.Containers.Indefinite_Vectors is function Find (Container : Vector; Item : Element_Type; - Position : Cursor := No_Element) return Cursor is - + Position : Cursor := No_Element) return Cursor + is begin if Position.Container /= null - and then (Position.Container /= - Vector_Access'(Container'Unchecked_Access) - or else Position.Index > Container.Last) + and then (Position.Container /= Container'Unchecked_Access + or else Position.Index > Container.Last) then raise Program_Error; end if; @@ -802,7 +768,8 @@ package body Ada.Containers.Indefinite_Vectors is function Find_Index (Container : Vector; Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index is + Index : Index_Type := Index_Type'First) return Extended_Index + is begin for Indx in Index .. Container.Last loop if Container.Elements (Indx) /= null @@ -1287,7 +1254,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= Container'Unchecked_Access then raise Program_Error; end if; @@ -1843,6 +1810,10 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error; end if; + if V.Elements (Index) = null then + raise Constraint_Error; + end if; + B := B + 1; L := L + 1; @@ -1907,14 +1878,22 @@ package body Ada.Containers.Indefinite_Vectors is end loop; end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- procedure Replace_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; - By : Element_Type) + New_Item : Element_Type) is begin if Index > Container.Last then @@ -1928,18 +1907,26 @@ package body Ada.Containers.Indefinite_Vectors is declare X : Element_Access := Container.Elements (Index); begin - Container.Elements (Index) := new Element_Type'(By); + Container.Elements (Index) := new Element_Type'(New_Item); Free (X); end; end Replace_Element; - procedure Replace_Element (Position : Cursor; By : Element_Type) is + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is begin if Position.Container = null then raise Constraint_Error; end if; - Replace_Element (Position.Container.all, Position.Index, By); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Container, Position.Index, New_Item); end Replace_Element; ---------------------- @@ -2083,6 +2070,41 @@ package body Ada.Containers.Indefinite_Vectors is end; end Reserve_Capacity; + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Container.Length <= 1 then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error; + end if; + + declare + I : Index_Type := Index_Type'First; + J : Index_Type := Container.Last; + E : Elements_Type renames Container.Elements.all; + + begin + while I < J loop + declare + EI : constant Element_Access := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + ------------------ -- Reverse_Find -- ------------------ @@ -2096,8 +2118,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container /= null - and then Position.Container /= - Vector_Access'(Container'Unchecked_Access) + and then Position.Container /= Container'Unchecked_Access then raise Program_Error; end if; @@ -2230,7 +2251,7 @@ package body Ada.Containers.Indefinite_Vectors is ---------- procedure Swap - (Container : Vector; + (Container : in out Vector; I, J : Index_Type) is begin @@ -2260,7 +2281,9 @@ package body Ada.Containers.Indefinite_Vectors is end; end Swap; - procedure Swap (I, J : Cursor) + procedure Swap + (Container : in out Vector; + I, J : Cursor) is begin if I.Container = null @@ -2269,11 +2292,13 @@ package body Ada.Containers.Indefinite_Vectors is raise Constraint_Error; end if; - if I.Container /= J.Container then + if I.Container /= Container'Unrestricted_Access + or else J.Container /= Container'Unrestricted_Access + then raise Program_Error; end if; - Swap (I.Container.all, I.Index, J.Index); + Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -2387,24 +2412,27 @@ package body Ada.Containers.Indefinite_Vectors is -------------------- procedure Update_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin if Index > Container.Last then raise Constraint_Error; end if; + if Container.Elements (Index) = null then + raise Constraint_Error; + end if; + B := B + 1; L := L + 1; begin - Process (V.Elements (Index).all); + Process (Container.Elements (Index).all); exception when others => L := L - 1; @@ -2417,15 +2445,20 @@ package body Ada.Containers.Indefinite_Vectors is end Update_Element; procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) is begin if Position.Container = null then raise Constraint_Error; end if; - Update_Element (Position.Container.all, Position.Index, Process); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Update_Element (Container, Position.Index, Process); end Update_Element; ----------- @@ -2466,4 +2499,12 @@ package body Ada.Containers.Indefinite_Vectors is end; end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 6ccfda5f7fa..822e797f04a 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -38,7 +38,6 @@ with Ada.Streams; generic type Index_Type is range <>; - type Element_Type (<>) is private; with function "=" (Left, Right : Element_Type) return Boolean is <>; @@ -52,8 +51,6 @@ package Ada.Containers.Indefinite_Vectors is No_Index : constant Extended_Index := Extended_Index'First; - subtype Index_Subtype is Index_Type; - type Vector is tagged private; type Cursor is private; @@ -62,6 +59,8 @@ package Ada.Containers.Indefinite_Vectors is No_Element : constant Cursor; + function "=" (Left, Right : Vector) return Boolean; + function To_Vector (Length : Count_Type) return Vector; function To_Vector @@ -76,8 +75,6 @@ package Ada.Containers.Indefinite_Vectors is function "&" (Left, Right : Element_Type) return Vector; - function "=" (Left, Right : Vector) return Boolean; - function Capacity (Container : Vector) return Count_Type; procedure Reserve_Capacity @@ -86,6 +83,10 @@ package Ada.Containers.Indefinite_Vectors is function Length (Container : Vector) return Count_Type; + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + function Is_Empty (Container : Vector) return Boolean; procedure Clear (Container : in out Vector); @@ -102,6 +103,16 @@ package Ada.Containers.Indefinite_Vectors is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Container : Vector; Index : Index_Type; @@ -112,24 +123,14 @@ package Ada.Containers.Indefinite_Vectors is Process : not null access procedure (Element : Element_Type)); procedure Update_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Replace_Element - (Container : Vector; - Index : Index_Type; - By : Element_Type); - - procedure Replace_Element - (Position : Cursor; - By : Element_Type); - - procedure Assign (Target : in out Vector; Source : Vector); + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); procedure Move (Target : in out Vector; Source : in out Vector); @@ -197,10 +198,6 @@ package Ada.Containers.Indefinite_Vectors is Position : out Cursor; Count : Count_Type := 1); - procedure Set_Length - (Container : in out Vector; - Length : Count_Type); - procedure Delete (Container : in out Vector; Index : Extended_Index; @@ -219,6 +216,12 @@ package Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Count : Count_Type := 1); + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + function First_Index (Container : Vector) return Index_Type; function First (Container : Vector) return Cursor; @@ -231,21 +234,13 @@ package Ada.Containers.Indefinite_Vectors is function Last_Element (Container : Vector) return Element_Type; - procedure Swap (Container : Vector; I, J : Index_Type); - - procedure Swap (I, J : Cursor); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : Vector) return Boolean; + function Next (Position : Cursor) return Cursor; - procedure Sort (Container : in out Vector); + procedure Next (Position : in out Cursor); - procedure Merge (Target, Source : in out Vector); + function Previous (Position : Cursor) return Cursor; - end Generic_Sorting; + procedure Previous (Position : in out Cursor); function Find_Index (Container : Vector; @@ -255,30 +250,22 @@ package Ada.Containers.Indefinite_Vectors is function Find (Container : Vector; Item : Element_Type; - Position : Cursor := No_Element) return Cursor; + Position : Cursor := No_Element) return Cursor; function Reverse_Find_Index (Container : Vector; Item : Element_Type; Index : Index_Type := Index_Type'Last) return Extended_Index; - function Reverse_Find (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) - return Cursor; + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; function Contains (Container : Vector; Item : Element_Type) return Boolean; - function Next (Position : Cursor) return Cursor; - - function Previous (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - procedure Previous (Position : in out Cursor); - function Has_Element (Position : Cursor) return Boolean; procedure Iterate @@ -289,6 +276,18 @@ package Ada.Containers.Indefinite_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)); + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + private pragma Inline (First_Index); @@ -346,6 +345,18 @@ private Index : Index_Type := Index_Type'First; end record; + procedure Write + (Stream : access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + No_Element : constant Cursor := Cursor'(null, Index_Type'First); end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index fb3a88bb873..b298fd6a736 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -303,37 +303,6 @@ package body Ada.Containers.Vectors is Count); end Append; - ------------ - -- Assign -- - ------------ - - procedure Assign - (Target : in out Vector; - Source : Vector) - is - N : constant Count_Type := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - Clear (Target); - - if N = 0 then - return; - end if; - - if N > Capacity (Target) then - Reserve_Capacity (Target, Capacity => N); - end if; - - Target.Elements (Index_Type'First .. Source.Last) := - Source.Elements (Index_Type'First .. Source.Last); - - Target.Last := Source.Last; - end Assign; - -------------- -- Capacity -- -------------- @@ -443,8 +412,7 @@ package body Ada.Containers.Vectors is raise Constraint_Error; end if; - if Position.Container /= - Vector_Access'(Container'Unchecked_Access) + if Position.Container /= Container'Unrestricted_Access or else Position.Index > Container.Last then raise Program_Error; @@ -452,11 +420,17 @@ package body Ada.Containers.Vectors is Delete (Container, Position.Index, Count); - if Position.Index <= Container.Last then - Position := (Container'Unchecked_Access, Position.Index); - else - Position := No_Element; - end if; + -- This is the old behavior, prior to the York API (2005/06): + + -- if Position.Index <= Container.Last then + -- Position := (Container'Unchecked_Access, Position.Index); + -- else + -- Position := No_Element; + -- end if; + + -- This is the behavior specified by the York API: + + Position := No_Element; end Delete; ------------------ @@ -539,6 +513,7 @@ package body Ada.Containers.Vectors is procedure Finalize (Container : in out Vector) is X : Elements_Access := Container.Elements; + begin if Container.Busy > 0 then raise Program_Error; @@ -556,13 +531,12 @@ package body Ada.Containers.Vectors is function Find (Container : Vector; Item : Element_Type; - Position : Cursor := No_Element) return Cursor is - + Position : Cursor := No_Element) return Cursor + is begin if Position.Container /= null - and then (Position.Container /= - Vector_Access'(Container'Unchecked_Access) - or else Position.Index > Container.Last) + and then (Position.Container /= Container'Unrestricted_Access + or else Position.Index > Container.Last) then raise Program_Error; end if; @@ -583,7 +557,8 @@ package body Ada.Containers.Vectors is function Find_Index (Container : Vector; Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index is + Index : Index_Type := Index_Type'First) return Extended_Index + is begin for Indx in Index .. Container.Last loop if Container.Elements (Indx) = Item then @@ -1152,6 +1127,31 @@ package body Ada.Containers.Vectors is Position := Cursor'(Container'Unchecked_Access, Index); end Insert; + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + ------------------ -- Insert_Space -- ------------------ @@ -1339,7 +1339,7 @@ package body Ada.Containers.Vectors is Index := Before.Index; end if; - Insert_Space (Container, Index, Count); + Insert_Space (Container, Index, Count => Count); Position := Cursor'(Container'Unchecked_Access, Index); end Insert_Space; @@ -1365,7 +1365,6 @@ package body Ada.Containers.Vectors is B : Natural renames V.Busy; begin - B := B + 1; begin @@ -1379,7 +1378,6 @@ package body Ada.Containers.Vectors is end; B := B - 1; - end Iterate; ---------- @@ -1620,14 +1618,22 @@ package body Ada.Containers.Vectors is end loop; end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- procedure Replace_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; - By : Element_Type) + New_Item : Element_Type) is begin if Index > Container.Last then @@ -1638,16 +1644,24 @@ package body Ada.Containers.Vectors is raise Program_Error; end if; - Container.Elements (Index) := By; + Container.Elements (Index) := New_Item; end Replace_Element; - procedure Replace_Element (Position : Cursor; By : Element_Type) is + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is begin if Position.Container = null then raise Constraint_Error; end if; - Replace_Element (Position.Container.all, Position.Index, By); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Replace_Element (Container, Position.Index, New_Item); end Replace_Element; ---------------------- @@ -1799,6 +1813,41 @@ package body Ada.Containers.Vectors is end; end Reserve_Capacity; + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Container.Length <= 1 then + return; + end if; + + if Container.Lock > 0 then + raise Program_Error; + end if; + + declare + I : Index_Type := Index_Type'First; + J : Index_Type := Container.Last; + E : Elements_Type renames Container.Elements.all; + + begin + while I < J loop + declare + EI : constant Element_Type := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + ------------------ -- Reverse_Find -- ------------------ @@ -1921,7 +1970,7 @@ package body Ada.Containers.Vectors is -- Swap -- ---------- - procedure Swap (Container : Vector; I, J : Index_Type) is + procedure Swap (Container : in out Vector; I, J : Index_Type) is begin if I > Container.Last or else J > Container.Last @@ -1949,7 +1998,7 @@ package body Ada.Containers.Vectors is end; end Swap; - procedure Swap (I, J : Cursor) is + procedure Swap (Container : in out Vector; I, J : Cursor) is begin if I.Container = null or else J.Container = null @@ -1957,11 +2006,13 @@ package body Ada.Containers.Vectors is raise Constraint_Error; end if; - if I.Container /= J.Container then + if I.Container /= Container'Unrestricted_Access + or else J.Container /= Container'Unrestricted_Access + then raise Program_Error; end if; - Swap (I.Container.all, I.Index, J.Index); + Swap (Container, I.Index, J.Index); end Swap; --------------- @@ -2057,13 +2108,12 @@ package body Ada.Containers.Vectors is -------------------- procedure Update_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin if Index > Container.Last then @@ -2074,7 +2124,7 @@ package body Ada.Containers.Vectors is L := L + 1; begin - Process (V.Elements (Index)); + Process (Container.Elements (Index)); exception when others => L := L - 1; @@ -2087,15 +2137,20 @@ package body Ada.Containers.Vectors is end Update_Element; procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) is begin if Position.Container = null then raise Constraint_Error; end if; - Update_Element (Position.Container.all, Position.Index, Process); + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + Update_Element (Container, Position.Index, Process); end Update_Element; ----------- @@ -2114,4 +2169,12 @@ package body Ada.Containers.Vectors is end loop; end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Vectors; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 9b5c9bb82cf..5b268b5e3f0 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -50,8 +50,6 @@ package Ada.Containers.Vectors is No_Index : constant Extended_Index := Extended_Index'First; - subtype Index_Subtype is Index_Type; - type Vector is tagged private; type Cursor is private; @@ -60,6 +58,8 @@ package Ada.Containers.Vectors is No_Element : constant Cursor; + function "=" (Left, Right : Vector) return Boolean; + function To_Vector (Length : Count_Type) return Vector; function To_Vector @@ -74,8 +74,6 @@ package Ada.Containers.Vectors is function "&" (Left, Right : Element_Type) return Vector; - function "=" (Left, Right : Vector) return Boolean; - function Capacity (Container : Vector) return Count_Type; procedure Reserve_Capacity @@ -84,6 +82,10 @@ package Ada.Containers.Vectors is function Length (Container : Vector) return Count_Type; + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + function Is_Empty (Container : Vector) return Boolean; procedure Clear (Container : in out Vector); @@ -100,6 +102,16 @@ package Ada.Containers.Vectors is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Container : Vector; Index : Index_Type; @@ -110,22 +122,14 @@ package Ada.Containers.Vectors is Process : not null access procedure (Element : Element_Type)); procedure Update_Element - (Container : Vector; + (Container : in out Vector; Index : Index_Type; Process : not null access procedure (Element : in out Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Replace_Element - (Container : Vector; - Index : Index_Type; - By : Element_Type); - - procedure Replace_Element (Position : Cursor; By : Element_Type); - - procedure Assign (Target : in out Vector; Source : Vector); + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); procedure Move (Target : in out Vector; Source : in out Vector); @@ -164,6 +168,17 @@ package Ada.Containers.Vectors is Position : out Cursor; Count : Count_Type := 1); + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + procedure Prepend (Container : in out Vector; New_Item : Vector); @@ -193,10 +208,6 @@ package Ada.Containers.Vectors is Position : out Cursor; Count : Count_Type := 1); - procedure Set_Length - (Container : in out Vector; - Length : Count_Type); - procedure Delete (Container : in out Vector; Index : Extended_Index; @@ -215,6 +226,12 @@ package Ada.Containers.Vectors is (Container : in out Vector; Count : Count_Type := 1); + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + function First_Index (Container : Vector) return Index_Type; function First (Container : Vector) return Cursor; @@ -227,21 +244,13 @@ package Ada.Containers.Vectors is function Last_Element (Container : Vector) return Element_Type; - procedure Swap (Container : Vector; I, J : Index_Type); - - procedure Swap (I, J : Cursor); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : Vector) return Boolean; + function Next (Position : Cursor) return Cursor; - procedure Sort (Container : in out Vector); + procedure Next (Position : in out Cursor); - procedure Merge (Target, Source : in out Vector); + function Previous (Position : Cursor) return Cursor; - end Generic_Sorting; + procedure Previous (Position : in out Cursor); function Find_Index (Container : Vector; @@ -267,14 +276,6 @@ package Ada.Containers.Vectors is (Container : Vector; Item : Element_Type) return Boolean; - function Next (Position : Cursor) return Cursor; - - function Previous (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - procedure Previous (Position : in out Cursor); - function Has_Element (Position : Cursor) return Boolean; procedure Iterate @@ -285,6 +286,18 @@ package Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)); + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + private pragma Inline (First_Index); @@ -340,6 +353,18 @@ private Index : Index_Type := Index_Type'First; end record; + procedure Write + (Stream : access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + No_Element : constant Cursor := Cursor'(null, Index_Type'First); end Ada.Containers.Vectors; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index ba363b72436..fad63d4e498 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -81,6 +81,8 @@ package body Ada.Containers.Ordered_Maps is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); + procedure Free (X : in out Node_Access); + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; pragma Inline (Is_Equal_Node_Node); @@ -98,8 +100,6 @@ package body Ada.Containers.Ordered_Maps is -- Local Instantiations -- -------------------------- - procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package Tree_Operations is new Red_Black_Trees.Generic_Operations (Tree_Types); @@ -127,16 +127,42 @@ package body Ada.Containers.Ordered_Maps is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Key < Right.Node.Key; end "<"; function "<" (Left : Cursor; Right : Key_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Key < Right; end "<"; function "<" (Left : Key_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Key; end "<"; @@ -155,16 +181,42 @@ package body Ada.Containers.Ordered_Maps is function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Key < Left.Node.Key; end ">"; function ">" (Left : Cursor; Right : Key_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + return Right < Left.Node.Key; end ">"; function ">" (Left : Key_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Key < Left; end ">"; @@ -231,12 +283,12 @@ package body Ada.Containers.Ordered_Maps is function Copy_Node (Source : Node_Access) return Node_Access is Target : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, + new Node_Type'(Color => Source.Color, Key => Source.Key, - Element => Source.Element); + Element => Source.Element, + Parent => null, + Left => null, + Right => null); begin return Target; end Copy_Node; @@ -246,16 +298,20 @@ package body Ada.Containers.Ordered_Maps is ------------ procedure Delete (Container : in out Map; Position : in out Cursor) is + Tree : Tree_Type renames Container.Tree; + begin if Position.Node = null then raise Constraint_Error; end if; - if Position.Container /= Map_Access'(Container'Unrestricted_Access) then + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); + pragma Assert (Vet (Tree, Position.Node), "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -269,7 +325,7 @@ package body Ada.Containers.Ordered_Maps is raise Constraint_Error; end if; - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end Delete; @@ -279,6 +335,7 @@ package body Ada.Containers.Ordered_Maps is procedure Delete_First (Container : in out Map) is X : Node_Access := Container.Tree.First; + begin if X /= null then Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); @@ -292,6 +349,7 @@ package body Ada.Containers.Ordered_Maps is procedure Delete_Last (Container : in out Map) is X : Node_Access := Container.Tree.Last; + begin if X /= null then Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); @@ -305,15 +363,42 @@ package body Ada.Containers.Ordered_Maps is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + return Position.Node.Element; end Element; function Element (Container : Map; Key : Key_Type) return Element_Type is Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + if Node = null then + raise Constraint_Error; + end if; + 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 -- ------------- @@ -323,7 +408,7 @@ package body Ada.Containers.Ordered_Maps is begin if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); Free (X); end if; end Exclude; @@ -348,12 +433,14 @@ package body Ada.Containers.Ordered_Maps is ----------- function First (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin - if Container.Tree.First = null then + if T.First = null then return No_Element; end if; - return Cursor'(Container'Unrestricted_Access, Container.Tree.First); + return Cursor'(Container'Unrestricted_Access, T.First); end First; ------------------- @@ -361,8 +448,14 @@ package body Ada.Containers.Ordered_Maps is ------------------- function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.First.Element; + if T.First = null then + raise Constraint_Error; + end if; + + return T.First.Element; end First_Element; --------------- @@ -370,8 +463,14 @@ package body Ada.Containers.Ordered_Maps is --------------- function First_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.First.Key; + if T.First = null then + raise Constraint_Error; + end if; + + return T.First.Key; end First_Key; ----------- @@ -389,6 +488,26 @@ package body Ada.Containers.Ordered_Maps is return Cursor'(Container'Unrestricted_Access, Node); end Floor; + ---------- + -- 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 + return; + end if; + + X.Parent := X; + X.Left := X; + X.Right := X; + + Deallocate (X); + end Free; + ----------------- -- Has_Element -- ----------------- @@ -444,15 +563,13 @@ package body Ada.Containers.Ordered_Maps is -------------- function New_Node return Node_Access is - Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, - Key => Key, - Element => New_Item); begin - return Node; + return new Node_Type'(Key => Key, + Element => New_Item, + Color => Red_Black_Trees.Red, + Parent => null, + Left => null, + Right => null); end New_Node; -- Start of processing for Insert @@ -507,18 +624,13 @@ package body Ada.Containers.Ordered_Maps is -------------- function New_Node return Node_Access is - Node : Node_Access := new Node_Type; - begin - begin - Node.Key := Key; - exception - when others => - Free (Node); - raise; - end; - - return Node; + return new Node_Type'(Key => Key, + Element => <>, + Color => Red_Black_Trees.Red, + Parent => null, + Left => null, + Right => null); end New_Node; -- Start of processing for Insert @@ -633,6 +745,13 @@ package body Ada.Containers.Ordered_Maps is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Position.Node.Key; end Key; @@ -641,12 +760,14 @@ package body Ada.Containers.Ordered_Maps is ---------- function Last (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin - if Container.Tree.Last = null then + if T.Last = null then return No_Element; end if; - return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); + return Cursor'(Container'Unrestricted_Access, T.Last); end Last; ------------------ @@ -654,8 +775,14 @@ package body Ada.Containers.Ordered_Maps is ------------------ function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.Last.Element; + if T.Last = null then + raise Constraint_Error; + end if; + + return T.Last.Element; end Last_Element; -------------- @@ -663,8 +790,14 @@ package body Ada.Containers.Ordered_Maps is -------------- function Last_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin - return Container.Tree.Last.Key; + if T.Last = null then + raise Constraint_Error; + end if; + + return T.Last.Key; end Last_Key; ---------- @@ -712,6 +845,9 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare Node : constant Node_Access := Tree_Operations.Next (Position.Node); @@ -749,6 +885,9 @@ package body Ada.Containers.Ordered_Maps is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := Tree_Operations.Previous (Position.Node); @@ -771,29 +910,40 @@ package body Ada.Containers.Ordered_Maps is Process : not null access procedure (Key : Key_Type; Element : Element_Type)) is - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - T : Tree_Type renames Position.Container.Tree; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - B : Natural renames T.Busy; - L : Natural renames T.Lock; + declare + T : Tree_Type renames Position.Container.Tree; - begin - B := B + 1; - L := L + 1; + B : Natural renames T.Busy; + L : Natural renames T.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; + 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; end Query_Element; ---------- @@ -835,6 +985,14 @@ package body Ada.Containers.Ordered_Maps is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + ------------- -- Replace -- ------------- @@ -863,15 +1021,28 @@ package body Ada.Containers.Ordered_Maps is -- Replace_Element -- --------------------- - procedure Replace_Element (Position : Cursor; By : Element_Type) is - E : Element_Type renames Position.Node.Element; - + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is begin - if Position.Container.Tree.Lock > 0 then + if Position.Node = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then raise Program_Error; end if; - E := By; + if Container.Tree.Lock > 0 then + raise Program_Error; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Position.Node.Element := New_Item; end Replace_Element; --------------------- @@ -968,33 +1139,49 @@ package body Ada.Containers.Ordered_Maps is -------------------- procedure Update_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) is - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - T : Tree_Type renames Position.Container.Tree; + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; - B : Natural renames T.Busy; - L : Natural renames T.Lock; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element"); - begin - B := B + 1; - L := L + 1; + declare + T : Tree_Type renames Container.Tree; + + B : Natural renames T.Busy; + L : Natural renames T.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; + 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; end Update_Element; ----------- @@ -1032,4 +1219,12 @@ package body Ada.Containers.Ordered_Maps is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 0efa16fbbb0..7f8386b4b13 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -38,9 +38,7 @@ with Ada.Finalization; with Ada.Streams; generic - type Key_Type is private; - type Element_Type is private; with function "<" (Left, Right : Key_Type) return Boolean is <>; @@ -49,6 +47,8 @@ generic package Ada.Containers.Ordered_Maps is pragma Preelaborate; + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + type Map is tagged private; type Cursor is private; @@ -69,18 +69,22 @@ package Ada.Containers.Ordered_Maps is function Element (Position : Cursor) return Element_Type; + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + procedure Query_Element (Position : Cursor; Process : not null access procedure (Key : Key_Type; Element : Element_Type)); procedure Update_Element - (Position : Cursor; - Process : not null access + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Replace_Element (Position : Cursor; By : in Element_Type); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -111,6 +115,8 @@ package Ada.Containers.Ordered_Maps is Key : Key_Type; New_Item : Element_Type); + procedure Exclude (Container : in out Map; Key : Key_Type); + procedure Delete (Container : in out Map; Key : Key_Type); procedure Delete (Container : in out Map; Position : in out Cursor); @@ -119,30 +125,18 @@ package Ada.Containers.Ordered_Maps is procedure Delete_Last (Container : in out Map); - procedure Exclude (Container : in out Map; Key : Key_Type); - - function Contains (Container : Map; Key : Key_Type) return Boolean; - - function Find (Container : Map; Key : Key_Type) return Cursor; - - function Element (Container : Map; Key : Key_Type) return Element_Type; - - function Floor (Container : Map; Key : Key_Type) return Cursor; - - function Ceiling (Container : Map; Key : Key_Type) return Cursor; - function First (Container : Map) return Cursor; - function First_Key (Container : Map) return Key_Type; - function First_Element (Container : Map) return Element_Type; - function Last (Container : Map) return Cursor; + function First_Key (Container : Map) return Key_Type; - function Last_Key (Container : Map) return Key_Type; + function Last (Container : Map) return Cursor; function Last_Element (Container : Map) return Element_Type; + function Last_Key (Container : Map) return Key_Type; + function Next (Position : Cursor) return Cursor; procedure Next (Position : in out Cursor); @@ -151,6 +145,16 @@ package Ada.Containers.Ordered_Maps is procedure Previous (Position : in out Cursor); + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + function Has_Element (Position : Cursor) return Boolean; function "<" (Left, Right : Cursor) return Boolean; @@ -202,8 +206,9 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; - type Map_Access is access Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record @@ -211,9 +216,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index caa44144d0f..eb1e3656229 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -84,6 +84,13 @@ package body Ada.Containers.Ordered_Multisets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access); + procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -115,9 +122,6 @@ package body Ada.Containers.Ordered_Multisets is -- Local Instantiations -- -------------------------- - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package Tree_Operations is new Red_Black_Trees.Generic_Operations (Tree_Types); @@ -154,18 +158,44 @@ package body Ada.Containers.Ordered_Multisets is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Element < Right.Node.Element; end "<"; function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Element < Right; end "<"; function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Element; end "<"; @@ -184,6 +214,18 @@ package body Ada.Containers.Ordered_Multisets is function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + -- L > R same as R < L return Right.Node.Element < Left.Node.Element; @@ -192,12 +234,26 @@ package body Ada.Containers.Ordered_Multisets is function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + return Right < Left.Node.Element; end ">"; function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Element < Left; end ">"; @@ -299,7 +355,7 @@ package body Ada.Containers.Ordered_Multisets is end loop; end Delete; - procedure Delete (Container : in out Set; Position : in out Cursor) is + procedure Delete (Container : in out Set; Position : in out Cursor) is begin if Position.Node = null then raise Constraint_Error; @@ -309,6 +365,9 @@ package body Ada.Containers.Ordered_Multisets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); @@ -371,9 +430,31 @@ package body Ada.Containers.Ordered_Multisets is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + 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 -- --------------------- @@ -460,6 +541,10 @@ package body Ada.Containers.Ordered_Multisets is function First_Element (Container : Set) return Element_Type is begin + if Container.Tree.First = null then + raise Constraint_Error; + end if; + return Container.Tree.First.Element; end First_Element; @@ -479,6 +564,24 @@ package body Ada.Containers.Ordered_Multisets is return Cursor'(Container'Unrestricted_Access, Node); end Floor; + ---------- + -- 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.Parent := X; + X.Left := X; + X.Right := X; + + Deallocate (X); + end if; + end Free; + ------------------ -- Generic_Keys -- ------------------ @@ -510,34 +613,6 @@ package body Ada.Containers.Ordered_Multisets 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 : 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 ">"; - ------------- -- Ceiling -- ------------- @@ -596,9 +671,28 @@ package body Ada.Containers.Ordered_Multisets is Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); begin + if Node = null then + raise Constraint_Error; + end if; + 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 -- ------------- @@ -608,6 +702,7 @@ package body Ada.Containers.Ordered_Multisets is Node : Node_Access := Key_Keys.Ceiling (Tree, Key); Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); X : Node_Access; + begin while Node /= Done loop X := Node; @@ -657,7 +752,7 @@ package body Ada.Containers.Ordered_Multisets is (Left : Key_Type; Right : Node_Access) return Boolean is begin - return Left > Right.Element; + return Key (Right.Element) < Left; end Is_Greater_Key_Node; ---------------------- @@ -668,7 +763,7 @@ package body Ada.Containers.Ordered_Multisets is (Left : Key_Type; Right : Node_Access) return Boolean is begin - return Left < Right.Element; + return Left < Key (Right.Element); end Is_Less_Key_Node; ------------- @@ -720,6 +815,13 @@ package body Ada.Containers.Ordered_Multisets is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Key (Position.Node.Element); end Key; @@ -786,9 +888,12 @@ package body Ada.Containers.Ordered_Multisets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + 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; @@ -809,11 +914,7 @@ package body Ada.Containers.Ordered_Multisets is L := L - 1; B := B - 1; - if K < E - or else K > E - then - null; - else + if Equivalent_Keys (Left => K, Right => Key (E)) then return; end if; end; @@ -854,6 +955,24 @@ package body Ada.Containers.Ordered_Multisets is New_Item : Element_Type; Position : out Cursor) is + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access) + is function New_Node return Node_Access; pragma Inline (New_Node); @@ -869,25 +988,23 @@ package body Ada.Containers.Ordered_Multisets is function New_Node return Node_Access is Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, Element => New_Item); begin return Node; end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert_Sans_Hint begin Unconditional_Insert_Sans_Hint - (Container.Tree, + (Tree, New_Item, - Position.Node); - - Position.Container := Container'Unrestricted_Access; - end Insert; + Node); + end Insert_Sans_Hint; ---------------------- -- Insert_With_Hint -- @@ -1116,6 +1233,10 @@ package body Ada.Containers.Ordered_Multisets is function Last_Element (Container : Set) return Element_Type is begin + if Container.Tree.Last = null then + raise Constraint_Error; + end if; + return Container.Tree.Last.Element; end Last_Element; @@ -1165,6 +1286,9 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare Node : constant Node_Access := Tree_Operations.Next (Position.Node); @@ -1211,6 +1335,9 @@ package body Ada.Containers.Ordered_Multisets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := Tree_Operations.Previous (Position.Node); @@ -1231,29 +1358,36 @@ package body Ada.Containers.Ordered_Multisets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - S : Set renames Position.Container.all; - T : Tree_Type renames S.Tree'Unrestricted_Access.all; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - B : Natural renames T.Busy; - L : Natural renames T.Lock; + declare + T : Tree_Type renames Position.Container.Tree; - begin - B := B + 1; - L := L + 1; + B : Natural renames T.Busy; + L : Natural renames T.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; ---------- @@ -1294,6 +1428,14 @@ package body Ada.Containers.Ordered_Multisets is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + --------------------- -- Replace_Element -- --------------------- @@ -1336,6 +1478,11 @@ package body Ada.Containers.Ordered_Multisets is function New_Node return Node_Access is begin Node.Element := Item; + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + return Node; end New_Node; @@ -1354,12 +1501,10 @@ package body Ada.Containers.Ordered_Multisets 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; @@ -1369,7 +1514,10 @@ package body Ada.Containers.Ordered_Multisets is raise Program_Error; end if; - Replace_Element (Tree, Position.Node, By); + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; --------------------- @@ -1514,6 +1662,19 @@ package body Ada.Containers.Ordered_Multisets is return Set'(Controlled with Tree); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + + begin + Insert_Sans_Hint (Tree, New_Item, Node); + return Set'(Controlled with Tree); + end To_Set; + ----------- -- Union -- ----------- @@ -1564,4 +1725,12 @@ package body Ada.Containers.Ordered_Multisets is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index cb42f07d349..ab3d4d4d01e 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -46,6 +46,8 @@ generic package Ada.Containers.Ordered_Multisets is pragma Preelaborate; + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + type Set is tagged private; type Cursor is private; @@ -58,6 +60,8 @@ package Ada.Containers.Ordered_Multisets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -66,18 +70,16 @@ package Ada.Containers.Ordered_Multisets 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); + procedure Move (Target : in out Set; Source : in out Set); procedure Insert (Container : in out Set; @@ -88,6 +90,16 @@ package Ada.Containers.Ordered_Multisets is (Container : in out Set; New_Item : Element_Type); +-- TODO: include Replace too??? +-- +-- procedure Replace +-- (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); @@ -100,10 +112,6 @@ package Ada.Containers.Ordered_Multisets is 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; @@ -132,14 +140,6 @@ package Ada.Containers.Ordered_Multisets is 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; @@ -156,6 +156,14 @@ package Ada.Containers.Ordered_Multisets is 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; @@ -189,47 +197,37 @@ package Ada.Containers.Ordered_Multisets is 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 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; Position : Cursor; Process : not null access - procedure (Element : in out Element_Type)); + procedure (Element : in out Element_Type)); procedure Iterate (Container : Set; @@ -271,6 +269,7 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -280,9 +279,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 04652f80444..9060552302b 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -84,6 +84,14 @@ package body Ada.Containers.Ordered_Sets is function Copy_Node (Source : Node_Access) return Node_Access; pragma Inline (Copy_Node); + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + procedure Insert_With_Hint (Dst_Tree : in out Tree_Type; Dst_Hint : Node_Access; @@ -115,9 +123,6 @@ package body Ada.Containers.Ordered_Sets is -- Local Instantiations -- -------------------------- - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - package Tree_Operations is new Red_Black_Trees.Generic_Operations (Tree_Types); @@ -154,16 +159,42 @@ package body Ada.Containers.Ordered_Sets is function "<" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left.Node.Element < Right.Node.Element; end "<"; function "<" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + return Left.Node.Element < Right; end "<"; function "<" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + return Left < Right.Node.Element; end "<"; @@ -182,6 +213,18 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left, Right : Cursor) return Boolean is begin + if Left.Node = null + or else Right.Node = null + then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + -- L > R same as R < L return Right.Node.Element < Left.Node.Element; @@ -189,11 +232,25 @@ package body Ada.Containers.Ordered_Sets is function ">" (Left : Element_Type; Right : Cursor) return Boolean is begin + if Right.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + return Right.Node.Element < Left; end ">"; function ">" (Left : Cursor; Right : Element_Type) return Boolean is begin + if Left.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + return Right < Left.Node.Element; end ">"; @@ -287,6 +344,9 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); Free (Position.Node); Position.Container := null; @@ -356,6 +416,13 @@ package body Ada.Containers.Ordered_Sets is function Element (Position : Cursor) return Element_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + return Position.Node.Element; end Element; @@ -455,6 +522,10 @@ package body Ada.Containers.Ordered_Sets is function First_Element (Container : Set) return Element_Type is begin + if Container.Tree.First = null then + raise Constraint_Error; + end if; + return Container.Tree.First.Element; end First_Element; @@ -474,6 +545,24 @@ package body Ada.Containers.Ordered_Sets is return Cursor'(Container'Unrestricted_Access, Node); end Floor; + ---------- + -- 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.Parent := X; + X.Left := X; + X.Right := X; + + Deallocate (X); + end if; + end Free; + ------------------ -- Generic_Keys -- ------------------ @@ -550,13 +639,15 @@ package body Ada.Containers.Ordered_Sets is -- Element -- ------------- - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); begin + if Node = null then + raise Constraint_Error; + end if; + return Node.Element; end Element; @@ -649,6 +740,13 @@ package body Ada.Containers.Ordered_Sets is function Key (Position : Cursor) return Key_Type is begin + if Position.Node = null then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + return Key (Position.Node.Element); end Key; @@ -691,6 +789,9 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + declare E : Element_Type renames Position.Node.Element; K : constant Key_Type := Key (E); @@ -770,32 +871,6 @@ package body Ada.Containers.Ordered_Sets is Position : out Cursor; Inserted : out Boolean) is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, - Element => New_Item); - begin - return Node; - end New_Node; - - -- Start of processing for Insert - begin Insert_Sans_Hint (Container.Tree, @@ -822,6 +897,48 @@ package body Ada.Containers.Ordered_Sets is end Insert; ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, + Element => New_Item); + end New_Node; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Tree, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- -- Insert_With_Hint -- ---------------------- @@ -1012,6 +1129,10 @@ package body Ada.Containers.Ordered_Sets is function Last_Element (Container : Set) return Element_Type is begin + if Container.Tree.Last = null then + raise Constraint_Error; + end if; + return Container.Tree.Last.Element; end Last_Element; @@ -1055,6 +1176,9 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + declare Node : constant Node_Access := Tree_Operations.Next (Position.Node); @@ -1101,6 +1225,9 @@ package body Ada.Containers.Ordered_Sets is return No_Element; end if; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + declare Node : constant Node_Access := Tree_Operations.Previous (Position.Node); @@ -1127,29 +1254,36 @@ package body Ada.Containers.Ordered_Sets is (Position : Cursor; Process : not null access procedure (Element : Element_Type)) is - E : Element_Type renames Position.Node.Element; + begin + if Position.Node = null then + raise Constraint_Error; + end if; - S : Set renames Position.Container.all; - T : Tree_Type renames S.Tree'Unrestricted_Access.all; + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); - B : Natural renames T.Busy; - L : Natural renames T.Lock; + declare + T : Tree_Type renames Position.Container.Tree; - begin - B := B + 1; - L := L + 1; + B : Natural renames T.Busy; + L : Natural renames T.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; ---------- @@ -1192,6 +1326,14 @@ package body Ada.Containers.Ordered_Sets is Read (Stream, Container.Tree); end Read; + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error; + end Read; + ------------- -- Replace -- ------------- @@ -1254,6 +1396,11 @@ package body Ada.Containers.Ordered_Sets is function New_Node return Node_Access is begin Node.Element := Item; + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; end New_Node; @@ -1294,6 +1441,11 @@ package body Ada.Containers.Ordered_Sets is function New_Node return Node_Access is begin + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; end New_Node; @@ -1330,6 +1482,9 @@ package body Ada.Containers.Ordered_Sets is raise Program_Error; end if; + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + Replace_Element (Container.Tree, Position.Node, New_Item); end Replace_Element; @@ -1436,6 +1591,20 @@ package body Ada.Containers.Ordered_Sets is return Set'(Controlled with Tree); end Symmetric_Difference; + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + Inserted : Boolean; + + begin + Insert_Sans_Hint (Tree, New_Item, Node, Inserted); + return Set'(Controlled with Tree); + end To_Set; + ----------- -- Union -- ----------- @@ -1486,4 +1655,12 @@ package body Ada.Containers.Ordered_Sets is Write (Stream, Container.Tree); end Write; + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error; + end Write; + end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index db5cfe5eae6..8afbd01e96f 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -60,6 +60,8 @@ package Ada.Containers.Ordered_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean; + function To_Set (New_Item : Element_Type) return Set; + function Length (Container : Set) return Count_Type; function Is_Empty (Container : Set) return Boolean; @@ -255,6 +257,7 @@ private use Red_Black_Trees; use Tree_Types; use Ada.Finalization; + use Ada.Streams; type Set_Access is access all Set; for Set_Access'Storage_Size use 0; @@ -264,9 +267,19 @@ private Node : Node_Access; end record; - No_Element : constant Cursor := Cursor'(null, null); + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : Cursor); - use Ada.Streams; + for Cursor'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); procedure Write (Stream : access Root_Stream_Type'Class; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb index 8dd62a5ce44..4720f8cbb48 100644 --- a/gcc/ada/a-crbtgo.adb +++ b/gcc/ada/a-crbtgo.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -49,91 +49,91 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); - --------------------- - -- Check_Invariant -- - --------------------- - - procedure Check_Invariant (Tree : Tree_Type) is - Root : constant Node_Access := Tree.Root; - - function Check (Node : Node_Access) return Natural; - - ----------- - -- Check -- - ----------- - - function Check (Node : Node_Access) return Natural is - begin - if Node = null then - return 0; - end if; - - if Color (Node) = Red then - declare - L : constant Node_Access := Left (Node); - begin - pragma Assert (L = null or else Color (L) = Black); - null; - end; - - declare - R : constant Node_Access := Right (Node); - begin - pragma Assert (R = null or else Color (R) = Black); - null; - end; - - declare - NL : constant Natural := Check (Left (Node)); - NR : constant Natural := Check (Right (Node)); - begin - pragma Assert (NL = NR); - return NL; - end; - end if; - - declare - NL : constant Natural := Check (Left (Node)); - NR : constant Natural := Check (Right (Node)); - begin - pragma Assert (NL = NR); - return NL + 1; - end; - end Check; - - -- Start of processing for Check_Invariant - - begin - if Root = null then - pragma Assert (Tree.First = null); - pragma Assert (Tree.Last = null); - pragma Assert (Tree.Length = 0); - null; - - else - pragma Assert (Color (Root) = Black); - pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= null); - pragma Assert (Tree.First /= null); - pragma Assert (Tree.Last /= null); - pragma Assert (Parent (Tree.Root) = null); - pragma Assert ((Tree.Length > 1) - or else (Tree.First = Tree.Last - and Tree.First = Tree.Root)); - pragma Assert (Left (Tree.First) = null); - pragma Assert (Right (Tree.Last) = null); - - declare - L : constant Node_Access := Left (Root); - R : constant Node_Access := Right (Root); - NL : constant Natural := Check (L); - NR : constant Natural := Check (R); - begin - pragma Assert (NL = NR); - null; - end; - end if; - end Check_Invariant; +-- --------------------- +-- -- Check_Invariant -- +-- --------------------- + +-- procedure Check_Invariant (Tree : Tree_Type) is +-- Root : constant Node_Access := Tree.Root; +-- +-- function Check (Node : Node_Access) return Natural; +-- +-- ----------- +-- -- Check -- +-- ----------- +-- +-- function Check (Node : Node_Access) return Natural is +-- begin +-- if Node = null then +-- return 0; +-- end if; +-- +-- if Color (Node) = Red then +-- declare +-- L : constant Node_Access := Left (Node); +-- begin +-- pragma Assert (L = null or else Color (L) = Black); +-- null; +-- end; +-- +-- declare +-- R : constant Node_Access := Right (Node); +-- begin +-- pragma Assert (R = null or else Color (R) = Black); +-- null; +-- end; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL; +-- end; +-- end if; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL + 1; +-- end; +-- end Check; +-- +-- -- Start of processing for Check_Invariant +-- +-- begin +-- if Root = null then +-- pragma Assert (Tree.First = null); +-- pragma Assert (Tree.Last = null); +-- pragma Assert (Tree.Length = 0); +-- null; +-- +-- else +-- pragma Assert (Color (Root) = Black); +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and Tree.First = Tree.Root)); +-- pragma Assert (Left (Tree.First) = null); +-- pragma Assert (Right (Tree.Last) = null); +-- +-- declare +-- L : constant Node_Access := Left (Root); +-- R : constant Node_Access := Right (Root); +-- NL : constant Natural := Check (L); +-- NR : constant Natural := Check (R); +-- begin +-- pragma Assert (NL = NR); +-- null; +-- end; +-- end if; +-- end Check_Invariant; ------------------ -- Delete_Fixup -- @@ -249,22 +249,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is raise Program_Error; end if; - pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= null); - pragma Assert (Tree.First /= null); - pragma Assert (Tree.Last /= null); - pragma Assert (Parent (Tree.Root) = null); - pragma Assert ((Tree.Length > 1) - or else (Tree.First = Tree.Last - and then Tree.First = Tree.Root)); - pragma Assert ((Left (Node) = null) - or else (Parent (Left (Node)) = Node)); - pragma Assert ((Right (Node) = null) - or else (Parent (Right (Node)) = Node)); - pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) - or else ((Parent (Node) /= null) and then - ((Left (Parent (Node)) = Node) - or else (Right (Parent (Node)) = Node)))); +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and then Tree.First = Tree.Root)); +-- pragma Assert ((Left (Node) = null) +-- or else (Parent (Left (Node)) = Node)); +-- pragma Assert ((Right (Node) = null) +-- or else (Parent (Right (Node)) = Node)); +-- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) +-- or else ((Parent (Node) /= null) and then +-- ((Left (Parent (Node)) = Node) +-- or else (Right (Parent (Node)) = Node)))); if Left (Z) = null then if Right (Z) = null then @@ -545,7 +545,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is P, X : Node_Access; begin - if Right (Source_Root) /= null then Set_Right (Node => Target_Root, @@ -586,7 +585,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is when others => Delete_Tree (Target_Root); raise; - end Generic_Copy_Tree; ------------------------- @@ -1049,4 +1047,106 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is Set_Parent (Y, X); end Right_Rotate; + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is + begin + if Node = null then + return True; + end if; + + if Parent (Node) = Node + or else Left (Node) = Node + or else Right (Node) = Node + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = null + or else Tree.First = null + or else Tree.Last = null + then + return False; + end if; + + if Parent (Tree.Root) /= null then + return False; + end if; + + if Left (Tree.First) /= null then + return False; + end if; + + if Right (Tree.Last) /= null then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Node /= Tree.First then + return False; + end if; + + if Parent (Node) /= null + or else Left (Node) /= null + or else Right (Node) /= null + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root + and then Tree.Last /= Tree.Root + then + return False; + end if; + + if Tree.First /= Node + and then Tree.Last /= Node + then + return False; + end if; + end if; + + if Left (Node) /= null + and then Parent (Left (Node)) /= Node + then + return False; + end if; + + if Right (Node) /= null + and then Parent (Right (Node)) /= Node + then + return False; + end if; + + if Parent (Node) = null then + if Tree.Root /= Node then + return False; + end if; + + elsif Left (Parent (Node)) /= Node + and then Right (Parent (Node)) /= Node + then + return False; + end if; + + return True; + end Vet; + end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads index 8b3ab50f7f8..a213a283010 100644 --- a/gcc/ada/a-crbtgo.ads +++ b/gcc/ada/a-crbtgo.ads @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2005, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -56,7 +56,14 @@ package Ada.Containers.Red_Black_Trees.Generic_Operations is function Max (Node : Node_Access) return Node_Access; - procedure Check_Invariant (Tree : Tree_Type); + -- NOTE: The Check_Invariant operation was used during early + -- development of the red-black tree. Now that the tree type + -- implementation has matured, we don't really need Check_Invariant + -- anymore. + + -- procedure Check_Invariant (Tree : Tree_Type); + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; function Next (Node : Node_Access) return Node_Access; |