1. -- 
  2. -- Copyright (c) 2012 Kevin Wellwood 
  3. -- All rights reserved. 
  4. -- 
  5. -- This source code is distributed under the Modified BSD License. For terms and 
  6. -- conditions, see license.txt. 
  7. -- 
  8.  
  9. private with Ada.Containers.Doubly_Linked_Lists; 
  10. private with Locking_Objects; 
  11.  
  12. generic 
  13.    type Element_Type is private; 
  14.  
  15.    with function "="( left, right : Element_Type ) return Boolean is <>; 
  16.  
  17. package Mutable_Lists is 
  18.  
  19.     pragma Preelaborate; 
  20.  
  21.     -- A Cursor references a location in a list. List elements referenced by 
  22.     -- cursors are locked and can only be examined via the open cursor 
  23.     -- referencing them. Any threads attempting to reference a locked list 
  24.     -- element will block until the element's cursor is closed. Note that while 
  25.     -- a List is thread safe, a Cursor is not. 
  26.     type Cursor is limited private; 
  27.  
  28.     -- Closes the cursor, unlocking the list element under examination. 
  29.     procedure Close( position : in out Cursor ); 
  30.  
  31.     -- Returns the element referenced by the cursor. An exception is raised on 
  32.     -- error. 
  33.     function Element( position : Cursor ) return Element_Type; 
  34.  
  35.     -- Returns True if the cursor is open, referencing an existing list element. 
  36.     function Has_Element( position : Cursor ) return Boolean; 
  37.  
  38.     -- Modifies the cursor to point to the next element in the list, blocking if 
  39.     -- the next element is already being examined. 
  40.     procedure Next( position : in out Cursor ); 
  41.  
  42.     ---------------------------------------------------------------------------- 
  43.  
  44.     -- A List is a thread-safe mutable list backed by doubly linked list. 
  45.     -- 
  46.     -- Mutable lists may be modified during iteration, so it is possible for a 
  47.     -- thread A to add to or remove elements from the list while a thread B is 
  48.     -- iterating across the list. However, elements which are being examined by 
  49.     -- a cursor or the Iterate procedure are locked to prevent other threads 
  50.     -- from modifying or removing elements referenced by cursors. 
  51.     -- 
  52.     -- Lists only support Append and Prepend additions. 
  53.     -- 
  54.     -- While the atomic list operations provided in this package are thread 
  55.     -- safe, there is no guarantee that the list will not be modified by a 
  56.     -- different thread between calls. For example, the following may fail: 
  57.     -- 
  58.     -- if list.Is_Empty then 
  59.     --     list.Append( element ); 
  60.     -- end if; 
  61.     -- Assert( not list.Is_Empty ); 
  62.     -- 
  63.     -- The list may be modified by other threads between the calls to Is_Empty 
  64.     -- and Append. 
  65.     type List is tagged limited private; 
  66.     type A_List is access all List'Class; 
  67.  
  68.     -- Appends the element to the list. 
  69.     procedure Append( this : not null access List'Class; element : Element_Type ); 
  70.  
  71.     -- Appends the element to the list unless it's already in the list. Inserted 
  72.     -- will be returned as True if the append was performed. 
  73.     procedure Append_No_Duplicate( this     : not null access List'Class; 
  74.                                    element  : Element_Type; 
  75.                                    inserted : out Boolean ); 
  76.  
  77.     -- Clears the list, blocking on elements that are being examined. 
  78.     procedure Clear( this : not null access List'Class ); 
  79.  
  80.     -- Returns True if 'element' is in the list. Only the existence is checked; 
  81.     -- no cursor will be returned. 
  82.     function Contains( this    : not null access List'Class; 
  83.                        element : Element_Type ) return Boolean; 
  84.  
  85.     -- Returns a cursor pointing to the element in the list, if it is found, in 
  86.     -- 'position'. The procedure will block if the element is being examined. If 
  87.     -- the element is not found in the list, a null cursor will be returned. 
  88.     procedure Find( this     : not null access List'Class; 
  89.                     element  : Element_Type; 
  90.                     position : out Cursor ); 
  91.  
  92.     -- Returns a cursor pointing to the first element in the list, blocking if 
  93.     -- the first element is being examined. 
  94.     procedure First( this : not null access List'Class; position : out Cursor ); 
  95.  
  96.     -- Returns True if the list has no elements. 
  97.     function Is_Empty( this : not null access List'Class ) return Boolean; 
  98.  
  99.     -- Iterates forward through the list, blocking on elements that are already 
  100.     -- being examined. Any thread can still modify the list while one thread is 
  101.     -- iterating over it, except for elements that are being examined. 
  102.     procedure Iterate( this    : not null access List'Class; 
  103.                        examine : access procedure( element : Element_Type ) ); 
  104.  
  105.     -- Iterates forward through the list with the option of an early exit. Set 
  106.     -- quit to True in the examine procedure to abort iteration. See Iterate for 
  107.     -- further details. 
  108.     procedure Iterate_With_Quit( this    : not null access List'Class; 
  109.                                  examine : access procedure( element : Element_Type; 
  110.                                                              quit    : in out Boolean ) ); 
  111.  
  112.     -- Returns the number of elements in the list. 
  113.     function Length( this : not null access List'Class ) return Natural; 
  114.  
  115.     -- Prepends an element to the list. 
  116.     procedure Prepend( this : not null access List'Class; element : Element_Type ); 
  117.  
  118.     -- Removes the element pointed to by position, blocking if the element is 
  119.     -- being examined. The cursor will be closed. 
  120.     procedure Remove( this : not null access List'Class; position : in out Cursor ); 
  121.  
  122.     -- Deletes the list. If there are any open cursors, the deletion will fail 
  123.     -- without modifying the list and an exception will be raised. 
  124.     procedure Delete( this : in out A_List ); 
  125.  
  126.     -- Raised when any kind of use error occurs while using a mutable list. 
  127.     -- See the exception occurence's message for details. 
  128.     Container_Error : exception; 
  129.  
  130. private 
  131.  
  132.     use Locking_Objects; 
  133.  
  134.     type Node is limited 
  135.         record 
  136.             lock    : A_Locking_Object := new Locking_Object; 
  137.             element : Element_Type; 
  138.         end record; 
  139.     type A_Node is access all Node; 
  140.  
  141.     ---------------------------------------------------------------------------- 
  142.  
  143.     package Node_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Node, "=" ); 
  144.  
  145.     type List is tagged limited 
  146.         record 
  147.             lock     : A_Locking_Object := new Locking_Object; 
  148.             refs     : Natural := 0;        -- open cursors referencing the list 
  149.             contents : Node_Lists.List; 
  150.         end record; 
  151.  
  152.     ---------------------------------------------------------------------------- 
  153.  
  154.     type Cursor is limited 
  155.         record 
  156.             list : A_List := null; 
  157.             crsr : Node_Lists.Cursor; 
  158.             node : A_Node := null; 
  159.         end record; 
  160.  
  161. end Mutable_Lists;