--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . L I S T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2018, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+package body GNAT.Lists is
+
+ package body Doubly_Linked_List is
+ procedure Delete_Node (L : Instance; Nod : Node_Ptr);
+ pragma Inline (Delete_Node);
+ -- Detach and delete node Nod from list L
+
+ procedure Ensure_Circular (Head : Node_Ptr);
+ pragma Inline (Ensure_Circular);
+ -- Ensure that dummy head Head is circular with respect to itself
+
+ procedure Ensure_Created (L : Instance);
+ pragma Inline (Ensure_Created);
+ -- Verify that list L is created. Raise Not_Created if this is not the
+ -- case.
+
+ procedure Ensure_Full (L : Instance);
+ pragma Inline (Ensure_Full);
+ -- Verify that list L contains at least one element. Raise List_Empty if
+ -- this is not the case.
+
+ procedure Ensure_Unlocked (L : Instance);
+ pragma Inline (Ensure_Unlocked);
+ -- Verify that list L is unlocked. Raise List_Locked if this is not the
+ -- case.
+
+ function Find_Node
+ (Head : Node_Ptr;
+ Elem : Element_Type) return Node_Ptr;
+ pragma Inline (Find_Node);
+ -- Travers a list indicated by dummy head Head to determine whethe there
+ -- exists a node with element Elem. If such a node exists, return it,
+ -- otherwise return null;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Linked_List, Instance);
+
+ procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr);
+
+ procedure Insert_Between
+ (L : Instance;
+ Elem : Element_Type;
+ Left : Node_Ptr;
+ Right : Node_Ptr);
+ pragma Inline (Insert_Between);
+ -- Insert element Elem between nodes Left and Right of list L
+
+ function Is_Valid (Iter : Iterator) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Determine whether iterator Iter refers to a valid element
+
+ function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Determine whether node Nod is non-null and does not refer to dummy
+ -- head Head, thus making it valid.
+
+ procedure Lock (L : Instance);
+ pragma Inline (Lock);
+ -- Lock all mutation functionality of list L
+
+ procedure Unlock (L : Instance);
+ pragma Inline (Unlock);
+ -- Unlock all mutation functionality of list L
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (L : Instance; Elem : Element_Type) is
+ Head : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ -- Ensure that the dummy head of an empty list is circular with
+ -- respect to itself.
+
+ Head := L.Nodes'Access;
+ Ensure_Circular (Head);
+
+ -- Append the node by inserting it between the last node and the
+ -- dummy head.
+
+ Insert_Between
+ (L => L,
+ Elem => Elem,
+ Left => Head.Prev,
+ Right => Head);
+ end Append;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create return Instance is
+ begin
+ return new Linked_List;
+ end Create;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains (L : Instance; Elem : Element_Type) return Boolean is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+
+ Head := L.Nodes'Access;
+ Nod := Find_Node (Head, Elem);
+
+ return Is_Valid (Nod, Head);
+ end Contains;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (L : Instance; Elem : Element_Type) is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Full (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Find_Node (Head, Elem);
+
+ if Is_Valid (Nod, Head) then
+ Delete_Node (L, Nod);
+ end if;
+ end Delete;
+
+ ------------------
+ -- Delete_First --
+ ------------------
+
+ procedure Delete_First (L : Instance) is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Full (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Head.Next;
+
+ if Is_Valid (Nod, Head) then
+ Delete_Node (L, Nod);
+ end if;
+ end Delete_First;
+
+ -----------------
+ -- Delete_Last --
+ -----------------
+
+ procedure Delete_Last (L : Instance) is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Full (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Head.Prev;
+
+ if Is_Valid (Nod, Head) then
+ Delete_Node (L, Nod);
+ end if;
+ end Delete_Last;
+
+ -----------------
+ -- Delete_Node --
+ -----------------
+
+ procedure Delete_Node (L : Instance; Nod : Node_Ptr) is
+ Ref : Node_Ptr := Nod;
+
+ pragma Assert (Ref /= null);
+
+ Next : constant Node_Ptr := Ref.Next;
+ Prev : constant Node_Ptr := Ref.Prev;
+
+ begin
+ pragma Assert (L /= null);
+ pragma Assert (Next /= null);
+ pragma Assert (Prev /= null);
+
+ Prev.Next := Next; -- Prev ---> Next
+ Next.Prev := Prev; -- Prev <--> Next
+
+ Ref.Next := null;
+ Ref.Prev := null;
+
+ L.Elements := L.Elements - 1;
+
+ Free (Ref);
+ end Delete_Node;
+
+ -------------
+ -- Destroy --
+ -------------
+
+ procedure Destroy (L : in out Instance) is
+ Head : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+
+ while Is_Valid (Head.Next, Head) loop
+ Delete_Node (L, Head.Next);
+ end loop;
+
+ Free (L);
+ end Destroy;
+
+ ---------------------
+ -- Ensure_Circular --
+ ---------------------
+
+ procedure Ensure_Circular (Head : Node_Ptr) is
+ pragma Assert (Head /= null);
+
+ begin
+ if Head.Next = null and then Head.Prev = null then
+ Head.Next := Head;
+ Head.Prev := Head;
+ end if;
+ end Ensure_Circular;
+
+ --------------------
+ -- Ensure_Created --
+ --------------------
+
+ procedure Ensure_Created (L : Instance) is
+ begin
+ if L = null then
+ raise Not_Created;
+ end if;
+ end Ensure_Created;
+
+ -----------------
+ -- Ensure_Full --
+ -----------------
+
+ procedure Ensure_Full (L : Instance) is
+ begin
+ pragma Assert (L /= null);
+
+ if L.Elements = 0 then
+ raise List_Empty;
+ end if;
+ end Ensure_Full;
+
+ ---------------------
+ -- Ensure_Unlocked --
+ ---------------------
+
+ procedure Ensure_Unlocked (L : Instance) is
+ begin
+ pragma Assert (L /= null);
+
+ -- The list has at least one outstanding iterator
+
+ if L.Locked > 0 then
+ raise List_Locked;
+ end if;
+ end Ensure_Unlocked;
+
+ ---------------
+ -- Find_Node --
+ ---------------
+
+ function Find_Node
+ (Head : Node_Ptr;
+ Elem : Element_Type) return Node_Ptr
+ is
+ pragma Assert (Head /= null);
+
+ Nod : Node_Ptr;
+
+ begin
+ -- Traverse the nodes of the list, looking for a matching element
+
+ Nod := Head.Next;
+ while Is_Valid (Nod, Head) loop
+ if Nod.Elem = Elem then
+ return Nod;
+ end if;
+
+ Nod := Nod.Next;
+ end loop;
+
+ return null;
+ end Find_Node;
+
+ -----------
+ -- First --
+ -----------
+
+ function First (L : Instance) return Element_Type is
+ begin
+ Ensure_Created (L);
+ Ensure_Full (L);
+
+ return L.Nodes.Next.Elem;
+ end First;
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Iterator) return Boolean is
+ Is_OK : constant Boolean := Is_Valid (Iter);
+
+ begin
+ -- The iterator is no longer valid which indicates that it has been
+ -- exhausted. Unlock all mutation functionality of the list because
+ -- the iterator cannot be advanced any further.
+
+ if not Is_OK then
+ Unlock (Iter.List);
+ end if;
+
+ return Is_OK;
+ end Has_Next;
+
+ ------------------
+ -- Insert_After --
+ ------------------
+
+ procedure Insert_After
+ (L : Instance;
+ After : Element_Type;
+ Elem : Element_Type)
+ is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Find_Node (Head, After);
+
+ if Is_Valid (Nod, Head) then
+ Insert_Between
+ (L => L,
+ Elem => Elem,
+ Left => Nod,
+ Right => Nod.Next);
+ end if;
+ end Insert_After;
+
+ -------------------
+ -- Insert_Before --
+ -------------------
+
+ procedure Insert_Before
+ (L : Instance;
+ Before : Element_Type;
+ Elem : Element_Type)
+ is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Find_Node (Head, Before);
+
+ if Is_Valid (Nod, Head) then
+ Insert_Between
+ (L => L,
+ Elem => Elem,
+ Left => Nod.Prev,
+ Right => Nod);
+ end if;
+ end Insert_Before;
+
+ --------------------
+ -- Insert_Between --
+ --------------------
+
+ procedure Insert_Between
+ (L : Instance;
+ Elem : Element_Type;
+ Left : Node_Ptr;
+ Right : Node_Ptr)
+ is
+ pragma Assert (L /= null);
+ pragma Assert (Left /= null);
+ pragma Assert (Right /= null);
+
+ Nod : constant Node_Ptr :=
+ new Node'(Elem => Elem,
+ Next => Right, -- Left Nod ---> Right
+ Prev => Left); -- Left <--- Nod ---> Right
+
+ begin
+ Left.Next := Nod; -- Left <--> Nod ---> Right
+ Right.Prev := Nod; -- Left <--> Nod <--> Right
+
+ L.Elements := L.Elements + 1;
+ end Insert_Between;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (L : Instance) return Boolean is
+ begin
+ Ensure_Created (L);
+
+ return L.Elements = 0;
+ end Is_Empty;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Iter : Iterator) return Boolean is
+ begin
+ -- The invariant of Iterate and Next ensures that the iterator always
+ -- refers to a valid node if there exists one.
+
+ return Is_Valid (Iter.Nod, Iter.List.Nodes'Access);
+ end Is_Valid;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Nod : Node_Ptr; Head : Node_Ptr) return Boolean is
+ begin
+ -- A node is valid if it is non-null, and does not refer to the dummy
+ -- head of some list.
+
+ return Nod /= null and then Nod /= Head;
+ end Is_Valid;
+
+ -------------
+ -- Iterate --
+ -------------
+
+ function Iterate (L : Instance) return Iterator is
+ begin
+ Ensure_Created (L);
+
+ -- Lock all mutation functionality of the list while it is being
+ -- iterated on.
+
+ Lock (L);
+
+ return (List => L, Nod => L.Nodes.Next);
+ end Iterate;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (L : Instance) return Element_Type is
+ begin
+ Ensure_Created (L);
+ Ensure_Full (L);
+
+ return L.Nodes.Prev.Elem;
+ end Last;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (L : Instance) return Element_Count_Type is
+ begin
+ Ensure_Created (L);
+
+ return L.Elements;
+ end Length;
+
+ ----------
+ -- Lock --
+ ----------
+
+ procedure Lock (L : Instance) is
+ begin
+ pragma Assert (L /= null);
+
+ -- The list may be locked multiple times if multiple iterators are
+ -- operating over it.
+
+ L.Locked := L.Locked + 1;
+ end Lock;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out Iterator;
+ Elem : out Element_Type)
+ is
+ Is_OK : constant Boolean := Is_Valid (Iter);
+ Saved : constant Node_Ptr := Iter.Nod;
+
+ begin
+ -- The iterator is no linger valid which indicates that it has been
+ -- exhausted. Unlock all mutation functionality of the list as the
+ -- iterator cannot be advanced any further.
+
+ if not Is_OK then
+ Unlock (Iter.List);
+ raise Iterator_Exhausted;
+ end if;
+
+ -- Advance to the next node along the list
+
+ Iter.Nod := Iter.Nod.Next;
+ Elem := Saved.Elem;
+ end Next;
+
+ -------------
+ -- Prepend --
+ -------------
+
+ procedure Prepend (L : Instance; Elem : Element_Type) is
+ Head : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ -- Ensure that the dummy head of an empty list is circular with
+ -- respect to itself.
+
+ Head := L.Nodes'Access;
+ Ensure_Circular (Head);
+
+ -- Append the node by inserting it between the dummy head and the
+ -- first node.
+
+ Insert_Between
+ (L => L,
+ Elem => Elem,
+ Left => Head,
+ Right => Head.Next);
+ end Prepend;
+
+ -------------
+ -- Replace --
+ -------------
+
+ procedure Replace
+ (L : Instance;
+ Old_Elem : Element_Type;
+ New_Elem : Element_Type)
+ is
+ Head : Node_Ptr;
+ Nod : Node_Ptr;
+
+ begin
+ Ensure_Created (L);
+ Ensure_Unlocked (L);
+
+ Head := L.Nodes'Access;
+ Nod := Find_Node (Head, Old_Elem);
+
+ if Is_Valid (Nod, Head) then
+ Nod.Elem := New_Elem;
+ end if;
+ end Replace;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : Instance) is
+ begin
+ pragma Assert (L /= null);
+
+ -- The list may be locked multiple times if multiple iterators are
+ -- operating over it.
+
+ L.Locked := L.Locked - 1;
+ end Unlock;
+ end Doubly_Linked_List;
+
+end GNAT.Lists;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . L I S T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2018, 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Compiler_Unit_Warning;
+
+package GNAT.Lists is
+
+ ------------------------
+ -- Doubly_Linked_List --
+ ------------------------
+
+ -- The following package offers a doubly linked list abstraction with the
+ -- following characteristics:
+ --
+ -- * Creation of multiple instances, of different sizes.
+ -- * Iterable elements.
+ --
+ -- The following use pattern must be employed with this list:
+ --
+ -- List : Instance := Create;
+ --
+ -- <various operations>
+ --
+ -- Destroy (List)
+ --
+ -- The destruction of the list reclaims all storage occupied by it.
+
+ -- The following type denotes the number of elements stored in a list
+
+ type Element_Count_Type is range 0 .. 2 ** 31 - 1;
+
+ generic
+ type Element_Type is private;
+
+ with function "="
+ (Left : Element_Type;
+ Right : Element_Type) return Boolean;
+
+ package Doubly_Linked_List is
+
+ ---------------------
+ -- List operations --
+ ---------------------
+
+ type Instance is private;
+ Nil : constant Instance;
+
+ List_Empty : exception;
+ -- This exception is raised when the list is empty, and an attempt is
+ -- made to delete an element from it.
+
+ List_Locked : exception;
+ -- This exception is raised when the list is being iterated on, and an
+ -- attempt is made to mutate its state.
+
+ Not_Created : exception;
+ -- This exception is raised when the list has not been created by
+ -- routine Create, and an attempt is made to read or mutate its state.
+
+ procedure Append (L : Instance; Elem : Element_Type);
+ -- Insert element Elem at the end of list L. This action will raise
+ -- List_Locked if the list has outstanding iterators.
+
+ function Contains (L : Instance; Elem : Element_Type) return Boolean;
+ -- Determine whether list L contains element Elem
+
+ function Create return Instance;
+ -- Create a new list
+
+ procedure Delete (L : Instance; Elem : Element_Type);
+ -- Delete element Elem from list L. The routine has no effect if Elem is
+ -- not present. This action will raise
+ --
+ -- * List_Empty if the list is empty.
+ -- * List_Locked if the list has outstanding iterators.
+
+ procedure Delete_First (L : Instance);
+ -- Delete an element from the start of list L. This action will raise
+ --
+ -- * List_Empty if the list is empty.
+ -- * List_Locked if the list has outstanding iterators.
+
+ procedure Delete_Last (L : Instance);
+ -- Delete an element from the end of list L. This action will raise
+ --
+ -- * List_Empty if the list is empty.
+ -- * List_Locked if the list has outstanding iterators.
+
+ procedure Destroy (L : in out Instance);
+ -- Destroy the contents of list L. This routine must be called at the
+ -- end of a list's lifetime. This action will raise List_Locked if the
+ -- list has outstanding iterators.
+
+ function First (L : Instance) return Element_Type;
+ -- Obtain an element from the start of list L. This action will raise
+ -- List_Empty if the list is empty.
+
+ procedure Insert_After
+ (L : Instance;
+ After : Element_Type;
+ Elem : Element_Type);
+ -- Insert new element Elem after element After in list L. The routine
+ -- has no effect if After is not present. This action will raise
+ -- List_Locked if the list has outstanding iterators.
+
+ procedure Insert_Before
+ (L : Instance;
+ Before : Element_Type;
+ Elem : Element_Type);
+ -- Insert new element Elem before element Before in list L. The routine
+ -- has no effect if After is not present. This action will raise
+ -- List_Locked if the list has outstanding iterators.
+
+ function Is_Empty (L : Instance) return Boolean;
+ -- Determine whether list L is empty
+
+ function Last (L : Instance) return Element_Type;
+ -- Obtain an element from the end of list L. This action will raise
+ -- List_Empty if the list is empty.
+
+ function Length (L : Instance) return Element_Count_Type;
+ -- Obtain the number of elements in list L
+
+ procedure Prepend (L : Instance; Elem : Element_Type);
+ -- Insert element Elem at the start of list L. This action will raise
+ -- List_Locked if the list has outstanding iterators.
+
+ procedure Replace
+ (L : Instance;
+ Old_Elem : Element_Type;
+ New_Elem : Element_Type);
+ -- Replace old element Old_Elem with new element New_Elem in list L. The
+ -- routine has no effect if Old_Elem is not present. This action will
+ -- raise List_Locked if the list has outstanding iterators.
+
+ -------------------------
+ -- Iterator operations --
+ -------------------------
+
+ -- The following type represents an element iterator. An iterator locks
+ -- all mutation operations, and ulocks them once it is exhausted. The
+ -- iterator must be used with the following pattern:
+ --
+ -- Iter := Iterate (My_List);
+ -- while Has_Next (Iter) loop
+ -- Next (Iter, Element);
+ -- end loop;
+ --
+ -- It is possible to advance the iterator by using Next only, however
+ -- this risks raising Iterator_Exhausted.
+
+ type Iterator is private;
+
+ Iterator_Exhausted : exception;
+ -- This exception is raised when an iterator is exhausted and further
+ -- attempts to advance it are made by calling routine Next.
+
+ function Iterate (L : Instance) return Iterator;
+ -- Obtain an iterator over the elements of list L. This action locks all
+ -- mutation functionality of the associated list.
+
+ function Has_Next (Iter : Iterator) return Boolean;
+ -- Determine whether iterator Iter has more elements to examine. If the
+ -- iterator has been exhausted, restore all mutation functionality of
+ -- the associated list.
+
+ procedure Next
+ (Iter : in out Iterator;
+ Elem : out Element_Type);
+ -- Return the current element referenced by iterator Iter and advance
+ -- to the next available element. If the iterator has been exhausted
+ -- and further attempts are made to advance it, this routine restores
+ -- mutation functionality of the associated list, and then raises
+ -- Iterator_Exhausted.
+
+ private
+ -- The following type represents a list node
+
+ type Node;
+ type Node_Ptr is access all Node;
+ type Node is record
+ Elem : Element_Type;
+
+ Next : Node_Ptr := null;
+ Prev : Node_Ptr := null;
+ end record;
+
+ -- The following type represents a list
+
+ type Linked_List is record
+ Elements : Element_Count_Type := 0;
+ -- The number of elements in the list
+
+ Locked : Natural := 0;
+ -- Number of outstanding iterators
+
+ Nodes : aliased Node;
+ -- The dummy head of the list
+ end record;
+
+ type Instance is access all Linked_List;
+ Nil : constant Instance := null;
+
+ -- The following type represents an element iterator
+
+ type Iterator is record
+ List : Instance := null;
+ -- Reference to the associated list
+
+ Nod : Node_Ptr := null;
+ -- Reference to the current node being examined. The invariant of the
+ -- iterator requires that this field always points to a valid node. A
+ -- value of null indicates that the iterator is exhausted.
+ end record;
+ end Doubly_Linked_List;
+
+end GNAT.Lists;
--- /dev/null
+-- { dg-do run }
+
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.Lists; use GNAT.Lists;
+
+procedure Linkedlist is
+ package Integer_Lists is new Doubly_Linked_List
+ (Element_Type => Integer,
+ "=" => "=");
+ use Integer_Lists;
+
+ procedure Check_Empty
+ (Caller : String;
+ L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Ensure that none of the elements in the range Low_Elem .. High_Elem are
+ -- present in list L, and that the list's length is 0.
+
+ procedure Check_Locked_Mutations (Caller : String; L : in out Instance);
+ -- Ensure that all mutation operations of list L are locked
+
+ procedure Check_Present
+ (Caller : String;
+ L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Ensure that all elements in the range Low_Elem .. High_Elem are present
+ -- in list L.
+
+ procedure Check_Unlocked_Mutations (Caller : String; L : in out Instance);
+ -- Ensure that all mutation operations of list L are unlocked
+
+ procedure Populate_With_Append
+ (L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Add elements in the range Low_Elem .. High_Elem in that order in list L
+
+ procedure Test_Append;
+ -- Verify that Append properly inserts at the tail of a list
+
+ procedure Test_Contains
+ (Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Verify that Contains properly identifies that elements in the range
+ -- Low_Elem .. High_Elem are within a list.
+
+ procedure Test_Create;
+ -- Verify that all list operations fail on a non-created list
+
+ procedure Test_Delete
+ (Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Verify that Delete properly removes elements in the range Low_Elem ..
+ -- High_Elem from a list.
+
+ procedure Test_Delete_First
+ (Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Verify that Delete properly removes elements in the range Low_Elem ..
+ -- High_Elem from the head of a list.
+
+ procedure Test_Delete_Last
+ (Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Verify that Delete properly removes elements in the range Low_Elem ..
+ -- High_Elem from the tail of a list.
+
+ procedure Test_First;
+ -- Verify that First properly returns the head of a list
+
+ procedure Test_Insert_After;
+ -- Verify that Insert_After properly adds an element after some other
+ -- element.
+
+ procedure Test_Insert_Before;
+ -- Vefity that Insert_Before properly adds an element before some other
+ -- element.
+
+ procedure Test_Is_Empty;
+ -- Verify that Is_Empty properly returns this status of a list
+
+ procedure Test_Iterate;
+ -- Verify that iterators properly manipulate mutation operations
+
+ procedure Test_Iterate_Empty;
+ -- Verify that iterators properly manipulate mutation operations of an
+ -- empty list.
+
+ procedure Test_Iterate_Forced
+ (Low_Elem : Integer;
+ High_Elem : Integer);
+ -- Verify that an iterator that is forcefully advanced by Next properly
+ -- unlocks the mutation operations of a list.
+
+ procedure Test_Last;
+ -- Verify that Last properly returns the tail of a list
+
+ procedure Test_Length;
+ -- Verify that Length returns the correct length of a list
+
+ procedure Test_Prepend;
+ -- Verify that Prepend properly inserts at the head of a list
+
+ procedure Test_Replace;
+ -- Verify that Replace properly substitutes old elements with new ones
+
+ -----------------
+ -- Check_Empty --
+ -----------------
+
+ procedure Check_Empty
+ (Caller : String;
+ L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ Len : constant Element_Count_Type := Length (L);
+
+ begin
+ for Elem in Low_Elem .. High_Elem loop
+ if Contains (L, Elem) then
+ Put_Line ("ERROR: " & Caller & ": extra element" & Elem'Img);
+ end if;
+ end loop;
+
+ if Len /= 0 then
+ Put_Line ("ERROR: " & Caller & ": wrong length");
+ Put_Line ("expected: 0");
+ Put_Line ("got :" & Len'Img);
+ end if;
+ end Check_Empty;
+
+ ----------------------------
+ -- Check_Locked_Mutations --
+ ----------------------------
+
+ procedure Check_Locked_Mutations (Caller : String; L : in out Instance) is
+ begin
+ begin
+ Append (L, 1);
+ Put_Line ("ERROR: " & Caller & ": Append: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Append: unexpected exception");
+ end;
+
+ begin
+ Delete (L, 1);
+ Put_Line ("ERROR: " & Caller & ": Delete: no exception raised");
+ exception
+ when List_Empty =>
+ null;
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Delete: unexpected exception");
+ end;
+
+ begin
+ Delete_First (L);
+ Put_Line ("ERROR: " & Caller & ": Delete_First: no exception raised");
+ exception
+ when List_Empty =>
+ null;
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: " & Caller & ": Delete_First: unexpected exception");
+ end;
+
+ begin
+ Delete_Last (L);
+ Put_Line ("ERROR: " & Caller & ": Delete_List: no exception raised");
+ exception
+ when List_Empty =>
+ null;
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: " & Caller & ": Delete_Last: unexpected exception");
+ end;
+
+ begin
+ Destroy (L);
+ Put_Line ("ERROR: " & Caller & ": Destroy: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Destroy: unexpected exception");
+ end;
+
+ begin
+ Insert_After (L, 1, 2);
+ Put_Line ("ERROR: " & Caller & ": Insert_After: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: " & Caller & ": Insert_After: unexpected exception");
+ end;
+
+ begin
+ Insert_Before (L, 1, 2);
+ Put_Line
+ ("ERROR: " & Caller & ": Insert_Before: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: " & Caller & ": Insert_Before: unexpected exception");
+ end;
+
+ begin
+ Prepend (L, 1);
+ Put_Line ("ERROR: " & Caller & ": Prepend: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Prepend: unexpected exception");
+ end;
+
+ begin
+ Replace (L, 1, 2);
+ Put_Line ("ERROR: " & Caller & ": Replace: no exception raised");
+ exception
+ when List_Locked =>
+ null;
+ when others =>
+ Put_Line ("ERROR: " & Caller & ": Replace: unexpected exception");
+ end;
+ end Check_Locked_Mutations;
+
+ -------------------
+ -- Check_Present --
+ -------------------
+
+ procedure Check_Present
+ (Caller : String;
+ L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ Elem : Integer;
+ Iter : Iterator;
+
+ begin
+ Iter := Iterate (L);
+ for Exp_Elem in Low_Elem .. High_Elem loop
+ Next (Iter, Elem);
+
+ if Elem /= Exp_Elem then
+ Put_Line ("ERROR: " & Caller & ": Check_Present: wrong element");
+ Put_Line ("expected:" & Exp_Elem'Img);
+ Put_Line ("got :" & Elem'Img);
+ end if;
+ end loop;
+
+ -- At this point all elements should have been accounted for. Check for
+ -- extra elements.
+
+ while Has_Next (Iter) loop
+ Next (Iter, Elem);
+ Put_Line
+ ("ERROR: " & Caller & ": Check_Present: extra element" & Elem'Img);
+ end loop;
+
+ exception
+ when Iterator_Exhausted =>
+ Put_Line
+ ("ERROR: "
+ & Caller
+ & "Check_Present: incorrect number of elements");
+ end Check_Present;
+
+ ------------------------------
+ -- Check_Unlocked_Mutations --
+ ------------------------------
+
+ procedure Check_Unlocked_Mutations (Caller : String; L : in out Instance) is
+ begin
+ Append (L, 1);
+ Append (L, 2);
+ Append (L, 3);
+ Delete (L, 1);
+ Delete_First (L);
+ Delete_Last (L);
+ Insert_After (L, 2, 3);
+ Insert_Before (L, 2, 1);
+ Prepend (L, 0);
+ Replace (L, 3, 4);
+ end Check_Unlocked_Mutations;
+
+ --------------------------
+ -- Populate_With_Append --
+ --------------------------
+
+ procedure Populate_With_Append
+ (L : Instance;
+ Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ begin
+ for Elem in Low_Elem .. High_Elem loop
+ Append (L, Elem);
+ end loop;
+ end Populate_With_Append;
+
+ -----------------
+ -- Test_Append --
+ -----------------
+
+ procedure Test_Append is
+ L : Instance := Create;
+
+ begin
+ Append (L, 1);
+ Append (L, 2);
+ Append (L, 3);
+ Append (L, 4);
+ Append (L, 5);
+
+ Check_Present
+ (Caller => "Test_Append",
+ L => L,
+ Low_Elem => 1,
+ High_Elem => 5);
+
+ Destroy (L);
+ end Test_Append;
+
+ -------------------
+ -- Test_Contains --
+ -------------------
+
+ procedure Test_Contains
+ (Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ Low_Bogus : constant Integer := Low_Elem - 1;
+ High_Bogus : constant Integer := High_Elem + 1;
+
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, Low_Elem, High_Elem);
+
+ -- Ensure that the elements are contained in the list
+
+ for Elem in Low_Elem .. High_Elem loop
+ if not Contains (L, Elem) then
+ Put_Line
+ ("ERROR: Test_Contains: element" & Elem'Img & " not in list");
+ end if;
+ end loop;
+
+ -- Ensure that arbitrary elements which were not inserted in the list
+ -- are not contained in the list.
+
+ if Contains (L, Low_Bogus) then
+ Put_Line
+ ("ERROR: Test_Contains: element" & Low_Bogus'Img & " in list");
+ end if;
+
+ if Contains (L, High_Bogus) then
+ Put_Line
+ ("ERROR: Test_Contains: element" & High_Bogus'Img & " in list");
+ end if;
+
+ Destroy (L);
+ end Test_Contains;
+
+ -----------------
+ -- Test_Create --
+ -----------------
+
+ procedure Test_Create is
+ Count : Element_Count_Type;
+ Flag : Boolean;
+ Iter : Iterator;
+ L : Instance;
+ Val : Integer;
+
+ begin
+ -- Ensure that every routine defined in the API fails on a list which
+ -- has not been created yet.
+
+ begin
+ Append (L, 1);
+ Put_Line ("ERROR: Test_Create: Append: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Append: unexpected exception");
+ end;
+
+ begin
+ Flag := Contains (L, 1);
+ Put_Line ("ERROR: Test_Create: Contains: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Contains: unexpected exception");
+ end;
+
+ begin
+ Delete (L, 1);
+ Put_Line ("ERROR: Test_Create: Delete: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Delete: unexpected exception");
+ end;
+
+ begin
+ Delete_First (L);
+ Put_Line ("ERROR: Test_Create: Delete_First: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: Test_Create: Delete_First: unexpected exception");
+ end;
+
+ begin
+ Delete_Last (L);
+ Put_Line ("ERROR: Test_Create: Delete_Last: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Delete_Last: unexpected exception");
+ end;
+
+ begin
+ Val := First (L);
+ Put_Line ("ERROR: Test_Create: First: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: First: unexpected exception");
+ end;
+
+ begin
+ Insert_After (L, 1, 2);
+ Put_Line ("ERROR: Test_Create: Insert_After: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: Test_Create: Insert_After: unexpected exception");
+ end;
+
+ begin
+ Insert_Before (L, 1, 2);
+ Put_Line ("ERROR: Test_Create: Insert_Before: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line
+ ("ERROR: Test_Create: Insert_Before: unexpected exception");
+ end;
+
+ begin
+ Flag := Is_Empty (L);
+ Put_Line ("ERROR: Test_Create: Is_Empty: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Is_Empty: unexpected exception");
+ end;
+
+ begin
+ Iter := Iterate (L);
+ Put_Line ("ERROR: Test_Create: Iterate: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Iterate: unexpected exception");
+ end;
+
+ begin
+ Val := Last (L);
+ Put_Line ("ERROR: Test_Create: Last: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Last: unexpected exception");
+ end;
+
+ begin
+ Count := Length (L);
+ Put_Line ("ERROR: Test_Create: Length: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Length: unexpected exception");
+ end;
+
+ begin
+ Prepend (L, 1);
+ Put_Line ("ERROR: Test_Create: Prepend: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Prepend: unexpected exception");
+ end;
+
+ begin
+ Replace (L, 1, 2);
+ Put_Line ("ERROR: Test_Create: Replace: no exception raised");
+ exception
+ when Not_Created =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Create: Replace: unexpected exception");
+ end;
+ end Test_Create;
+
+ -----------------
+ -- Test_Delete --
+ -----------------
+
+ procedure Test_Delete
+ (Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ Iter : Iterator;
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, Low_Elem, High_Elem);
+
+ -- Delete the first element, which is technically the head
+
+ Delete (L, Low_Elem);
+
+ -- Ensure that all remaining elements except for the head are present in
+ -- the list.
+
+ Check_Present
+ (Caller => "Test_Delete",
+ L => L,
+ Low_Elem => Low_Elem + 1,
+ High_Elem => High_Elem);
+
+ -- Delete the last element, which is technically the tail
+
+ Delete (L, High_Elem);
+
+ -- Ensure that all remaining elements except for the head and tail are
+ -- present in the list.
+
+ Check_Present
+ (Caller => "Test_Delete",
+ L => L,
+ Low_Elem => Low_Elem + 1,
+ High_Elem => High_Elem - 1);
+
+ -- Delete all even elements
+
+ for Elem in Low_Elem + 1 .. High_Elem - 1 loop
+ if Elem mod 2 = 0 then
+ Delete (L, Elem);
+ end if;
+ end loop;
+
+ -- Ensure that all remaining elements except the head, tail, and even
+ -- elements are present in the list.
+
+ for Elem in Low_Elem + 1 .. High_Elem - 1 loop
+ if Elem mod 2 /= 0 and then not Contains (L, Elem) then
+ Put_Line ("ERROR: Test_Delete: missing element" & Elem'Img);
+ end if;
+ end loop;
+
+ -- Delete all odd elements
+
+ for Elem in Low_Elem + 1 .. High_Elem - 1 loop
+ if Elem mod 2 /= 0 then
+ Delete (L, Elem);
+ end if;
+ end loop;
+
+ -- At this point the list should be completely empty
+
+ Check_Empty
+ (Caller => "Test_Delete",
+ L => L,
+ Low_Elem => Low_Elem,
+ High_Elem => High_Elem);
+
+ -- Try to delete an element. This operation should raise List_Empty.
+
+ begin
+ Delete (L, Low_Elem);
+ Put_Line ("ERROR: Test_Delete: List_Empty not raised");
+ exception
+ when List_Empty =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Delete: unexpected exception");
+ end;
+
+ Destroy (L);
+ end Test_Delete;
+
+ -----------------------
+ -- Test_Delete_First --
+ -----------------------
+
+ procedure Test_Delete_First
+ (Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, Low_Elem, High_Elem);
+
+ -- Delete the head of the list, and verify that the remaining elements
+ -- are still present in the list.
+
+ for Elem in Low_Elem .. High_Elem loop
+ Delete_First (L);
+
+ Check_Present
+ (Caller => "Test_Delete_First",
+ L => L,
+ Low_Elem => Elem + 1,
+ High_Elem => High_Elem);
+ end loop;
+
+ -- At this point the list should be completely empty
+
+ Check_Empty
+ (Caller => "Test_Delete_First",
+ L => L,
+ Low_Elem => Low_Elem,
+ High_Elem => High_Elem);
+
+ -- Try to delete an element. This operation should raise List_Empty.
+
+ begin
+ Delete_First (L);
+ Put_Line ("ERROR: Test_Delete_First: List_Empty not raised");
+ exception
+ when List_Empty =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Delete_First: unexpected exception");
+ end;
+
+ Destroy (L);
+ end Test_Delete_First;
+
+ ----------------------
+ -- Test_Delete_Last --
+ ----------------------
+
+ procedure Test_Delete_Last
+ (Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, Low_Elem, High_Elem);
+
+ -- Delete the tail of the list, and verify that the remaining elements
+ -- are still present in the list.
+
+ for Elem in reverse Low_Elem .. High_Elem loop
+ Delete_Last (L);
+
+ Check_Present
+ (Caller => "Test_Delete_Last",
+ L => L,
+ Low_Elem => Low_Elem,
+ High_Elem => Elem - 1);
+ end loop;
+
+ -- At this point the list should be completely empty
+
+ Check_Empty
+ (Caller => "Test_Delete_Last",
+ L => L,
+ Low_Elem => Low_Elem,
+ High_Elem => High_Elem);
+
+ -- Try to delete an element. This operation should raise List_Empty.
+
+ begin
+ Delete_Last (L);
+ Put_Line ("ERROR: Test_Delete_Last: List_Empty not raised");
+ exception
+ when List_Empty =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Delete_First: unexpected exception");
+ end;
+
+ Destroy (L);
+ end Test_Delete_Last;
+
+ ----------------
+ -- Test_First --
+ ----------------
+
+ procedure Test_First is
+ Elem : Integer;
+ L : Instance := Create;
+
+ begin
+ -- Try to obtain the head. This operation should raise List_Empty.
+
+ begin
+ Elem := First (L);
+ Put_Line ("ERROR: Test_First: List_Empty not raised");
+ exception
+ when List_Empty =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_First: unexpected exception");
+ end;
+
+ Populate_With_Append (L, 1, 2);
+
+ -- Obtain the head
+
+ Elem := First (L);
+
+ if Elem /= 1 then
+ Put_Line ("ERROR: Test_First: wrong element");
+ Put_Line ("expected: 1");
+ Put_Line ("got :" & Elem'Img);
+ end if;
+
+ Destroy (L);
+ end Test_First;
+
+ -----------------------
+ -- Test_Insert_After --
+ -----------------------
+
+ procedure Test_Insert_After is
+ L : Instance := Create;
+
+ begin
+ -- Try to insert after a non-inserted element, in an empty list
+
+ Insert_After (L, 1, 2);
+
+ -- At this point the list should be completely empty
+
+ Check_Empty
+ (Caller => "Test_Insert_After",
+ L => L,
+ Low_Elem => 0,
+ High_Elem => -1);
+
+ Append (L, 1); -- 1
+
+ Insert_After (L, 1, 3); -- 1, 3
+ Insert_After (L, 1, 2); -- 1, 2, 3
+ Insert_After (L, 3, 4); -- 1, 2, 3, 4
+
+ -- Try to insert after a non-inserted element, in a full list
+
+ Insert_After (L, 10, 11);
+
+ Check_Present
+ (Caller => "Test_Insert_After",
+ L => L,
+ Low_Elem => 1,
+ High_Elem => 4);
+
+ Destroy (L);
+ end Test_Insert_After;
+
+ ------------------------
+ -- Test_Insert_Before --
+ ------------------------
+
+ procedure Test_Insert_Before is
+ L : Instance := Create;
+
+ begin
+ -- Try to insert before a non-inserted element, in an empty list
+
+ Insert_Before (L, 1, 2);
+
+ -- At this point the list should be completely empty
+
+ Check_Empty
+ (Caller => "Test_Insert_Before",
+ L => L,
+ Low_Elem => 0,
+ High_Elem => -1);
+
+ Append (L, 4); -- 4
+
+ Insert_Before (L, 4, 2); -- 2, 4
+ Insert_Before (L, 2, 1); -- 1, 2, 4
+ Insert_Before (L, 4, 3); -- 1, 2, 3, 4
+
+ -- Try to insert before a non-inserted element, in a full list
+
+ Insert_Before (L, 10, 11);
+
+ Check_Present
+ (Caller => "Test_Insert_Before",
+ L => L,
+ Low_Elem => 1,
+ High_Elem => 4);
+
+ Destroy (L);
+ end Test_Insert_Before;
+
+ -------------------
+ -- Test_Is_Empty --
+ -------------------
+
+ procedure Test_Is_Empty is
+ L : Instance := Create;
+
+ begin
+ if not Is_Empty (L) then
+ Put_Line ("ERROR: Test_Is_Empty: list is not empty");
+ end if;
+
+ Append (L, 1);
+
+ if Is_Empty (L) then
+ Put_Line ("ERROR: Test_Is_Empty: list is empty");
+ end if;
+
+ Delete_First (L);
+
+ if not Is_Empty (L) then
+ Put_Line ("ERROR: Test_Is_Empty: list is not empty");
+ end if;
+
+ Destroy (L);
+ end Test_Is_Empty;
+
+ ------------------
+ -- Test_Iterate --
+ ------------------
+
+ procedure Test_Iterate is
+ Elem : Integer;
+ Iter_1 : Iterator;
+ Iter_2 : Iterator;
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, 1, 5);
+
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the list.
+
+ Iter_1 := Iterate (L);
+
+ -- Ensure that every mutation routine defined in the API fails on a list
+ -- with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ L => L);
+
+ -- Obtain another iterator
+
+ Iter_2 := Iterate (L);
+
+ -- Ensure that every mutation is still locked
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ L => L);
+
+ -- Exhaust the first itertor
+
+ while Has_Next (Iter_1) loop
+ Next (Iter_1, Elem);
+ end loop;
+
+ -- Ensure that every mutation is still locked
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate",
+ L => L);
+
+ -- Exhaust the second itertor
+
+ while Has_Next (Iter_2) loop
+ Next (Iter_2, Elem);
+ end loop;
+
+ -- Ensure that all mutation operations are once again callable
+
+ Check_Unlocked_Mutations
+ (Caller => "Test_Iterate",
+ L => L);
+
+ Destroy (L);
+ end Test_Iterate;
+
+ ------------------------
+ -- Test_Iterate_Empty --
+ ------------------------
+
+ procedure Test_Iterate_Empty is
+ Elem : Integer;
+ Iter : Iterator;
+ L : Instance := Create;
+
+ begin
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the list.
+
+ Iter := Iterate (L);
+
+ -- Ensure that every mutation routine defined in the API fails on a list
+ -- with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate_Empty",
+ L => L);
+
+ -- Attempt to iterate over the elements
+
+ while Has_Next (Iter) loop
+ Next (Iter, Elem);
+
+ Put_Line
+ ("ERROR: Test_Iterate_Empty: element" & Elem'Img & " exists");
+ end loop;
+
+ -- Ensure that all mutation operations are once again callable
+
+ Check_Unlocked_Mutations
+ (Caller => "Test_Iterate_Empty",
+ L => L);
+
+ Destroy (L);
+ end Test_Iterate_Empty;
+
+ -------------------------
+ -- Test_Iterate_Forced --
+ -------------------------
+
+ procedure Test_Iterate_Forced
+ (Low_Elem : Integer;
+ High_Elem : Integer)
+ is
+ Elem : Integer;
+ Iter : Iterator;
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, Low_Elem, High_Elem);
+
+ -- Obtain an iterator. This action must lock all mutation operations of
+ -- the list.
+
+ Iter := Iterate (L);
+
+ -- Ensure that every mutation routine defined in the API fails on a list
+ -- with at least one outstanding iterator.
+
+ Check_Locked_Mutations
+ (Caller => "Test_Iterate_Forced",
+ L => L);
+
+ -- Forcibly advance the iterator until it raises an exception
+
+ begin
+ for Guard in Low_Elem .. High_Elem + 1 loop
+ Next (Iter, Elem);
+ end loop;
+
+ Put_Line
+ ("ERROR: Test_Iterate_Forced: Iterator_Exhausted not raised");
+ exception
+ when Iterator_Exhausted =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Iterate_Forced: unexpected exception");
+ end;
+
+ -- Ensure that all mutation operations are once again callable
+
+ Check_Unlocked_Mutations
+ (Caller => "Test_Iterate_Forced",
+ L => L);
+
+ Destroy (L);
+ end Test_Iterate_Forced;
+
+ ---------------
+ -- Test_Last --
+ ---------------
+
+ procedure Test_Last is
+ Elem : Integer;
+ L : Instance := Create;
+
+ begin
+ -- Try to obtain the tail. This operation should raise List_Empty.
+
+ begin
+ Elem := First (L);
+ Put_Line ("ERROR: Test_Last: List_Empty not raised");
+ exception
+ when List_Empty =>
+ null;
+ when others =>
+ Put_Line ("ERROR: Test_Last: unexpected exception");
+ end;
+
+ Populate_With_Append (L, 1, 2);
+
+ -- Obtain the tail
+
+ Elem := Last (L);
+
+ if Elem /= 2 then
+ Put_Line ("ERROR: Test_Last: wrong element");
+ Put_Line ("expected: 2");
+ Put_Line ("got :" & Elem'Img);
+ end if;
+
+ Destroy (L);
+ end Test_Last;
+
+ -----------------
+ -- Test_Length --
+ -----------------
+
+ procedure Test_Length is
+ L : Instance := Create;
+ Len : Element_Count_Type;
+
+ begin
+ Len := Length (L);
+
+ if Len /= 0 then
+ Put_Line ("ERROR: Test_Length: wrong length");
+ Put_Line ("expected: 0");
+ Put_Line ("got :" & Len'Img);
+ end if;
+
+ Populate_With_Append (L, 1, 2);
+ Len := Length (L);
+
+ if Len /= 2 then
+ Put_Line ("ERROR: Test_Length: wrong length");
+ Put_Line ("expected: 2");
+ Put_Line ("got :" & Len'Img);
+ end if;
+
+ Populate_With_Append (L, 3, 6);
+ Len := Length (L);
+
+ if Len /= 6 then
+ Put_Line ("ERROR: Test_Length: wrong length");
+ Put_Line ("expected: 6");
+ Put_Line ("got :" & Len'Img);
+ end if;
+
+ Destroy (L);
+ end Test_Length;
+
+ ------------------
+ -- Test_Prepend --
+ ------------------
+
+ procedure Test_Prepend is
+ L : Instance := Create;
+
+ begin
+ Prepend (L, 5);
+ Prepend (L, 4);
+ Prepend (L, 3);
+ Prepend (L, 2);
+ Prepend (L, 1);
+
+ Check_Present
+ (Caller => "Test_Prepend",
+ L => L,
+ Low_Elem => 1,
+ High_Elem => 5);
+
+ Destroy (L);
+ end Test_Prepend;
+
+ ------------------
+ -- Test_Replace --
+ ------------------
+
+ procedure Test_Replace is
+ L : Instance := Create;
+
+ begin
+ Populate_With_Append (L, 1, 5);
+
+ Replace (L, 3, 8);
+ Replace (L, 1, 6);
+ Replace (L, 4, 9);
+ Replace (L, 5, 10);
+ Replace (L, 2, 7);
+
+ Replace (L, 11, 12);
+
+ Check_Present
+ (Caller => "Test_Replace",
+ L => L,
+ Low_Elem => 6,
+ High_Elem => 10);
+
+ Destroy (L);
+ end Test_Replace;
+
+-- Start of processing for Operations
+
+begin
+ Test_Append;
+
+ Test_Contains
+ (Low_Elem => 1,
+ High_Elem => 5);
+
+ Test_Create;
+
+ Test_Delete
+ (Low_Elem => 1,
+ High_Elem => 10);
+
+ Test_Delete_First
+ (Low_Elem => 1,
+ High_Elem => 5);
+
+ Test_Delete_Last
+ (Low_Elem => 1,
+ High_Elem => 5);
+
+ Test_First;
+ Test_Insert_After;
+ Test_Insert_Before;
+ Test_Is_Empty;
+ Test_Iterate;
+ Test_Iterate_Empty;
+
+ Test_Iterate_Forced
+ (Low_Elem => 1,
+ High_Elem => 5);
+
+ Test_Last;
+ Test_Length;
+ Test_Prepend;
+ Test_Replace;
+end Linkedlist;
git://gcc.gnu.org / gcc.git / commitdiff