-- --
-- 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 --
------------------------------------------------------------------------------
with System; use type System.Address;
+
with Ada.Unchecked_Deallocation;
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;
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;
X : Node_Access;
begin
- pragma Assert (Vet (Position), "bad cursor in Delete");
-
if Position.Node = null then
raise Constraint_Error;
end if;
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;
Free (X);
end loop;
+
+ Position := No_Element; -- Post-York behavior
end Delete;
------------------
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;
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
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
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
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;
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;
end if;
end Swap;
- -- Start of processing for Reverse_List
+ -- Start of processing for Reverse_Elements
begin
if Container.Length <= 1 then
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 --
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
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
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
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
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;
-- 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;
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;
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
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);
--------------------
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;
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;
-- --
-- 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 --
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
(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;
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;
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;
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;
(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;
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;
-- --
-- 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 --
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;
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;
Free (X);
end loop;
+
+ Position := No_Element; -- Post-York behavior
end Delete;
------------------
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;
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
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
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;
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;
end if;
end Swap;
- -- Start of processing for Reverse_List
+ -- Start of processing for Reverse_Elements
begin
if Container.Length <= 1 then
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 --
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
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
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;
-- 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;
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;
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
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);
--------------------
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;
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;
-- --
-- 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 --
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
(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);
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;
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;
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;
(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;
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;
-- --
-- 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 --
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 --
---------------
-- 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");
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;
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;
--------------------
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");
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;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
-
begin
Process (K, E);
exception
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 --
----------------
-- --
-- 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 --
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;
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
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;
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);
use HT_Types;
use Ada.Finalization;
+ use Ada.Streams;
procedure Adjust (Container : in out Map);
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);
-- --
-- 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 --
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);
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;
New_Item : Element_Type;
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);
raise;
end New_Node;
- HT : Hash_Table_Type renames Container.HT;
-
-- Start of processing for Insert
begin
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;
------------------
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;
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 --
---------------
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 --
-----------
-------------
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
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 --
----------------
-- --
-- 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 --
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
use HT_Types;
use Ada.Finalization;
+ use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
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);
-- --
-- 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 --
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 "<";
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 ">";
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;
-----------
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;
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;
------------------
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);
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);
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 --
-------------
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;
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;
-----------
-----------
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;
-------------------
-------------------
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;
---------------
---------------
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;
-----------
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;
----------
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
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;
----------
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;
------------------
------------------
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;
--------------
--------------
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;
----------
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;
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;
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;
----------
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 --
-------------
-- 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;
---------------------
--------------------
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;
-----------
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;
-- --
-- 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 --
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;
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);
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);
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;
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
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;
-- --
-- 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 --
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;
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 "<";
-- ">" --
---------
- 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 ">";
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);
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 --
---------------------
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;
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;
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
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 --
-------------
-------------
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 --
-------------
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;
----------------------
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;
-------------
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;
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;
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;
(Container : in out Set;
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);
return new Node_Type'(Parent => null,
Left => null,
Right => null,
- Color => Red,
+ Color => Red_Black_Trees.Red,
Element => X);
exception
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 --
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;
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);
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);
(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;
----------
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 --
---------------------
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;
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;
---------------------
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 --
-----------
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;
-- --
-- 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 --
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;
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;
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
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);
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;
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;
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;
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;
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;
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);
-- --
-- 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 --
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;
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 "<";
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;
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 ">";
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;
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;
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 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;
----------
procedure Free (X : in out Node_Access) is
-
procedure Deallocate is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
return;
end if;
+ X.Parent := X;
+ X.Left := X;
+ X.Right := X;
+
begin
Free_Element (X.Element);
exception
Key_Keys.Find (Container.Tree, Key);
begin
+ if Node = null then
+ raise Constraint_Error;
+ end if;
+
return Node.Element.all;
end Element;
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;
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);
New_Item : Element_Type;
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);
--------------
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 =>
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 --
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;
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);
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);
(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;
----------
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 --
-------------
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);
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;
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;
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;
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 --
-----------
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;
-- --
-- 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 --
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;
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;
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;
-- --
-- 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 --
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;
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 --
---------------
-- 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");
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;
----------------------
--------------------
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");
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;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
-
begin
Process (K, E);
exception
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 --
----------------
-- --
-- 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 --
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
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;
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
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;
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;
(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);
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;
-- --
-- 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 --
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;
New_Item : Element_Type;
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);
--------------
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
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;
------------------
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 --
---------------
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 --
-----------
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 --
----------------
-- --
-- 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 --
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
use HT_Types;
use Ada.Finalization;
+ use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
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;
-- --
-- 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 --
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 --
--------------
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;
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;
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;
------------------
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
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;
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
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;
raise Constraint_Error;
end if;
+ if V.Elements (Index) = null then
+ raise Constraint_Error;
+ end if;
+
B := B + 1;
L := L + 1;
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
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;
----------------------
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 --
------------------
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;
----------
procedure Swap
- (Container : Vector;
+ (Container : in out Vector;
I, J : Index_Type)
is
begin
end;
end Swap;
- procedure Swap (I, J : Cursor)
+ procedure Swap
+ (Container : in out Vector;
+ I, J : Cursor)
is
begin
if I.Container = null
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;
---------------
--------------------
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;
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;
-----------
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;
-- --
-- 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 --
generic
type Index_Type is range <>;
-
type Element_Type (<>) is private;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
No_Index : constant Extended_Index := Extended_Index'First;
- subtype Index_Subtype is Index_Type;
-
type Vector is tagged private;
type Cursor is private;
No_Element : constant Cursor;
+ function "=" (Left, Right : Vector) return Boolean;
+
function To_Vector (Length : Count_Type) return Vector;
function To_Vector
function "&" (Left, Right : Element_Type) return Vector;
- function "=" (Left, Right : Vector) return Boolean;
-
function Capacity (Container : Vector) return Count_Type;
procedure Reserve_Capacity
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);
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;
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);
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;
(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;
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;
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
(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);
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;
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 --
--------------
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;
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;
------------------
procedure Finalize (Container : in out Vector) is
X : Elements_Access := Container.Elements;
+
begin
if Container.Busy > 0 then
raise Program_Error;
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;
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
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 --
------------------
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;
B : Natural renames V.Busy;
begin
-
B := B + 1;
begin
end;
B := B - 1;
-
end Iterate;
----------
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
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;
----------------------
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 --
------------------
-- 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
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
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;
---------------
--------------------
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
L := L + 1;
begin
- Process (V.Elements (Index));
+ Process (Container.Elements (Index));
exception
when others =>
L := L - 1;
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;
-----------
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;
-- --
-- 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 --
No_Index : constant Extended_Index := Extended_Index'First;
- subtype Index_Subtype is Index_Type;
-
type Vector is tagged private;
type Cursor is private;
No_Element : constant Cursor;
+ function "=" (Left, Right : Vector) return Boolean;
+
function To_Vector (Length : Count_Type) return Vector;
function To_Vector
function "&" (Left, Right : Element_Type) return Vector;
- function "=" (Left, Right : Vector) return Boolean;
-
function Capacity (Container : Vector) return Count_Type;
procedure Reserve_Capacity
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);
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;
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);
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);
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;
(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;
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;
(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
(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);
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;
-- --
-- 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 --
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);
-- 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);
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 "<";
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 ">";
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;
------------
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;
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;
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);
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);
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 --
-------------
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;
-----------
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;
-------------------
-------------------
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;
---------------
---------------
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;
-----------
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 --
-----------------
--------------
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
--------------
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
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;
----------
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;
------------------
------------------
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;
--------------
--------------
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;
----------
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);
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);
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;
----------
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 --
-------------
-- 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;
---------------------
--------------------
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;
-----------
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;
-- --
-- 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 --
with Ada.Streams;
generic
-
type Key_Type is private;
-
type Element_Type is private;
with function "<" (Left, Right : Key_Type) return Boolean is <>;
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;
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
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);
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);
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;
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
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;
-- --
-- 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 --
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;
-- 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);
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 "<";
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;
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 ">";
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;
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);
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 --
---------------------
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;
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 --
------------------
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 --
-------------
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 --
-------------
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;
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
- return Left > Right.Element;
+ return Key (Right.Element) < Left;
end Is_Greater_Key_Node;
----------------------
(Left : Key_Type;
Right : Node_Access) return Boolean is
begin
- return Left < Right.Element;
+ return Left < Key (Right.Element);
end Is_Less_Key_Node;
-------------
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;
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;
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;
(Container : in out Set;
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);
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 --
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;
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);
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);
(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;
----------
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 --
---------------------
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;
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;
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;
---------------------
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 --
-----------
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;
-- --
-- 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 --
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;
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;
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;
(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_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;
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;
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;
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;
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;
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;
-- --
-- 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 --
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;
-- 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);
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 "<";
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;
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 ">";
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;
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 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;
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 --
------------------
-- 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;
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;
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);
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,
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 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 --
----------------------
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;
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);
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);
(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;
----------
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 --
-------------
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;
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;
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;
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 --
-----------
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;
-- --
-- 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 --
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;
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;
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;
-- --
-- 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 --
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 --
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
P, X : Node_Access;
begin
-
if Right (Source_Root) /= null then
Set_Right
(Node => Target_Root,
when others =>
Delete_Tree (Target_Root);
raise;
-
end Generic_Copy_Tree;
-------------------------
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;
-- --
-- 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 --
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;
projects / gcc.git / commitdiff