-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Ada.Unchecked_Deallocation;
+with System; use type System.Address;
+
package body Ada.Containers.Indefinite_Ordered_Sets is
+ type Iterator is new Limited_Controlled and
+ Set_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : Set_Access;
+ Node : Node_Access;
+ end record;
+
+ overriding procedure Finalize (Object : in out Iterator);
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
-----------------------
-- Local Subprograms --
-----------------------
-- Adjust --
------------
- procedure Adjust is
- new Tree_Operations.Generic_Adjust (Copy_Tree);
+ procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree);
procedure Adjust (Container : in out Set) is
begin
Adjust (Container.Tree);
end Adjust;
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ Tree : Tree_Type renames Control.Container.all.Tree;
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+ begin
+ B := B + 1;
+ L := L + 1;
+ end;
+ end if;
+ end Adjust;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Set; Source : Set) is
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Target.Clear;
+ Target.Union (Source);
+ end Assign;
+
-------------
-- Ceiling --
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
Node : constant Node_Access :=
Element_Keys.Ceiling (Container.Tree, Item);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Node));
end Ceiling;
-----------
return Node.Color;
end Color;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Set;
+ Position : Cursor) return Constant_Reference_Type
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong container";
+ end if;
+
+ if Position.Node.Element = null then
+ raise Program_Error with "Node has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Container.Tree, Position.Node),
+ "bad cursor in Constant_Reference");
+
+ declare
+ Tree : Tree_Type renames Position.Container.all.Tree;
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => Position.Node.Element.all'Access,
+ Control =>
+ (Controlled with Container'Unrestricted_Access))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
+ end Constant_Reference;
+
--------------
-- Contains --
--------------
return Find (Container, Item) /= No_Element;
end Contains;
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Set) return Set is
+ begin
+ return Target : Set do
+ Target.Assign (Source);
+ end return;
+ end Copy;
+
---------------
-- Copy_Node --
---------------
procedure Delete_First (Container : in out Set) is
Tree : Tree_Type renames Container.Tree;
X : Node_Access := Tree.First;
-
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Tree, X);
procedure Delete_Last (Container : in out Set) is
Tree : Tree_Type renames Container.Tree;
X : Node_Access := Tree.Last;
-
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Tree, X);
end Difference;
function Difference (Left, Right : Set) return Set is
- Tree : constant Tree_Type :=
- Set_Ops.Difference (Left.Tree, Right.Tree);
+ Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree);
begin
return Set'(Controlled with Tree);
end Difference;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean is
begin
- if Left < Right
- or else Right < Left
- then
+ if Left < Right or else Right < Left then
return False;
else
return True;
procedure Exclude (Container : in out Set; Item : Element_Type) is
X : Node_Access :=
Element_Keys.Find (Container.Tree, Item);
-
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
end if;
end Exclude;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.Tree.Busy;
+ begin
+ B := B - 1;
+ end;
+ end if;
+ end Finalize;
+
+ procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ Tree : Tree_Type renames Control.Container.all.Tree;
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+ begin
+ B := B - 1;
+ L := L - 1;
+ end;
+
+ Control.Container := null;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
function Find (Container : Set; Item : Element_Type) return Cursor is
Node : constant Node_Access :=
Element_Keys.Find (Container.Tree, Item);
-
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 : Set) return Cursor is
begin
- if Container.Tree.First = null then
- return No_Element;
- end if;
+ return
+ (if Container.Tree.First = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Container.Tree.First));
+ end First;
+
+ function First (Object : Iterator) return Cursor is
+ begin
+ -- The value of the iterator object's Node component influences the
+ -- behavior of the First (and Last) selector function.
+
+ -- When the Node component is null, this means the iterator object was
+ -- constructed without a start expression, in which case the (forward)
+ -- iteration starts from the (logical) beginning of the entire sequence
+ -- of items (corresponding to Container.First, for a forward iterator).
- return Cursor'(Container'Unrestricted_Access, Container.Tree.First);
+ -- Otherwise, this is iteration over a partial sequence of items. When
+ -- the Node component is non-null, the iterator object was constructed
+ -- with a start expression, that specifies the position from which the
+ -- (forward) partial iteration begins.
+
+ if Object.Node = null then
+ return Object.Container.First;
+ else
+ return Cursor'(Object.Container, Object.Node);
+ end if;
end First;
-------------------
begin
if Container.Tree.First = null then
raise Constraint_Error with "set is empty";
+ else
+ return Container.Tree.First.Element.all;
end if;
-
- return Container.Tree.First.Element.all;
end First_Element;
-----------
function Floor (Container : Set; Item : Element_Type) return Cursor is
Node : constant Node_Access :=
Element_Keys.Floor (Container.Tree, Item);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Node));
end Floor;
----------
function Ceiling (Container : Set; Key : Key_Type) return Cursor is
Node : constant Node_Access :=
Key_Keys.Ceiling (Container.Tree, Key);
+ begin
+ return (if Node = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Node));
+ end Ceiling;
+
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Set;
+ Key : Key_Type) return Constant_Reference_Type
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
begin
if Node = null then
- return No_Element;
+ raise Constraint_Error with "Key not in set";
end if;
- return Cursor'(Container'Unrestricted_Access, Node);
- end Ceiling;
+ if Node.Element = null then
+ raise Program_Error with "Node has no element";
+ end if;
+
+ declare
+ Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree;
+ B : Natural renames Tree.Busy;
+ L : Natural renames Tree.Lock;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => Node.Element.all'Access,
+ Control =>
+ (Controlled with Container'Unrestricted_Access))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
+ end Constant_Reference;
--------------
-- Contains --
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 with "key not in set";
+ else
+ return Node.Element.all;
end if;
-
- return Node.Element.all;
end Element;
---------------------
function Equivalent_Keys (Left, Right : Key_Type) return Boolean is
begin
- if Left < Right
- or else Right < Left
- then
+ if Left < Right or else Right < Left then
return False;
else
return True;
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
begin
if X /= null then
Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X);
function Find (Container : Set; Key : Key_Type) return Cursor is
Node : constant Node_Access :=
Key_Keys.Find (Container.Tree, Key);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Node));
end Find;
-----------
function Floor (Container : Set; Key : Key_Type) return Cursor is
Node : constant Node_Access :=
Key_Keys.Floor (Container.Tree, Key);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Node));
end Floor;
-------------------------
function Is_Greater_Key_Node
(Left : Key_Type;
- Right : Node_Access) return Boolean is
+ Right : Node_Access) return Boolean
+ is
begin
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 < Key (Right.Element.all);
end Is_Less_Key_Node;
Replace_Element (Container.Tree, Node, New_Item);
end Replace;
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ------------------------------
+ -- Reference_Preserving_Key --
+ ------------------------------
+
+ function Reference_Preserving_Key
+ (Container : aliased in out Set;
+ Position : Cursor) return Reference_Type
+ is
+ begin
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong container";
+ end if;
+
+ if Position.Node.Element = null then
+ raise Program_Error with "Node has no element";
+ end if;
+
+ pragma Assert
+ (Vet (Container.Tree, Position.Node),
+ "bad cursor in function Reference_Preserving_Key");
+
+ -- Some form of finalization will be required in order to actually
+ -- check that the key-part of the element designated by Position has
+ -- not changed. ???
+
+ return (Element => Position.Node.Element.all'Access);
+ end Reference_Preserving_Key;
+
+ function Reference_Preserving_Key
+ (Container : aliased in out Set;
+ Key : Key_Type) return Reference_Type
+ is
+ Node : constant Node_Access :=
+ Key_Keys.Find (Container.Tree, Key);
+
+ begin
+ if Node = null then
+ raise Constraint_Error with "Key not in set";
+ end if;
+
+ if Node.Element = null then
+ raise Program_Error with "Node has no element";
+ end if;
+
+ -- Some form of finalization will be required in order to actually
+ -- check that the key-part of the element designated by Key has not
+ -- changed. ???
+
+ return (Element => Node.Element.all'Access);
+ end Reference_Preserving_Key;
+
-----------------------------------
-- Update_Element_Preserving_Key --
-----------------------------------
raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Generic_Keys;
-----------------
function Is_Greater_Element_Node
(Left : Element_Type;
- Right : Node_Access) return Boolean is
+ Right : Node_Access) return Boolean
+ is
begin
-- e > node same as node < e
function Is_Less_Element_Node
(Left : Element_Type;
- Right : Node_Access) return Boolean is
+ Right : Node_Access) return Boolean
+ is
begin
return Left < Right.Element.all;
end Is_Less_Element_Node;
Process (Cursor'(Container'Unrestricted_Access, Node));
end Process_Node;
- T : Tree_Type renames Container.Tree'Unrestricted_Access.all;
+ T : Tree_Type renames Container'Unrestricted_Access.all.Tree;
B : Natural renames T.Busy;
-- Start of processing for Iterate
B := B - 1;
end Iterate;
+ function Iterate
+ (Container : Set)
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
+ begin
+ -- The value of the Node component influences the behavior of the First
+ -- and Last selector functions of the iterator object. When the Node
+ -- component is null (as is the case here), this means the iterator
+ -- object was constructed without a start expression. This is a complete
+ -- iterator, meaning that the iteration starts from the (logical)
+ -- beginning of the sequence of items.
+
+ -- Note: For a forward iterator, Container.First is the beginning, and
+ -- for a reverse iterator, Container.Last is the beginning.
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null)
+ do
+ B := B + 1;
+ end return;
+ end Iterate;
+
+ function Iterate
+ (Container : Set;
+ Start : Cursor)
+ return Set_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ B : Natural renames Container'Unrestricted_Access.all.Tree.Busy;
+
+ begin
+ -- It was formerly the case that when Start = No_Element, the partial
+ -- iterator was defined to behave the same as for a complete iterator,
+ -- and iterate over the entire sequence of items. However, those
+ -- semantics were unintuitive and arguably error-prone (it is too easy
+ -- to accidentally create an endless loop), and so they were changed,
+ -- per the ARG meeting in Denver on 2011/11. However, there was no
+ -- consensus about what positive meaning this corner case should have,
+ -- and so it was decided to simply raise an exception. This does imply,
+ -- however, that it is not possible to use a partial iterator to specify
+ -- an empty sequence of items.
+
+ if Start = No_Element then
+ raise Constraint_Error with
+ "Start position for iterator equals No_Element";
+ end if;
+
+ if Start.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Start cursor of Iterate designates wrong set";
+ end if;
+
+ pragma Assert (Vet (Container.Tree, Start.Node),
+ "Start cursor of Iterate is bad");
+
+ -- The value of the Node component influences the behavior of the First
+ -- and Last selector functions of the iterator object. When the Node
+ -- component is non-null (as is the case here), it means that this is a
+ -- partial iteration, over a subset of the complete sequence of
+ -- items. The iterator object was constructed with a start expression,
+ -- indicating the position from which the iteration begins. Note that
+ -- the start position has the same value irrespective of whether this is
+ -- a forward or reverse iteration.
+
+ return It : constant Iterator :=
+ (Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
+ end Iterate;
+
----------
-- Last --
----------
function Last (Container : Set) return Cursor is
begin
- if Container.Tree.Last = null then
- return No_Element;
- end if;
+ return
+ (if Container.Tree.Last = null then No_Element
+ else Cursor'(Container'Unrestricted_Access, Container.Tree.Last));
+ end Last;
+
+ function Last (Object : Iterator) return Cursor is
+ begin
+ -- The value of the iterator object's Node component influences the
+ -- behavior of the Last (and First) selector function.
+
+ -- When the Node component is null, this means the iterator object was
+ -- constructed without a start expression, in which case the (reverse)
+ -- iteration starts from the (logical) beginning of the entire sequence
+ -- (corresponding to Container.Last, for a reverse iterator).
- return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
+ -- Otherwise, this is iteration over a partial sequence of items. When
+ -- the Node component is non-null, the iterator object was constructed
+ -- with a start expression, that specifies the position from which the
+ -- (reverse) partial iteration begins.
+
+ if Object.Node = null then
+ return Object.Container.Last;
+ else
+ return Cursor'(Object.Container, Object.Node);
+ end if;
end Last;
------------------
begin
if Container.Tree.Last = null then
raise Constraint_Error with "set is empty";
+ else
+ return Container.Tree.Last.Element.all;
end if;
-
- return Container.Tree.Last.Element.all;
end Last_Element;
----------
-- Move --
----------
- procedure Move is
- new Tree_Operations.Generic_Move (Clear);
+ procedure Move is new Tree_Operations.Generic_Move (Clear);
procedure Move (Target : in out Set; Source : in out Set) is
begin
declare
Node : constant Node_Access :=
Tree_Operations.Next (Position.Node);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Position.Container, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Position.Container, Node));
end;
end Next;
+ function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is
+ begin
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong set";
+ end if;
+
+ return Next (Position);
+ end Next;
+
-------------
-- Overlap --
-------------
declare
Node : constant Node_Access :=
Tree_Operations.Previous (Position.Node);
-
begin
- if Node = null then
- return No_Element;
- end if;
-
- return Cursor'(Position.Container, Node);
+ return (if Node = null then No_Element
+ else Cursor'(Position.Container, Node));
end;
end Previous;
+ function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is
+ begin
+ if Position.Container = null then
+ return No_Element;
+ end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Previous designates wrong set";
+ end if;
+
+ return Previous (Position);
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream set cursor";
end Read;
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
-------------
-- Replace --
-------------
pragma Inline (New_Node);
procedure Local_Insert_Post is
- new Element_Keys.Generic_Insert_Post (New_Node);
+ new Element_Keys.Generic_Insert_Post (New_Node);
procedure Local_Insert_Sans_Hint is
- new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
+ new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post);
procedure Local_Insert_With_Hint is
- new Element_Keys.Generic_Conditional_Insert_With_Hint
- (Local_Insert_Post,
- Local_Insert_Sans_Hint);
+ new Element_Keys.Generic_Conditional_Insert_With_Hint
+ (Local_Insert_Post,
+ Local_Insert_Sans_Hint);
--------------
-- New_Node --
Node.Parent := null;
Node.Right := null;
Node.Left := null;
-
return Node;
end New_Node;
------------
function To_Set (New_Item : Element_Type) return Set is
- Tree : Tree_Type;
-
+ Tree : Tree_Type;
Node : Node_Access;
Inserted : Boolean;
pragma Unreferenced (Node, Inserted);
-
begin
Insert_Sans_Hint (Tree, New_Item, Node, Inserted);
return Set'(Controlled with Tree);
raise Program_Error with "attempt to stream set cursor";
end Write;
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
end Ada.Containers.Indefinite_Ordered_Sets;