-- --
-- 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.Containers.Red_Black_Trees.Generic_Set_Operations;
pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations);
+with System; use type System.Address;
+
package body Ada.Containers.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;
+
------------------------------
-- Access to Fields of Node --
------------------------------
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;
+
+ 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'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);
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;
+ return (if Left < Right or else Right < Left then False else True);
end Equivalent_Elements;
---------------------
function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is
begin
- if L.Element < R.Element then
- return False;
- elsif R.Element < L.Element then
- return False;
- else
- return True;
- end if;
+ return (if L.Element < R.Element then False
+ elsif R.Element < L.Element then False
+ else True);
end Is_Equivalent_Node_Node;
-- Start of processing for Equivalent_Sets
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;
- end if;
-
- return Cursor'(Container'Unrestricted_Access, Node);
+ return (if Node = null then No_Element
+ else 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;
-------------------
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;
----------
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;
-
+ X.Left := X;
+ X.Right := X;
Deallocate (X);
end if;
end Free;
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;
+ 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'Access,
+ Control =>
+ (Controlled with Container'Unrestricted_Access))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
+ end Constant_Reference;
--------------
-- Contains --
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;
+ return (if Left < Right or else Right < Left then False else True);
end Equivalent_Keys;
-------------
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : Node_Access := Key_Keys.Find (Container.Tree, Key);
-
begin
if X /= null then
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;
-------------------------
return Key (Position.Node.Element);
end Key;
+ ----------
+ -- 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;
+
+ 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'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;
+
+ -- 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 => Node.Element'Access);
+ end Reference_Preserving_Key;
+
-------------
-- Replace --
-------------
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;
-----------------
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.
+
+ B := B + 1;
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => null);
+ 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.
+
+ B := B + 1;
+
+ return It : constant Iterator :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node);
+ 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).
+
+ -- 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.
- return Cursor'(Container'Unrestricted_Access, Container.Tree.Last);
+ 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;
end if;
-
- return Container.Tree.Last.Element;
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;
Position := Next (Position);
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;
Position := Previous (Position);
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 --
-------------------
(Stream : not null access Root_Stream_Type'Class) return Node_Access
is
Node : Node_Access := new Node_Type;
-
begin
Element_Type'Read (Stream, Node.Element);
return Node;
-
exception
when others =>
Free (Node);
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 --
-------------
function New_Node return Node_Access is
begin
Node.Element := Item;
- Node.Color := Red;
- Node.Parent := null;
- Node.Right := null;
- Node.Left := null;
-
+ Node.Color := Red;
+ Node.Parent := null;
+ Node.Right := null;
+ Node.Left := null;
return Node;
end New_Node;
-- Start of processing for Replace_Element
begin
- if Item < Node.Element
- or else Node.Element < Item
- then
+ if Item < Node.Element or else Node.Element < Item then
null;
else
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.Ordered_Sets;
OSDN Git Service
