-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2011, 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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
with Ada.Unchecked_Deallocation;
+with System; use type System.Address;
+
package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- type Iterator is new
- List_Iterator_Interfaces.Reversible_Iterator with record
- Container : List_Access;
- Node : Node_Access;
- end record;
+ type Iterator is new Limited_Controlled and
+ List_Iterator_Interfaces.Reversible_Iterator with
+ record
+ Container : List_Access;
+ Node : Node_Access;
+ end record;
- overriding function First (Object : Iterator) return Cursor;
+ overriding procedure Finalize (Object : in out Iterator);
- overriding function Last (Object : Iterator) return Cursor;
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
overriding function Next
(Object : Iterator;
New_Node : Node_Access);
function Vet (Position : Cursor) return Boolean;
+ -- Checks invariants of the cursor and its designated container, as a
+ -- simple way of detecting dangling references (see operation Free for a
+ -- description of the detection mechanism), returning True if all checks
+ -- pass. Invocations of Vet are used here as the argument of pragma Assert,
+ -- so the checks are performed only when assertions are enabled.
---------
-- "=" --
end loop;
end Adjust;
+ procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ declare
+ C : List renames Control.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ B := B + 1;
+ L := L + 1;
+ end;
+ end if;
+ end Adjust;
+
------------
-- Append --
------------
Insert (Container, No_Element, New_Item, Count);
end Append;
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out List; Source : List) is
+ Node : Node_Access;
+
+ begin
+ if Target'Address = Source'Address then
+ return;
+ end if;
+
+ Target.Clear;
+
+ Node := Source.First;
+ while Node /= null loop
+ Target.Append (Node.Element.all);
+ Node := Node.Next;
+ end loop;
+ end Assign;
+
-----------
-- Clear --
-----------
Free (X);
end Clear;
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased List;
+ 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 (Position), "bad cursor in Constant_Reference");
+
+ declare
+ C : List renames Position.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ return R : constant Constant_Reference_Type :=
+ (Element => Position.Node.Element.all'Access,
+ Control => (Controlled with Position.Container))
+ 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 : List) return List is
+ begin
+ return Target : List do
+ Target.Assign (Source);
+ end return;
+ end Copy;
+
------------
-- Delete --
------------
return Position.Node.Element.all;
end Element;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Iterator) is
+ begin
+ if Object.Container /= null then
+ declare
+ B : Natural renames Object.Container.all.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
+ C : List renames Control.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ B := B - 1;
+ L := L - 1;
+ end;
+
+ Control.Container := null;
+ end if;
+ end Finalize;
+
----------
-- Find --
----------
while Node /= null loop
if Node.Element.all = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Next;
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.First);
+ return Cursor'(Container'Unrestricted_Access, Container.First);
end First;
function First (Object : Iterator) return Cursor is
begin
- return Cursor'(Object.Container, Object.Container.First);
+ -- 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).
+
+ -- 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 Indefinite_Doubly_Linked_Lists.First (Object.Container.all);
+ else
+ return Cursor'(Object.Container, Object.Node);
+ end if;
end First;
-------------------
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
begin
+ -- While a node is in use, as an active link in a list, its Previous and
+ -- Next components must be null, or designate a different node; this is
+ -- a node invariant. For this indefinite list, there is an additional
+ -- invariant: that the element access value be non-null. Before actually
+ -- deallocating the node, we set the node access value components of the
+ -- node to point to the node itself, and set the element access value to
+ -- null (by deallocating the node's element), thus falsifying the node
+ -- invariant. Subprogram Vet inspects the value of the node components
+ -- when interrogating the node, in order to detect whether the cursor's
+ -- node access value is dangling.
+
+ -- Note that we have no guarantee that the storage for the node isn't
+ -- modified when it is deallocated, but there are other tests that Vet
+ -- does if node invariants appear to be satisifed. However, in practice
+ -- this simple test works well enough, detecting dangling references
+ -- immediately, without needing further interrogation.
+
X.Next := X;
X.Prev := X;
LI, RI : Cursor;
begin
- if Target'Address = Source'Address then
+
+ -- The semantics of Merge changed slightly per AI05-0021. It was
+ -- originally the case that if Target and Source denoted the same
+ -- container object, then the GNAT implementation of Merge did
+ -- nothing. However, it was argued that RM05 did not precisely
+ -- specify the semantics for this corner case. The decision of the
+ -- ARG was that if Target and Source denote the same non-empty
+ -- container object, then Program_Error is raised.
+
+ if Source.Is_Empty then
return;
end if;
+ if Target'Address = Source'Address then
+ raise Program_Error with
+ "Target and Source denote same non-empty container";
+ end if;
+
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Target (list is busy)";
(Container : List;
Process : not null access procedure (Position : Cursor))
is
- C : List renames Container'Unrestricted_Access.all;
- B : Natural renames C.Busy;
-
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
Node : Node_Access := Container.First;
begin
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Next;
end loop;
exception
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
- It : constant Iterator := (Container'Unchecked_Access, Container.First);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ -- 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 : List;
Start : Cursor)
- return List_Iterator_Interfaces.Reversible_Iterator'class
+ return List_Iterator_Interfaces.Reversible_Iterator'Class
is
- It : constant Iterator := (Container'Unchecked_Access, Start.Node);
+ B : Natural renames Container'Unrestricted_Access.all.Busy;
+
begin
- return It;
+ -- 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 list";
+ end if;
+
+ pragma Assert (Vet (Start), "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 :=
+ Iterator'(Limited_Controlled with
+ Container => Container'Unrestricted_Access,
+ Node => Start.Node)
+ do
+ B := B + 1;
+ end return;
end Iterate;
----------
return No_Element;
end if;
- return Cursor'(Container'Unchecked_Access, Container.Last);
+ return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last;
function Last (Object : Iterator) return Cursor is
begin
- if Object.Container.Last = null then
- return No_Element;
- end if;
+ -- The value of the iterator object's Node component influences the
+ -- behavior of the Last (and First) selector function.
- return Cursor'(Object.Container, Object.Container.Last);
+ -- 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.
+
+ if Object.Node = null then
+ return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all);
+ else
+ return Cursor'(Object.Container, Object.Node);
+ end if;
end Last;
------------------
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
- if Position.Node = Object.Container.Last then
+ if Position.Container = null then
return No_Element;
+ end if;
- else
- return (Object.Container, Position.Node.Next);
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong list";
end if;
+
+ return Next (Position);
end Next;
-------------
function Previous (Object : Iterator; Position : Cursor) return Cursor is
begin
- if Position.Node = Position.Container.First then
+ if Position.Container = null then
return No_Element;
- else
- return (Object.Container, Position.Node.Prev);
end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Previous designates wrong list";
+ end if;
+
+ return Previous (Position);
end Previous;
-------------------
-- Reference --
---------------
- function Constant_Reference (Container : List; Position : Cursor)
- return Constant_Reference_Type is
+ function Reference
+ (Container : aliased in out List;
+ Position : Cursor) return Reference_Type
+ is
begin
- pragma Unreferenced (Container);
-
if Position.Container = null then
raise Constraint_Error with "Position cursor has no element";
end if;
- return (Element => Position.Node.Element.all'Access);
- end Constant_Reference;
-
- function Reference (Container : List; Position : Cursor)
- return Reference_Type is
- begin
- pragma Unreferenced (Container);
+ if Position.Container /= Container'Unrestricted_Access then
+ raise Program_Error with
+ "Position cursor designates wrong container";
+ end if;
- if Position.Container = null then
- raise Constraint_Error with "Position cursor has no element";
+ if Position.Node.Element = null then
+ raise Program_Error with "Node has no element";
end if;
- return (Element => Position.Node.Element.all'Access);
+ pragma Assert (Vet (Position), "bad cursor in function Reference");
+
+ declare
+ C : List renames Position.Container.all;
+ B : Natural renames C.Busy;
+ L : Natural renames C.Lock;
+ begin
+ return R : constant Reference_Type :=
+ (Element => Position.Node.Element.all'Access,
+ Control => (Controlled with Position.Container))
+ do
+ B := B + 1;
+ L := L + 1;
+ end return;
+ end;
end Reference;
---------------------
while Node /= null loop
if Node.Element.all = Item then
- return Cursor'(Container'Unchecked_Access, Node);
+ return Cursor'(Container'Unrestricted_Access, Node);
end if;
Node := Node.Prev;
begin
while Node /= null loop
- Process (Cursor'(Container'Unchecked_Access, Node));
+ Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Node.Prev;
end loop;
exception
return False;
end if;
+ -- An invariant of a node is that its Previous and Next components can
+ -- be null, or designate a different node. Also, its element access
+ -- value must be non-null. Operation Free sets the node access value
+ -- components of the node to designate the node itself, and the element
+ -- access value to null, before actually deallocating the node, thus
+ -- deliberately violating the node invariant. This gives us a simple way
+ -- to detect a dangling reference to a node.
+
if Position.Node.Next = Position.Node then
return False;
end if;
return False;
end if;
+ -- In practice the tests above will detect most instances of a dangling
+ -- reference. If we get here, it means that the invariants of the
+ -- designated node are satisfied (they at least appear to be satisfied),
+ -- so we perform some more tests, to determine whether invariants of the
+ -- designated list are satisfied too.
+
declare
L : List renames Position.Container.all;
+
begin
if L.Length = 0 then
return False;
return False;
end if;
- if Position.Node.Prev = null
- and then Position.Node /= L.First
- then
+ if Position.Node.Prev = null and then Position.Node /= L.First then
return False;
end if;
- if Position.Node.Next = null
- and then Position.Node /= L.Last
- then
+ if Position.Node.Next = null and then Position.Node /= L.Last then
return False;
end if;
OSDN Git Service
