SIMPLE COMPONENTS
version 4.3
by Dmitry A. Kazakov

(mailbox@dmitry-kazakov.de)
[Home]

This library is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

As a special exception, if other files instantiate generics from this unit, or you link this unit with other files to produce an executable, this unit does not by itself cause the resulting executable to be covered by the GNU General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Public License.


The current version provides implementations of smart pointers, directed graphs, sets, maps, B-trees, stacks, tables, string editing, unbounded arrays, expression analyzers, lock-free data structures, synchronization primitives (events, race condition free pulse events, arrays of events, reentrant mutexes, deadlock-free arrays of mutexes), pseudo-random non-repeating numbers, symmetric encoding and decoding, IEEE 754 representations support, multiple connections server designing tools. It grew out of needs and does not pretend to be universal. Tables management and strings editing are described in separate documents see Tables and Strings edit. The library is kept conform to the Ada 95, Ada 2005, Ada 2012 language standards.

Quick reference

B-trees
Chebyshev series
Cryptography
Doubly-linked webs and lists
Blackboards (lock-free)
Graphs (directed, weighted, acyclic, trees)
Events (plain, pulse, array of)
HTTP implementation
FIFO (lock-free)
IEEE 754
Multiple connection TCP servers
Mutexes
Objects and handles to
ODBC bindings
Parsers
Persistent objects and handles to
Persistent storage and handles to
Pools
Sets and maps
SQLite bindings
Stacks
Streams
Strings editing
Tables (maps of strings)
Unbounded arrays

Download Simple Components for Ada Platform:   64- 32bit
Fedora packages fedora   precompiled and packaged using RPM     [Download page] [Download page]
Debian packages debian   precompiled and packaged for dpkg   [Download page] [Download page]
Source distribution (any platform)   components_4_3.tgz (tar + gzip, Windows users may use WinZip)   [Download]

See also changes log.


[TOC][Next]

1. Objects and handles (smart pointers)

The objects and handles are designed to provide automatic garbage collection. The objects are created explicitly, but never explicitly destroyed. An application program usually should not directly access objects, using object handles (smart pointers) instead. As long as at least one handle to an object exists the object will not be destroyed. When the last handle disappears the object is automatically destroyed. The presented implementation is oriented on large and rather complex objects. Usually it has little sense to have pointers to small objects, having no identity. For such objects by-value semantics is often safer, easier to understand and more efficient. For this reason an object-oriented approach was chosen. The object type is considered a descendant of a limited controlled type which can be extended as necessary. Same handle type can be used for the whole class of descendant types. The proxy operations can be defined on handles which implementations may dispatch according to the actual type of the pointed object.

A specialization of objects is provided to support object's persistence. Such objects can be stored in an external persistent storage and then restored from there. The persistent storage interface itself is an object. This allows implementation of object serving as proxies of external objects permanently resident in an external storage.

[Back][TOC][Next]

1.1. Objects

The package Object provides the base type Entity for all objects:

type Entity is new
   Ada.Finalization.Limited_Controlled with
record
   Use_Count : Natural := 0;
end record;
type Entity_Ptr is access all Entity'Class;

It is a limited controlled type. The following operations are defined on it:

procedure Decrement_Count (Object : in out Entity);

This procedure decreases object's reference count. It should never be used explicitly, except than in implementations of handles to objects.

function Equal
         (  Left  : Entity;
            Right : Entity'Class;
            Flag  : Boolean := False
         )  return Boolean;
function Less
         (  Left  : Entity;
            Right : Entity'Class;
            Flag  : Boolean := False
         )  return Boolean;

These functions are used to compare objects. The meaning of comparison is usually defined by the nature of the objects. However the main reason why comparison is defined, is to support ordered sets of objects, so any order is suitable. Thus the implementations of Equal and Less use storage addresses to get Entity objects ordered. They should be overridden if a more meaningful order of objects exists. Note that Ada does not fully support multiple dispatch. Therefore the operations are declared asymmetric. The second parameter is class-wide. If the operation is overridden, an implementation should dispatch on the second parameter to emulate true multiple dispatch. The parameter Flag indicates whether the function is called recursively. The following code fragment illustrates how to do it:

function Less
         (  Left  : A_New_Object_Type;
            Right : Object.Entity'Class;
            Flag  : Boolean := False
         )  return Boolean is
begin
   if (  Flag
      or else
         Right not in A_New_Object_Type'Class
      or else
         Right in A_New_Object_Type
      )
   then
      -- Implement it here
      ...
   else
      -- Dispatch on the second parameter
      return
         not (  Less (Right, Left, True)
             or else
                Equal (Right, Left, True)
             );
   end if;
end Less;

The idea is that a given overriding is responsible for implementation of Less if and only if Left :> Right, i.e. when Left is in the class of Right. The dispatching mechanism warranties that Left is in the type class, so if Right is of the same type or else does not belong to the type class, then Left :> Right. Otherwise, Right is used to re-dispatch and Flag is set to indicate that no more dispatch may happen. Observe, that if Left and Right are siblings and therefore neither of Left :> Right and Left <: Right is true, then Flag will stop the recursion.

If the implementation casts Right down to a known type, as it usually would do in other cases, then in the case of siblings, this would cause propagation of Constraint_Error out of Less or Equal. If this behavior is undesirable, another way to deal with comparison of siblings is to find the most specific common ancestor of both. In that case the code of Less might look as follows:

function Less
         (  Left  : A_New_Object_Type;
            Right : Object.Entity'Class;
            Flag  : Boolean := False
         )  return Boolean is
begin
   if (  Right not in A_New_Object_Type'Class
      or else
         Right in A_New_Object_Type
      )
   then
      -- Implement it here
      ...
   elsif Flag then
      -- Using Less of the most specific common ancestor,
      -- for example, the predefined Less:
      
return Object.Less (Object.Entity (Left), Right, True);
   else
      -- Dispatch on the second parameter
      return
         not (  Less (Right, Left, True)
             or else
                Equal (Right, Left, True)
             );
   end if;
end Less;

procedure Finalize (This : in out Entity);

This procedure is called upon object finalization. It raises Program_Error if the destroyed object is still in use. Note that any derived type shall call this procedure from its implementation of Finalize when it overrides Finalize.

procedure Increment_Count (Object : in out Entity);

This procedure increases object's reference count. It should never be used explicitly, except than in implementations of handles to objects.

procedure Initialize (Object : in out Entity);

This procedure is called upon object initialization. Any derived type shall call it from its implementation of.

procedure Release (Ptr : in out Entity_Ptr);

The object pointed by Ptr is deleted if its use count in 1. Otherwise the use count is decremented. Ptr becomes null if the object it points to is deleted. The procedure does nothing if Ptr is already null. It can be used for implementation of the smart pointers to Entity and its descendants.

1.1.1. Tasking

The package provides several implementations of Object:

[Back][TOC][Next]

1.2. Handles to objects

The generic child package Object.Handle defines the type Handle used to access objects of a given type:

generic
   type Object_Type (<>) is abstract new Entity with private;
   type Object_Type_Ptr is access Object_Type'Class;
package Object.Handle is
   type Handle is new Ada.Finalization.Controlled with private;

The package has two generic parameters:

Handles can be assigned to copy a reference to the object. If a handle object is not initialized it is invalid. An invalid handle cannot be used to access objects, but it can be used in some comparisons, it can be copied and assigned. The constant Null_Handle defined in the package is a predefined invalid handle. The following operations are defined on a Handle:

procedure Finalize (Reference : in out Handle);

The destructor destroys the referenced object (if any) in case when the handle was the last one pointing the object.

procedure Invalidate (Reference : in out Handle);

This procedure detaches handle from the object (if any) it points to. The result handle cannot be used to access any object. The referenced object is destroyed if it was the last handle.

function Is_Valid (Reference : Handle) return Boolean;

This function checks whether a handle points to an object.

function Ptr (Reference : Handle) return Object_Type_Ptr;

This function is used to get a pointer to the object the handle points to. The pointer of to the object shall be used no longer the handle it was get from exists. A safe way to do it is to avoid declarations of any variables of the type Object_Type_Ptr.

function Ref (Thing : Object_Type_Ptr) return Handle;

This function is used to get a handle from a pointer to an object.

procedure Set (Reference : in out Handle; Thing : Object_Type_Ptr);

This procedure resets the handle Reference to a possibly another object. In the course of this operation the previously pointed object may be destroyed if Reference was the last handle pointing to it. It is safe when Thing is the object Reference already points to. When Thing is null, this procedure is equivalent to Invalidate.

function "<" (Left, Right : Handle) return Boolean;
function "<="(Left, Right : Handle) return Boolean;
function ">="(Left, Right : Handle) return Boolean;
function ">" (Left, Right : Handle) return Boolean;
function "=" (Left, Right : Handle) return Boolean;
function "="
        (  Left  : Handle;
           Right : access Object_Type'Class
        )  return Boolean;
function "="
        (  Left  : access Object_Type'Class;
           Right : Handle
        )  return Boolean;

Valid handles are comparable. The result of comparison is one of the objects they point to. Implementations of the comparisons use Less and Equal defined on Object_Type. If one of the parameters is invalid Contraint_Error is propagated for all functions except "=". For equality (and thus inequality) it is legal to compare with an invalid handle. The result of such comparison is true if and only if both handles are invalid. One of parameters in equality is allowed to be a pointer to an object.

[Back][TOC][Next]

1.3. An example of use

The usage of objects and handles is illustrated by the following simplified example of an implementation of dynamic strings: 

File test_my_string.ads:
with Object;

package Test_My_String is
   type My_String (Length : Natural) is
      new
Object.Entity with record
         Value : String (1..Length);
   end record;
   type My_String_Ptr is access My_String'Class;
end Test_My_String;

An instance of My_String keeps the string body. But a user should rather use handles to My_String, provided by the child package:

File test_my_string-handle.ads:
with Object.Handle;

package Test_My_String.Handle is
--
-- Though an instantiation of Object.Handle provides handles to
-- My_String, we would like to have some additional operations on
-- handles.
--

   package My_String_Handle is
      new Object.Handle (My_String, My_String_Ptr);
--
-- So we immediately derive from the obtained type. Note that no
-- additional components needed (with null record). 
--

   type My_Safe_String is
      new
My_String_Handle.Handle with null record;
--
-- Now define useful operations on string handles:
--

   function Create (Value : String) return My_Safe_String;
   function Value (Reference : My_Safe_String) return String;
--
--
 Note that Copy takes handle as an inout-parameter. It does not touch
-- the old object it just creates a new one and sets handle to point to
-- it. The old object is automatically destroyed if no more referenced. 
--

   procedure Copy
             (  Reference : in out My_Safe_String;
                New_Value : String
             );
   procedure Copy
             (  Reference : in out My_Safe_String;
                New_Value : My_Safe_String
             );
private
--
-- Note that Ref shall be overridden. This is a language requirement,
-- which ensures that the results are covariant. We make it private
-- because there is no need for a user to access it.
--

   function Ref (Pointer : My_String_Ptr) return My_Safe_String;

end Test_My_String.Handle;

This package defines the type My_Safe_String which can be used with less care about memory allocation and deallocation. A handle can be copied using the standard assignment. A new string object can be created from a string. The value it points to can be accessed using the function Value, etc. It is a good practice to provide Create returning a handle instead of a direct use of Ref on an existing object, because it prevents referring stack-allocated objects which could get out of scope before handles to them. Object.Finalize would notice that and raise Program_Error. An implementation of My_Safe_String might look like follows.

File test_my_string-handle.adb:
package body Test_My_String.Handle is

   function Create (Value : String) return My_Safe_String is
      Ptr : My_String_Ptr := new My_String (Value'Length);
   begin
      Ptr.Value := Value;
      return Ref (Ptr);
   end Create;

   function Value (Reference : My_Safe_String) return String is
   begin
      return Ptr (Reference).Value;
   end Value;

   procedure Copy
             (  Reference : in out My_Safe_String;
                New_Value : String
             )  is
   begin
      Reference := Create (New_Value);
   end Copy;

   procedure Copy
             (  Reference : in out My_Safe_String;
                New_Value : My_Safe_String
             )  is
   begin
      Reference := Create (Value (New_Value));
   end Copy;

   function Ref (Pointer : My_String_Ptr) return My_Safe_String is
   begin
      return (My_String_Handle.Ref (Pointer) with null record);
   end Ref;

end Test_My_String.Handle;

[Back][TOC][Next]

1.4. Bounded arrays of objects

The package Object.Handle.Generic_Bounded_Array defines the type Bounded_Array. An instance of Bounded_Array is a fixed size array of references to objects. It is same as an array of handles to objects but more efficient.

generic
   type Index_Type is (<>);
   type
Handle_Type is new Handle with private;
package
Object.Handle.Generic_Bounded_Array is ...

Here Index_Type is the type used to index the array elements. Handle_Type is any descendant of Handle including itself. The type Bounded_Array is defined in the package as:

type Bounded_Array (First, Last : Index_Type) is
   new
Ada.Finalization.Controlled with private;

The discriminants First and Last define the index range. The following operations are defined on Bounded_Array:

procedure Adjust (Container : in out Bounded_Array);

The assignment makes a copy of the array.

function Append
         (  Container : Bounded_Array;
            Element   : Object_Type_Ptr := null;
            Count     : Natural         := 1
         )  return Bounded_Array;
function Append
         (  Container : Bounded_Array;
            Element   : Handle_Type;
            Count     : Natural := 1
         )  return Bounded_Array;

These functions add Element Count times to the end of Container. The result will have the lower bound Container.First. Constraint_Error is propagated when the upper bound cannot be represented in Index_Type.

function Delete
         (  Container : Bounded_Array;
            From      : Index_Type;
            Count     : Natural := 1
         )  return Bounded_Array;

This function deletes Count elements from Container starting with the element From. When Count exceeds the number of elements in the array, the available elements are removed. The lower bound of the result is Container.First, except the case when all elements are removed. For an empty result, the lower bound is Index_Type'Succ (Index_Type'First). Constraint_Error is propagated when the result should be empty, but Index_Type has less than two values. It is also propagated when From is not in Container.

procedure Finalize (Container : in out Bounded_Array);

The destructor may delete some objects referenced by the array.

procedure Fill
          (  Container : in out Bounded_Array;
             From      : Index_Type;
             To        : Index_Type;
             Element   : Object_Type_Ptr := null
          );
procedure Fill
          (  Container : in out Bounded_Array;
             From      : Index_Type;
             To        : Index_Type;
             Element   : Handle_Type
          );

These procedures are used to put in / replace a range of array elements. The range From..To is filled with Element. Nothing happens if From > To. Otherwise Constraint_Error is propagated when From..To is not in Container.First..Constainer.Last.

function Get
         (  Container : Bounded_Array;
            Index     : Index_Type
         )  return Object_Type_Ptr;

This function returns either a pointer to an object or null.

function Get
         (  Container : Bounded_Array;
            From      : Index_Type;
            To        : Index_Type
         )  return Bounded_Array;

This function returns a slice of Container. The lower index of the slice is From, the upper index is To. Constraint_Error is propagated when From..To is not empty and does not belong to the range First..Last of Container.

function Prepend
         (  Container : Bounded_Array;
            Element   : Object_Type_Ptr := null;
            Count     : Natural         := 1
         )  return Bounded_Array;
function Prepend
         (  Container : Bounded_Array;
            Element   : Handle_Type;
            Count     : Natural := 1
         )  return Bounded_Array;

These functions add Element Count times in front of Container. The result will have the upper bound Container.Last. Constraint_Error is propagated when the upper bound cannot be represented in Index_Type.

procedure Put
          (  Container : in out Bounded_Array;
             Index     : Index_Type;
             Element   : Object_Type_Ptr
          );
procedure Put
          (  Container : in out Bounded_Array;
             Index     : Index_Type;
             Element   : Handle_Type
          );

These procedures are used to put in / replace an array element using its index. Constraint_Error is propagated when Index is illegal.

procedure Put
          (  Container : in out Bounded_Array;
             From      : Index_Type;
             To        : Index_Type;
             Elements  : Bounded_Array
          );

This procedures replaces the slice From..To of Container with Elements. Container and Elements can be the same object. Else if Elements is shorter than the slice, the rightmost elements of the slice are replaced with invalid handles. When Elements is longer, then its rightmost elements are ignored. The operation is void when From..To is empty. Constraint_Error is propagated when From..To is not empty and does not belong to the range First..Last of Container.

function Ref
         (  Container : Bounded_Array;
            Index     : Index_Type
         )  return Handle_Type;
This function returns a valid handle to an object. Otherwise Constraint_Error is propagated.
function "&" (Left, Right : Bounded_Array) return Bounded_Array;

This function returns a concatenation of two arrays. If Right is empty, the result Left, else if Left is empty, the result is Right. Otherwise, the lower bound of the result is Index_Type'First.

Empty : constant Bounded_Array;

Empty array constant.

[Back][TOC][Next]

1.5. Unbounded arrays of objects

The package Object.Handle.Generic_Unbounded_Array defines the type Unbounded_Array. An instance of Unbounded_Array is an unbounded array of references to objects. The package has same functionality as an instance of Generic_Unbounded_Array with Handle as Object_Type, but it is more efficient.

generic
   type Index_Type is (<>);
   type
Handle_Type is new Handle with private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Object.Handle.Generic_Unbounded_Array is ...

Here:

The type is declared as:

type Unbounded_Array is new Ada.Finalization.Controlled with private;

The following operations are defined on Unbounded_Array:

procedure Adjust (Container : in out Unbounded_Array);
The assignment does not make a copy of the array. It just increments an internal use count. The array will be copied only when a destructive operation is applied.

procedure Erase (Container : in out Unbounded_Array);

This procedure removes all elements from Container making it empty. The objects referenced only by Container will be deleted.

procedure Finalize (Container : in out Unbounded_Array);

The destructor may delete some objects referenced by the array.

function First
         (  Container : Unbounded_Array;
         )  return Index_Type;

This function returns the current lower bound of the array. Constraint_Error is propagated when the array is empty.

function Get
         (  Container : Unbounded_Array;
            Index     : Index_Type
         )  return Object_Type_Ptr;

This function returns either a pointer to an object or null.

function Last
         (  Container : Unbounded_Array;
         )  return Index_Type;

This function returns the current upper bound of the array. Constraint_Error is propagated when the array is empty.

procedure Put
          (  Container : in out Unbounded_Array;
             Index     : Index_Type;
             Element   : Object_Type_Ptr
          );
procedure Put
          (  Container : in out Unbounded_Array;
             Index     : Index_Type;
             Element   : Handle_Type
          );

These procedures are used to put in / replace an array element using its index. The array is automatically expanded as necessary. It never happens if Element is null or an invalid handle.

function Ref
         (  Container : Unbounded_Array;
            Index     : Index_Type
         )  return Handle_Type;
This function returns a valid handle to an object. Otherwise Constraint_Error is propagated.

[Back][TOC][Next]

1.6. Unbounded sets of objects

The package Object.Handle.Generic_Set defines the type Set. An instance of Generic_Set is a set of references to objects. The package has same functionality as an instance of Generic_Set with Handle as Object_Type, but it is more efficient. It has the following generic parameters:

generic
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Object.Handle.Generic_Set is ...

Here:

The type Set is declared as:

type Set is new Ada.Finalization.Controlled with private;

The following operations are defined on Set:

procedure Add (Container : in out Set; Item  : Handle);
procedure
Add (Container : in out Set; Item  : Object_Type_Ptr);
procedure
Add (Container : in out Set; Items : Set);

These procedures are used to add an object to a set or all items of one set to another. The parameter Item can be either a handle or a pointer to the object. Nothing happens if an item is already in the set or pointer is an invalid handle or null.

procedure Adjust (Container : in out Set);

The assignment does not make a copy of the Container. It just increments an internal use count of the set body. A set will be physicaly copied only when a destructive operation is applied to it.

function Create return Set;

This function returns an empty set.

procedure Erase (Container : in out Set);

This procedure removes all objects from the set. The objects referenced only by Container will be deleted.

procedure Finalize (Container : in out Set);

The destructor may delete some objects referenced by Container.

function Find (Container : Set; Item : Handle)
   return Integer;
function
Find (Container : Set; Item : Object_Type'Class)
   return Integer;
function Find (Container : Set; Item : Object_Type_Ptr)
   return Integer;

This function is used to Item in the set Container. The result is either a positive index of the found item or a negated index of the place where the item should be if it were in the set.

function Get (Container : Set; Index : Positive)
   return Object_Type_Ptr;

This function is used to get an item of the set Container using a positive index. The result is a pointer to the object. It is valid as long as the object is in the set. See also Ref which represents a safer way of accessing the set items. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Set) return Natural;

This function returns the number of items in the set.

function Is_Empty (Container : Set) return Boolean;

True is returned if Container is empty.

function Is_In (Container : Set; Item : Handle)
   return Boolean;
function
Is_In (Container : Set; Item : Object_Type'Class)
   return Boolean;
function Is_In (Container : Set; Item : Object_Type_Ptr)
   return Boolean;

True is returned if Item is in Container. Item can be either a pointer to the object, a handle to it or the object itself. The result is always false when Item is invalid or null.

function Ref (Container : Set; Index : Positive) return Handle;

This function is used to get an item of the set Container using a positive index. The result is a handle to the object. Constraint_Error is propagated if Index is wrong.

procedure Remove (Container : in out Set; Index : Positive);
procedure Remove (Container : in out Set; Item  : Handle);
procedure
Remove (Container : in out Set; Item  : Object_Type'Class);
procedure Remove (Container : in out Set; Item  : Object_Type_Ptr);
procedure Remove (Container : in out Set; Items : Set);

These procedures are used to remove items from the set Container. An item can be removed either by its index, or explicitly by a pointer, object or handle to it, or else by specifying a set of items to be removed. If a particular item is not in the set, then nothing happens. Also nothing happens if a handle is illegal or pointer is null. Constraint_Error is propagated when item index is wrong.

function "and" (Left, Right : Set) return Set;
function "or"  (Left, Right : Set) return Set;
function "xor" (Left, Right : Set) return Set;

These functions are conventional set operations - intersection, union, difference. Difference is defined as a set which items are only in one of the sets Left and Right.

function "=" (Left, Right : Set) return Boolean;

True is returned if both sets contain same items.

[Back][TOC][Next]

1.7. Universal sets of objects

The packages Object.Handle.Generic_Handle_Set resembles Object.Handle.Generic_Set, but it is more universal. It allows to specify a user-defined types both for the object handles and for the weak references to objects (usually pointers). It has the following generic parameters:

generic
   type
Handle_Type is new Handle with private;
   type
Object_Ptr_Type is private;
  
Null_Object_Ptr : Object_Ptr_Type;
   with function
Ptr (Object : Handle_Type) return Object_Ptr_Type is <>;
   with function Ref (Object : Object_Ptr_Type) return Handle_Type is <>;
   with function To_Object_Ptr (Object : Object_Ptr_Type) return Object_Type_Ptr is <>;
   with function
"<" (Left, Right : Object_Ptr_Type) return Boolean is <>;
   with function
"=" (Left, Right : Object_Ptr_Type) return Boolean is <>;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Object.Handle.Generic_Handle_Set is ...

Here:

In other aspects both packages are identical. The interface subprograms described below are similar in both. The Handle should be read Handle_Type when Object.Handle.Generic_Handle_Set is considered.

The type Set is declared as:

type Set is new Ada.Finalization.Controlled with private;

The following operations are defined on Set:

procedure Add (Container : in out Set; Item  : Handle_Type);
procedure
Add (Container : in out Set; Item  : Object_Ptr_Type);
procedure
Add (Container : in out Set; Items : Set);

These procedures are used to add an object to a set or all items of one set to another. The parameter Item can be either a handle or a pointer to the object. Nothing happens if an item is already in the set or pointer is an invalid handle or null.

procedure Adjust (Container : in out Set);

The assignment does not make a copy of the Container. It just increments an internal use count of the set body. A set will be physicaly copied only when a destructive operation is applied to it.

function Create return Set;

This function returns an empty set.

procedure Erase (Container : in out Set);

This procedure removes all objects from the set. The objects referenced only by Container will be deleted.

procedure Finalize (Container : in out Set);

The destructor may delete some objects referenced by Container.

function Find (Container : Set; Item : Handle_Type)
   return Integer;
function Find (Container : Set; Item : Object_Ptr_Type)
   return Integer;

This function is used to Item in the set Container. The result is either a positive index of the found item or a negated index of the place where the item should be if it were in the set.

function Get (Container : Set; Index : Positive)
   return Object_Ptr_Type;

This function is used to get an item of the set Container using a positive index. The result is a pointer to the object. It is valid as long as the object is in the set. See also Ref which represents a safer way of accessing the set items. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Set) return Natural;

This function returns the number of items in the set.

function Is_Empty (Container : Set) return Boolean;

True is returned if Container is empty.

function Is_In (Container : Set; Item : Handle_Type)
   return Boolean;
function Is_In (Container : Set; Item : Object_Ptr_Type)
   return Boolean;

True is returned if Item is in Container. Item can be either a pointer to an object or a handle to it. The result is always false when Item is invalid or null.

function Ref (Container : Set; Index : Positive) return Handle_Type;

This function is used to get an item of the set Container using a positive index. The result is a handle to the object. Constraint_Error is propagated if Index is wrong.

procedure Remove (Container : in out Set; Index : Positive);
procedure Remove (Container : in out Set; Item  : Handle_Type);
procedure
Remove (Container : in out Set; Item  : Object_Ptr_Type);
procedure Remove (Container : in out Set; Items : Set);

These procedures are used to remove items from the set Container. An item can be removed either by its index, or explicitly by a pointer or handle to it, or else by specifying a set of items to be removed. If a particular item is not in the set, then nothing happens. Also nothing happens if a handle is illegal or pointer is null. Constraint_Error is propagated when item index is wrong.

function "and" (Left, Right : Set) return Set;
function "or"  (Left, Right : Set) return Set;
function "xor" (Left, Right : Set) return Set;

These functions are conventional set operations - intersection, union, difference. Difference is defined as a set which items are only in one of the sets Left and Right.

function "=" (Left, Right : Set) return Boolean;

The function returns true is returned if both sets contain same items.


[Back][TOC][Next]

2. Persistency

[Back][TOC][Next]

2.1. Persistent objects

A persistent object is one stored in an external storage, independent on the application, that originally created it. A persistent object can be restored from the external storage in a fully functional state in the same or other application. The provided implementation of persistent objects was designed with the following goals in mind:

Like other objects, persistent ones are normally accessed through handles.

2.1.1. Types

The package Object.Archived defines the type Deposit serving as the abstract base type for all persistent objects:

type Deposit is abstract new Entity with private;
type Deposit_Ptr is access Deposit'Class;

A type derived from Deposit should:

Objects may depend on other objects, but these dependencies may not be circular. Store and Restore provide forth and back string conversions. String was chosen instead of Stream_Element_Array to make it portable across different systems.

Storing an object:

  1. Get_Referents is called. Each object it refers is archived first. The order of the objects in the list is important and has to be preserved;
  2. Get_Class is called and its result is archived;
  3. Store is called and its result is finally archived.

Restoring an object:

  1. A list of objects the archived object depends on is built, the objects are restored as necessary;
  2. The object's class string is obtained;
  3. Restore is finally called with these parameters. The class is used to select an appropriate Restore. This is equivalent to dispatching according to the class. The list of available classes and their Restore procedures is formed by calls to Register.

The type Backward_Link is used when it is necessary to monitor deletion of an object.

type Backward_Link is abstract new Entity with private;
type Backward_Link_Ptr is access Backward_Link'Class;

Reference counting is used to prevent deletion of a Deposit object, when it is in use. Such objects are referenced through handles. These are direct links to the object, also known as strong references. But sometimes it is necessary to break the dependency of one object from another to delete the latter. For this the former object may get a notification about a desire to delete a referent. Upon this notification it can invalidate the handle to the referent and so allow the collector to delete it. A notification object is derived from Backward_Link, which represent a backward link from a referred object to a dependent one. Each Deposit object maintains a list of its backward links, also called weak references. Typically an external storage connection object tracks all persistent objects which are in the memory at the moment. Usually it has an index of such memory resident objects. A record of this index has a handle to a specialized descendant of Backward_Link. So when an object is no more in use and so the last handle to it disappears, the object is automatically destroyed. In the course of this operation the storage connection object becomes a notification via call to Destroyed. At this point the object being destroyed can be stored and then removed from the external storage index of memory resident objects.

type Deposit_Container is abstract
   new
Ada.Finalization.Controlled with private;

The type Deposit_Container is an abstract specialized container for Deposit objects. The container operates as a container of handles. That is when an object is put into it, then the object will not be deleted until it is in. Physically a reference to the object is placed into the container. Deposit_Container objects are used upon object storing and restoring to keep the list of things the object depends on. Deposit_Container is not limited so it can be copied when necessary. The child packages Object.Archived.Sets and Object.Archived.Lists provide unordered (set) and ordered (list) implementations of Deposit_Container.

2.1.2. Operations on objects

procedure Close (Object : in out Deposit'Class);

This class-wide procedure is called before finalization of a persistent object. It cleans the list of backward links. So it plays the role of a class-wide destructor. Finalize should always call it. For example, if the derived type is a descendant of Deposit overriding Finalize, then the implementation should look like:

procedure Finalize (Object : in out Derived) is
begin
  
Close (Object);
   ... -- finalization of Derived
   Finalize (Deposit (Object));
end Finalize;

It is safe to call it multiple times, though it is essential to call it before any vital object data get finalized. So Finalization of a type derived from Derived may call Close as well. Note that in Ada Finalize is called prior finalization of any object's components. So it is safe to use them. However, keep in mind that task components (if any) are though not yet finalized, but completed before Finalize, thus neither Store nor Get_Referents may communicate with task components of the object.

procedure Create
          (  Source  : String;
             Pointer : in out Integer;
             Class   : String;
             List    : Deposit_Container'Class;
             Object  : out Deposit_Ptr
          );

This procedure calls Restore for Class simulating a dispatching call. Name_Error is propagated if Class is not a registered object class. The string Source contains object description to be restored starting from the character Source (Pointer). Pointer  is advanced to the first object following from the used ones. The parameter Object accepts a pointer to the newly created object.

Exceptions
Data_Error Syntax error
End_Error Nothing matched
Layout_Error The value of Pointer is not in the range Source'First..Source'Last+1 
Name_Error Class is not a registered class
Use_Error Insufficient dependencies list

procedure Delete (Object : in out Deposit'Class);

This procedure is used when Object is being deleted. On each item in the Object's obituary notices delivery list, Delete is called. This has the effect that some references to Object may disappear and so the object will be collected. Note that a call to Delete does not guaranty Object's deletion, because some references to it, may still be present. It is safe to add new backward links to the Object's notification list from Delete, because the items are appended at the end of the delivery list. This also means that they will receive a Deleted callback in the course of the same notification. It is also safe to remove backward links from the list. Though Object's deletion is not guaranteed it might happen. So to prevent undefined behavior a caller should hold a handle to Object when it calls to Delete.

procedure Finalize (Object : in out Deposit);

Upon finalization backward links list is cleaned. All interested parties receive a notification via call to Destroyed. A derived type implementation have to call Finalize as well as Close.

procedure Free (Object : in out Deposit_Ptr);

This procedure is used to delete manually created objects. It is never called for existing objects, only for improperly constructed ones from an implementation of Restore.

function Get_Class (Object : Deposit) return String is abstract;

This function returns the class of Object. The class is a string uniquely describing the object's type. It is analogous to external type tag representation. Though, different types of objects may share same class if necessary.

procedure Get_Referents
          (  Object    : Deposit;
             Container : in out Deposit_Container'Class
          );

This procedure adds objects referenced from Object to Container objects. Only immediately viewed objects are stored there. No deep search has to be made to detect all objects. Objects shall not depend recursively. The default implementation does nothing, which behavior corresponds to an independent object. An implementation may raise Use_Error on a wrong object. See also notes about Close.

function Is_Modified (Object : Deposit)
   return
Boolean is abstract;

This function is used to check if Object's state was changed. Persistent objects serving as proxies to a persistent storage will require synchronization if this function returns true. An implementation of a mutable object would normally have a Boolean flag to be set by any destructive operation or new object creation.

procedure Reset_Modified (Object : in out Deposit) is abstract;

This procedure is used to reset Object's state modification flag. It is called immediately after synchronization the object with the persistent storage.

type Restore is access procedure
   
 (  Source  : String;
        Pointer : in out Integer;
        Class   : String;
        List    : Deposit_Container'Class;
        Object  : out Deposit_Ptr
     );

This procedure creates a new object from its string representation. It parses Source starting from Source (Pointer). Pointer is then advanced to the first character following the object's description in the string. The procedure has to be dispatching depending on the object's class, which is impossible in Ada. For this reason it is defined as an access to procedure type. Each object class has to define such a function and register it (see Register_Class). The parameter Class contains the actual object class according to which dispatch to an implementation of Restore was made. The parameter List contains the references to the objects the restored object depends on. The order of the objects in the list is same as one returned in Get_Referents. The result is a newly allocated object pointed by the Object parameter. An implementation may raise the following exceptions to indicate errors:

Exceptions
Data_Error Syntax error
End_Error Nothing matched
Layout_Error The value of Pointer is not in the range Source'First..Source'Last+1 
Use_Error Insufficient dependencies list

procedure Store
          (  Destination : in out String;
             Pointer     : in out Integer;
             Object      : Deposit
          )  is abstract;

An implementation places string describing Object is into Destination starting from the position specified by Pointer. Pointer is then advanced to the next position following the output. Layout_Error is propagated when Pointer not in Source'First..Source'Last + 1 or there is no room for output. Use_Error can be raised when Object is wrong. See also notes about Close.

2.1.3. Operations on backward links to objects

procedure Attach
          (  Link   : Backward_Link_Ptr;
             Object : Deposit_Ptr
          );

This procedure places Link at the end of Object's delivery list. If it is already in another list then it is removed from there first. Nothing happens if Object is null.

procedure Deleted
          (  Link  : in out Backward_Link;
             Temps : in out Deposit_Container'Class
          )  is abstract;

This procedure is used when an object is requested to be deleted. Normally Deleted is called as a result of object deletion request via call to Delete. The parameter Temps is the list of temporal objects the implementation might create. For example, some objects might be created to be notified within the course of the operation performed by the caller. Note that the caller should hold a handle to Link, to allow the callee to undertake actions which would otherwise lead to Link deletion. Note also that object's finalization does not cause a call to Delete it calls Destroyed instead.

procedure Destroyed (Link : in out Backward_Link) is abstract;

This procedure is used when an object is finally destroyed, but is still fully operable. Thus an implementation of Destroyed may safely access the object referred by Link. It may for example synchronize the object with the external storage or remove the object from the index cache etc. The caller should hold a handle to Link.

procedure Detach (Link : in out Backward_Link);

This procedure removes Link from object's delivery list, if any.

procedure Finalize (Link : in out Backward_Link);

This procedure should be called by a derived type if overridden. Link is removed for object's delivery list if any.

function Self (Link : Backward_Link) return Backward_Link_Ptr;

This function returns a pointer to the link object (to Link itself). Constraint_Error is propagated when Link is not bound to any object.

function This (Link : Backward_Link) return Deposit_Ptr;

This function returns a pointer to the target of Link. Constraint_Error is propagated when Link is not bound to any object.

The package Backward_Link_Handles provides handles to Backward_Link objects.

The child package Backward_Link_Handles.Sets provides sets of handles to Backward_Link object.

2.1.4. Operations on containers

procedure Add
          (  Container : in out Deposit_Container;
             Object    : Deposit_Ptr;
             Backward  : Boolean := False
          )  is abstract;

This procedure puts a reference to Object into Container. The implementation should ensure that Object will not be destroyed until it is in. The parameter Backward, when true indicates a backward link. Backward links are used when the dependent object associated with the container can survive deletion of Object. It is an optional parameter which may be ignored by some implementations. When it is supported, then marking an Object as a backward link should override the effect of any placing the same object as a direct link (with Backward = false). Nothing happens if Object is null.

procedure Erase (Container : in out Deposit_Container) is abstract;

This procedure removes all objects from Container.

function Get
         (  Container : Deposit_Container;
            Index     : Positive
         )  return Deposit_Ptr is abstract;

This function is used to enumerate the objects in a container Objects indices start with 1. Contraint_Error is propagated when Index is wrong.

function Get_Size (Container : Deposit_Container)
   return
Natural is abstract;

This function returns the number of objects in Container, i.e. the largest possible index allowed in Get. 0 is returned when the container is empty. Note that the objects in a container need not to be all different. This depends on the container implementation.

function Is_Backward
         (  Container : Deposit_Container;
            Object    : Deposit_Ptr
         )  return Boolean is abstract;

The result of this function is true if a backward link is used for Object in Container. Constraint_Error is propagated when Object is not in Container. Use_Error is propagated when the container implementation does not distinguish direct and backward links.

function Is_Empty (Container : Deposit_Container'Class)
   return
Boolean;

This function returns true if Container is empty. It is class-wide.

function Is_In
         (  Container : Deposit_Container;
            Object    : Deposit_Ptr
         )  return Boolean is abstract;

This function returns true if Object is in Container. Note that null cannot be in any container.

2.1.5. Registering classes of objects

function Is_Registered (Class : String) return Boolean;

This function returns true if there is a class of objects registered under the name Class.

procedure Register_Class
          (  Class       : String;
             Constructor : Restore
          );

This procedure is used to register each new class of objects. It is analogous to creating a dispatching table. It is necessary to register a class to make Restore functions working. Nothing happens if the class is already registered and has same constructor. Name_Error is propagated when class is registered with a different constructor.

2.1.6. Sets of persistent objects

The package Object.Archived.Sets provides an implementation of Deposit_Container. The type Deposit_Set is derived there:

type Deposit_Set is new Deposit_Container with private;

Sets do not distinguish multiple insertion of an object. they also ignore the Backward parameter of Add. So Is_Backward will raise Use_Error. Additionally to the predefined operations, Deposit_Set provides standard set-operations:

procedure Remove
          (  Container : in out Deposit_Set;
             Object    : Deposit_Ptr
          );

This procedure removes Object from Container. Nothing happens if it is null or not in.

function "and" (Left, Right : Deposit_Set) return Deposit_Set;
function "or"  (Left, Right : Deposit_Set) return Deposit_Set;
function "xor" (Left, Right : Deposit_Set) return Deposit_Set;

These functions are conventional set operations - intersection, union, difference. Difference is defined as a set which items are only in one of the sets Left and Right.

function "=" (Left, Right : Deposit_Set) return Boolean;

true is returned if both sets contain same items.

2.1.7. Lists of persistent objects

The package Object.Archived.Lists provides an implementation of Deposit_Container. The type Deposit_List is derived there as:

type Deposit_List is new Deposit_Container with private;

All objects in the list are enumerated from 1. The same object can occupy several places in the list. In the external storage Deposit_List can be stored as a set of objects, where objects do not repeat, followed by a list of values identifying the objects in the set. Additionally to the predefined operations, Deposit_List provides:

function Get_Total (Container : Deposit_List) return Natural;

This function returns the number of distinct objects in Container. This value is less or equal to the one returned by Get_Size.

function Is_First
         (  Container : Deposit_List;
            Index     : Positive
         )  return Boolean;

This function returns true if Index is the least index of the object it specifies. I.e. the least index of the object returned by Get (Container, Index). Constraint_Error is propagated if Index is wrong.

2.1.8. Referent objects enumeration

The package Object.Archived.Iterators provides an abstract iterator of references:

type References_Iterator
     (  Referents : access Deposit_Container'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

The type References_Iterator can be used directly or be extended. It provides the following operations:

procedure Enumerate
          (  Iterator : in out References_Iterator'Class;
             Object   : Deposit'Class
          );

This class-wide procedure is called to enumerate references of Object. This same procedure is used for both starting the process and continuing it for each found reference. Enumerate calls Get_Referents for Object and places all found objects which Object depends on into Iterator.Referents.all. A found object is placed only once which is detected by looking into Iterator.Referents.all. The object itself is not put there. After completion the caller may inspect Iterator.Referents.all for any found objects.

procedure On_Each
          (  Iterator : in out References_Iterator;
             Referent : Deposit_Ptr
          );

This procedure can be overridden. It is called by Enumerate each time a new object is found. It may raise an exception to stop the iteration process. This exception will then propagate out of Enumerate.

[Back][TOC][Next]

2.2. Handles to persistent objects

Persistent objects are subject of garbage collection. The recommended way to access them is through handles, which prevents premature destruction of objects in use. Handles can be aggregated into other objects to express object dependencies. Note that circular dependencies shall be avoided. The best way to do it is to design object in a way that would exclude any possibility of circular dependencies. If that is not possible, then Is_Dependent should be used to check dependencies at run time. The generic package Object.Archived.Handle defines the type Handle used to reference persistent object. It is derived from Handle obtained by an instantiation of Object.Handle:

generic
   type
Object_Type is abstract new Deposit with private;
   type
Object_Ptr_Type is access Object_Type'Class;
package
Handles is new Object.Handle (Deposit, Deposit_Ptr);
   type
Handle is new Handles.Handle with null record;

The formal parameters of the package are:

There is a ready-to use instantiation of Object.Archived.Handle with Deposit and Deposit_Ptr as the actual parameters: Deposit_Handles.

The package Object.Archived.Handle defines the following operations on Handle:

procedure Add
          (  Container : in out Deposit_Container;
             Object    : Handle;
             Backward  : Boolean := False
          )  is abstract;

This procedure puts Object into Container. The parameter Backward, when true indicates a backward link. Backward links are used when the dependent object associated with the container can survive deletion of Object. Constraint_Error is propagated when Object is an invalid handle.

procedure Delete (Object : in out Handle);

This procedure requests deletion of the object pointed by the handle Object. As the result of the operation Object becomes an invalid handle. The object itself is deleted if possible. Nothing happens if Object is not a valid handle.

function Get_Class (Object : Handle) return String;

This function returns the class of Object. The class is a string uniquely describing the object's type. It is analogous to an external type tag representation. Though, different types of objects may have same class if necessary.

procedure Get_References
          (  Object    : Handle;
             Container : in out Deposit_Container'Class
          );

This procedure adds to Container references to all objects the object specified by the handle Object depends on. No objects added if Object is an invalid handle.

procedure Invalidate (Object : in out Handle);

This procedure detaches handle from the object (if any) it points to. The result handle cannot be used to access any object. The referenced object is destroyed if it was the last handle.

function Is_Backward
         (  Container : Deposit_Container'Class;
            Object    : Handle
         )  return Boolean;

This function returns true if a backward link used for Object in Container. Contstraint_Error is propagated when Object is not in Container or invalid handle. Use_Error does when Container does not distinguish direct and backward links.

function Is_Dependent
         (  Dependant : Handle;
            Referent  : Handle
         )  return Boolean;
function
Is_Dependent
         (  Dependant : Handle;
            Referents : Deposit_Container'Class
         )  return Boolean;

These functions check whether Dependant refers to Referent or, when the second parameter is a container, then whether Dependant refers to any of the objects from that container. The result is false if Dependant, Referent is invalid or Referents is empty.

function Is_In
         (  Container : Deposit_Container'Class;
            Object    : Handle
         )  return Boolean;

This function returns true if Object is in Container. When Object is an invalid handle, the result false.

function Is_Valid (Object : Handle) return Boolean;

This function checks whether a handle points to any object, i.e. is valid.

function Ptr (Object : Handle) return Deposit_Ptr;

This function is used to get a pointer to the object the handle Object points to. The pointer of to the object shall be used no longer the handle it was get from exists. A safe way to do it is to avoid declarations of any variables of the type Deposit_Ptr.

function Ref (Thing : Object_Type_Ptr) return Handle;

This function is used to get a handle from a pointer to an persistent object.

function Ref
         (  Container : Deposit_Container'Class;
            Index     : Positive
         )  return Handle;

This function can be used to enumerate the objects in a container. Objects are enumerated from 1. The result is a valid handle to an object in Container. Contraint_Error is propagated when Index is wrong. Note that objects may repeat in containers of some types.

function References (Object : Handle) return Deposit_Set;

This function is used to query all objects its argument depends on. The result is a set of objects. It is empty if Object is an invalid handle.

procedure Set (Object : in out Handle; Thing : Object_Type_Ptr);

This procedure resets the handle Object to a possibly another object. In the course of this operation the previously pointed object may be destroyed if Object was the last handle pointing to it. It is safe when Thing is the object already pointed by the handle. When Thing is null, this procedure is equivalent to Invalidate.

The package Deposit_Handles provides an instantiation of Object.Archived.Handle:

package Deposit_Handles is
   new
Object.Archived.Handle (Deposit, Deposit_Ptr);

[Back][TOC][Next]

2.3. Persistent directories

There is no need to have dedicated objects to serve as persistent directories as any object could become a directory. Nevertheless the package Persistent.Directory provides objects which can be used as directories. They have no any functionality except an ability to persist. The package declares:

procedure Create
          (  Storage   : in out Storage_Handle;
             Directory : out Deposit_Handle;
             Name      : String;
             Parent    : Deposit_Handle := Root_Directory
          );

This procedure creates a new directory with the name Name and Parent as the parent directory. The result is a handle Directory to the object. The parameter Storage is a handle Storage_Handle to the persistent storage object where the directory has to be created.

Exceptions
Constraint_Error Invalid handle Storage, Parent is not persistent in Storage
Data_Error Inconsistent Storage
Name_Error Illegal name (such as empty), name conflict

function Is_Directory (Object : Deposit_Handle) return Boolean;

This function returns true if Object is a valid handle to a directory object.

Directory_Class : constant String := "Directory";

Is the class name of the directory objects.

[Back][TOC][Next]

2.4. Persistent storage implementation example

This paragraph describes a simplified example of persistent storage. It provides an implementation of a persistent storage based on direct access file. As an example of persistent objects serve nodes of binary trees.

2.4.1. Persistent storage implementation

The implementation uses a direct access file to store objects. Each object is stored in one file record. The record number serves as the object key. Observe that the implementation is independent from any implementation of concrete persistent object types (derived from Deposit). This example serves illustrative purpose. For abstract persistent storage interface see Persistent, Persistent.Handle. For persistent storage implementations see Persistent.Handle.Factory.

File test_persistent_file_storage.ads:
with Ada.Direct_IO;
with Ada.Finalization;
with Generic_Map;
with Object.Handle;

with Object.Archived;  use Object.Archived;
with Deposit_Handles;  use Deposit_Handles;

package Test_Persistent_File_Storage is
   --
   -- File_Storage -- Direct I/O based storage for persistent objects
   --

   type File_Storage is
      new
Ada.Finalization.Limited_Controlled with private;
   --
   -- Key -- To reference stored objects = record number 1..
   --
   type Key is new Integer;
   subtype Deposit_Handle is Deposit_Handles.Handle;

   procedure Initialize (Storage : in out File_Storage);
   procedure Finalize (Storage : in out File_Storage);
   procedure Clean_Up;
   function Store
            (  Storage : access File_Storage;
               Object : Deposit_Handle
            )  return Key;
   function Restore
            (  Storage : access File_Storage;
               ID      : Key
            )  return Deposit_Handle;

Here we declare the type File_Storage as a limited controlled type. The procedures Initialize / Finalize are overridden to provide construction / destruction. Upon construction the file is opened. Upon destruction it is closed. The procedure Clean_Up is provided to delete the file. The function Store will be used to store an object. It returns the object key, which identifies the object there. The key has the type Key also declared in this package. It is the number of the record reserved for the object in the file. When the object is already persistent in the file, its key is returned, so it is safe to call Store multiple times. The function Restore is the operation opposite to Store. It takes the object key and returns a handle to the object. Restore is also safe to call multiple times. So when the object referenced by a key, is already memory resident, a handle to it is returned instead of creating a new memory resident copy. The type Handle from the package Deposit_Handles is used to reference persistent objects. Deposit_Handles.Handle is "renamed" to Deposit_Handle for convenience. The objects themselves are never referenced directly but through handles only.

File test_persistent_file_storage.ads (continued, the private part):
private
   --
   -- Index_Record -- One per bound object
   --
  
type Index_Record (Storage : access File_Storage) is
      new
Backward_Link with
   record

     ID : Key; -- Object identifier
   end record;
   type Index_Record_Ptr is access all Index_Record'Class;
   --
   -- Implementation of Backward_Link's operation
   --
  
procedure Deleted
             (  Link  : in out Index_Record;
                Temps : in out Deposit_Container'Class
             );
   procedure Destroyed (Link : in out Index_Record);

A File_Storage object encapsulates the file and an index of all memory resident objects from that file. The index consists of Index_Records. One record is allocated per memory resident object. Index_Record is derived from Backward_Link to monitor what happens with the object. It also contains the object's key in the file. Two operations of Backward_Link need to be implemented: Deleted and Destroyed. The implementation of Deleted is called upon a request of object deletion. It does nothing in our case. Destroyed is called when the object is about to be finalized. In our case we store that object into the file. A more advanced implementation would check if the object was modified. It could also check if the object was requested for deletion and is no more referenced from other objects, in which case it can be removed from the persistent storage as well. But that would be too complex for a small illustrative example.

File test_persistent_file_storage.ads (continued, the private part):
   --
   -- Record_Handles -- Handles to index records
   --
   package Record_Handles is
      new
Object.Handle (Index_Record, Index_Record_Ptr);
   use Record_Handles;
   subtype Record_Handle is Record_Handles.Handle;
   --
   -- Map : object pointer -> record handle
   --
   function "<" (Left, Right : Deposit_Ptr) return Boolean;
   package Object_Maps is
      new
Generic_Map
          (  Key_Type    => Deposit_Ptr,
             Object_Type => Record_Handle
          );
   use Object_Maps;
   subtype Object_Map is Object_Maps.Map;
   --
   -- Map : object key -> record handle
   --
   package Key_Maps is
      new
Generic_Map
          (  Key_Type    => Key,
             Object_Type => Record_Handle
          );
   use Key_Maps;
   subtype Key_Map is Key_Maps.Map;

To reference Index_Record we will use handles provided by Record_Handles, an instantiation of Object.Handle. A handle to Index_Record is "renamed" to Record_Handle. Then we declare two maps: one to map objects to index records, another to map keys to the records. For this the package Generic_Map is instantiated once as Object_Maps and once as Key_Maps. Both use Record_Handle to reference Index_Record. So when the index record is deleted it is enough to remove it from the both maps and the object Index_Record will be automatically collected. Note also that Object_Map uses Deposit_Ptr, a pointer to the persistent object rather than a handle to it. It is important to allow object deletion. Otherwise an object would be never deleted as long as Index_Record referring it exists, i.e. up to File_Storage finalization. It would a thinkable, but too crude implementation. Generic_Map requires map keys be comparable, so the implementation declares "<" on Deposit_Ptr.

File test_persistent_file_storage.ads (continued, the private part):
   --
   -- File record
   --
   type Reference_List is array (Integer range 1..256of Key;
   type File_Record is record
      Length     : Natural := 0;
      Count      : Natural := 0;
      References : Reference_List;
      Descriptor : String (1..1024);
   end record;
   package Record_Files is new Ada.Direct_IO (File_Record);
   use Record_Files;
   --
   -- File_Storage -- Implementation
   --
   type File_Storage is
      new
Ada.Finalization.Limited_Controlled with
   record

      File             : File_Type;
      Object_To_Record : Object_Map;
      Key_To_Record    : Key_Map;
      Last_ID          : Key := 0; -- Last used object key
   end record;

end Test_Persistent_File_Storage;

The type File_Record describes one record in the file. The field References is the list of the keys of all the objects referred by the object. Count is the length of the list. The field Descriptor is a string describing the object. The length of the string is the field Length.

File test_persistent_file_storage.adb:
with Object.Archived.Lists;  use Object.Archived.Lists;
with Strings_Edit;           use Strings_Edit;

package body Test_Persistent_File_Storage is

   function "<" (Left, Right : Deposit_Ptr) return Boolean is
   begin
      if
Right = null then
         return
False;
      elsif Left = null then
         return
True;
      else
         return
Less (Left.all, Right.all);
      end if;
   end "<";

   procedure Clean_Up is
      File : File_Type;
   begin
      Create (File, Out_File, "test.dat");
      Close (File);
   end Clean_Up;

The implementation of "<" uses Less defined on objects to order them. Clean_Up opens the file in Out_File mode and immediately closes it. This erases the file.

File test_persistent_file_storage.adb (continued):
   procedure Write
             (  Storage : in out File_Storage;
                Object  : Deposit'Class;
                ID      : Key
             )  is
      References  : Deposit_List;
      Data_Record : File_Record;
      Pointer     : Integer := Data_Record.Descriptor'First;
   begin
      Get_Referents (Object, References);
      Data_Record.Count := Get_Size (References);
      for Item in 1..Data_Record.Count loop
         Data_Record.References (Item) :=
            Store (Storage'Access, Ref (References, Item));
      end loop;
      Put (Data_Record.Descriptor, Pointer, Get_Class (Object));
      Put (Data_Record.Descriptor, Pointer, ":");
      Store (Data_Record.Descriptor, Pointer, Object);
      Data_Record.Length := Pointer;
      Write (Storage.File, Data_Record, Count (ID));
   end Write;

The procedure Write is defined to store an object under the specified key. It calls to Get_Referents to obtain the list of the objects the stored object needs. Then for each such object it calls Store to ensure the object persistency in the file. The keys returned by Store are placed into the References array. After that Write starts to form the field Description. It places the object class there (Get_Class) followed by a colon. Then object's Store is called to query the object description and to add it to Description. The completed object record is then written into the file.

File test_persistent_file_storage.adb (continued):
   procedure Initialize (Storage : in out File_Storage) is
   begin

      Open (Storage.File, Inout_File, "test.dat");
      Storage.Last_ID := Key (Size (Storage.File));
   end Initialize;

   procedure Finalize (Storage : in out File_Storage) is
   begin
      while not
Is_Empty (Storage.Key_To_Record) loop
         declare

            Index_Item : Index_Record renames
            Ptr (Get (Storage.Key_To_Record, Integer'(1))).all;
         begin
            Write (Storage, This (Index_Item).all, Index_Item.ID);
         end;
         Remove (Storage.Key_To_Record, Integer'(1));
         Remove (Storage.Object_To_Record, 1);
      end loop;
      Close (Storage.File);
   end Finalize;

   procedure Bind
             (  Storage : access File_Storage;
                Object  : Deposit_Handle;
                ID      : Key
             )  is
      Link_Ptr   : Backward_Link_Ptr := new Index_Record (Storage);
      Index_Item : Index_Record renames Index_Record (Link_Ptr.all);
   begin
      Index_Item.ID := ID;
      Attach (Link_Ptr, Ptr (Object));
      Add
      (  Storage.Object_To_Record,
         Ptr (Object),
         Ref (Index_Item'Unchecked_Access)
      );
      Add
      (  Storage.Key_To_Record,
         ID,
         Ref (Index_Item'Unchecked_Access)
      );
   end Bind;

The implementation of Initialize just opens the file for input / output and initializes the field Last_ID. Finalize goes through the index of memory resident objects (the key to object map). For each record of the index it calls Write to store the corresponding object and then removes the references to the index record from both maps. This in turn deletes the record itself. Note how This is used to get the object. The procedure Bind is defined to create an index record. It calls to Attach to bind Index_Record with the object and places handles to Index_Record in each of the maps. Ref is used to obtain them

File test_persistent_file_storage.adb (continued):
   function Store
            (  Storage : access File_Storage;
               Object  : Deposit_Handle
            )  return Key is
      This : Deposit_Ptr := Ptr (Object);
   begin
      if 
This = null or else not Is_In (Storage.Object_To_Record, This)
      then
         Storage.Last_ID := Storage.Last_ID + 1;
         Bind (Storage, Object, Storage.Last_ID);
         return Storage.Last_ID;
      else
         return
Ptr (Get (Storage.Object_To_Record, This)).ID;
      end if;
   end Store;

The implementation of Store first looks into the index to check if it is already there. If yes it returns the key of the object. Otherwise it generates a new key by incrementing the field Last_ID and calls Bind to create a new index record.

File test_persistent_file_storage.adb (continued):
   function Restore (Storage : access File_Storage; ID : Key)
      return Deposit_Handle is
   begin

      if Is_In (Storage.Key_To_Record, ID) then
         return Ref (This (Ptr (Get (Storage.Key_To_Record, ID)).all));
      else
         --
         -- Read the object from the file
         --

         declare
            Data    : File_Record;
            List    : Deposit_List;
            Object  : Deposit_Ptr;
            Result  : Deposit_Handle;
            Pointer : Positive;
         begin
            Read (Storage.File, Data, Count (ID));
            for No in 1..Data.Count loop
               Add (List, Restore (Storage, Data.References (No)));
            end loop;
            Pointer := Data.Descriptor'First;
            while Data.Descriptor (Pointer) /= ':' loop
               Pointer := Pointer + 1;
            end loop;
            Pointer := Pointer + 1;
            Create
            (  Data.Descriptor,
               Pointer,
               Data.Descriptor (Data.Descriptor'First..Pointer - 2),
               List,
               Object
            );
            Result := Ref (Object);
            Bind (Storage, Result, ID);
            return Result;
         end;
      end if;
   end Restore;

The procedure Restore checks the index if an object with the specified key was already created. If yes it returns a handle to the object. This is used to get an object pointer from Index_Record. When the key identifies an unknown object, Restore reads its record from the file. The key is the record number. Restore goes through the array References and for each key calls itself to ensure this object to be restored too. The returned handle to that object is placed in a Deposit_List container. The container together with Descriptor's prefix (up to the first colon) as object's class name and the rest of it as the object's description, are passed to Create. That creates the object. A handle to it is then returned after Bind is called to place the object into the storage index.

File test_persistent_file_storage.adb (continued):
   procedure Deleted
             (  Link  : in out Index_Record;
                Temps : in out Deposit_Container'Class
             )  is
   begin
      null
;
   end Deleted;

   procedure Destroyed (Link : in out Index_Record) is
   begin

      Write (Link.Storage.all, This (Link).all, Link.ID);
      Remove (Link.Storage.Object_To_Record, This (Link));
      Remove (Link.Storage.Key_To_Record, Link.ID);
   end Destroyed;

end Test_Persistent_File_Storage;

The implementation of Deleted does nothing. Destroyed writes the object into the file and then removes it from the index.

2.4.2. Persistent objects implementation

Let's take binary tree node as an example of persistent object. A node may have up to two successors or none. Predecessor - successor relation is naturally mapped to dependant - referent.

File test_persistent_tree.ads:
with Object.Archived;  use Object.Archived;
with Deposit_Handles;  use Deposit_Handles;

package Test_Persistent_Tree is
   --
   -- Nothing -- No node handle
   --

   function Nothing return Handle;
   --
   -- Create_Node -- This function creates a new node
   --
   -- Field - Identifies the node
   -- Left  - Successor on the left (a handle to)
   -- Right - Successor on the right (a handle to)
   --

   function Create_Node
            (  Field : Integer;
               Left  : Handle := Nothing;
               Right : Handle := Nothing
            )  return Handle;
   --
   -- Print -- Prints the tree rooted in a node
   --
   --    Root - The root node (a handle to)
   --
   procedure Print (Root : Handle; Indentation : String := "");

private
   --
   -- Node -- Binary tree node type
   --
   type Node is new Deposit with record
      Field : Integer; -- Node identifier
      Left  : Handle;  -- Left successor, a handle to
      Right : Handle;  -- Right successor, a handle to
   end record;
   --
   -- Implementation of Deposit's operations
   --

   function Get_Class (Object : Node) return String;
   procedure Get_Referents
             (  Object    : Node;
                Container : in out Deposit_Container'Class
             );
   function Is_Modified (Object : Node) return Boolean;
   procedure Reset_Modified (Object : in out Node);
   procedure Restore
             (  Source  : String;
                Pointer : in out Integer;
                Class   : String;
                List    : Deposit_Container'Class;
                Object  : out Deposit_Ptr
             );
   procedure Store
             (  Destination : in out String;
                Pointer     : in out Integer;
                Object      : Node
             );
end Test_Persistent_Tree;

The public part of the package declares the function Create_Node and the procedure Print. Create_Node creates a new node and returns a handle to it. All nodes are referenced using Handle of Deposit_Handles. Each node is identified by an integer number. The next two parameters of Create_Node are the handles to the left and right successors. They are defaulted to an invalid handle for which the function Nothing is also declared. It plays role of a constant invalid handle. The procedure Print is used for control.  It prints the tree rooted in the node specified by the parameter Root.

The private part is straightforward. It declares the type Node as a descendant of Deposit. The operations Get_Class, Get_Referents, Is_Modified, Reset_Modified, Restore and Store are overridden to provide implementations.

File test_persistent_tree.adb:
with Ada.Text_IO;            use Ada.Text_IO;
with Strings_Edit;           use Strings_Edit;
with Strings_Edit.Integers;  use Strings_Edit.Integers;

package body Test_Persistent_Tree is
   Class : constant String := "Node"; -- The class of

   function Nothing return Handle is
      None : Handle;
   begin
      return
None;
   end Nothing;

   function Create_Node
            (  Field : Integer;
               Left  : Handle := Nothing;
               Right : Handle := Nothing
            )  return Handle is
      Node_Ptr : Deposit_Ptr := new Node;
      Object   : Node renames Node (Node_Ptr.all);
   begin
      Object.Field := Field;
      Object.Left  := Left;
      Object.Right := Right;
      return Ref (Node_Ptr);
   end Create_Node;

   function Get_Class (Object : Node) return String is
   begin
      return
Class;
   end Get_Class;

   procedure Get_Referents
             (  Object    : Node;
                Container : in out Deposit_Container'Class
             )  is
   begin
      if Is_Valid (Object.Left) then
         Add (Container, Object.Left);
      end if;
      if Is_Valid (Object.Right) then
         Add (Container, Object.Right);
      end if;
   end Get_Referents;

   function Is_Modified (Object : Node) return Boolean is
   begin
      return 
True; -- Save it always, do not care about performance
   end Is_Modified;

   procedure Reset_Modified (Object : in out Node) is
   begin
      null
;
   end Reset_Modified;

The implementation of Get_Referents places handles to the node successors into a Deposit_Container. The left successor is placed first. Is_Modified and Reset_Modified are void for sake of simplicity. So a node is always written into the persistent storage even if it is not changed.

File test_persistent_tree.adb (continued):
   procedure Restore
             (  Source  : String;
                Pointer : in out Integer;
                Class   : String;
                List    : Deposit_Container'Class;
                Object  : out Deposit_Ptr
             )  is
      Field : Integer;
      Left  : Handle;
      Right : Handle;
   begin
      if
Source (Pointer) = '<' then
         Left := Ref (List, 1);
         if Source (Pointer + 1) = '>' then
            Right := Ref (List, 2);
         end if;
      elsif Source (Pointer + 1) = '>' then
         Right := Ref (List, 1);
      end if;
      Pointer := Pointer + 2;
      Get (Source, Pointer, Field);
      Object := new Node;
      declare
         Item : Node renames Node (Object.all);
      begin
         Item.Field := Field;
         Item.Left  := Left;
         Item.Right := Right;
      end;
   exception
      when others
=>
         raise Data_Error;
   end Restore;

The implementation of Restore first gets description of node dependencies from the source string. It is two characters. The first one is either '<' if there is a left successor or '-' otherwise. The second is '>' if there is a right successor or else '-'. After that it gets the node identifier (plain integer number). Then a new node object is allocated. Note that the target access type should be Deposit_Ptr to ensure right storage pool selection.

File test_persistent_tree.adb (continued):
   procedure Store
             (  Destination : in out String;
                Pointer     : in out Integer;
                Object      : Node
             )  is
   begin
      if
Is_Valid (Object.Left) then
         Put (Destination, Pointer, "<");
      else
         Put (Destination, Pointer, "-");
      end if;
      if Is_Valid (Object.Right) then
         Put (Destination, Pointer, ">");
      else
         Put (Destination, Pointer, "-");
      end if;
      Put (Destination, Pointer, Object.Field);
   end Store;

   procedure Print (Root : Handle; Indentation : String := "") is
   begin
      if
Is_Valid (Root) then
         declare

            The_Node : Node renames Node (Ptr (Root).all);
         begin
            Put_Line (Indentation & "\_" & Image (The_Node.Field));
            Print (The_Node.Left, Indentation & " |");
            Print (The_Node.Right, Indentation & " ");
         end;
      else
         Put_Line (Indentation & "\_*");
      end if;
   end Print;

begin
   Register_Class (Class, Restore'Access);
end Test_Persistent_Tree;

The procedure Store is reverse to Restore. Also the package defines a new class of persistent objects named Node. For this it calls Register_Class once upon elaboration with the class name and a pointer to Restore as parameters.

2.4.3. Test program

The test program is shown below. It consists of two sessions. In the first session an object is stored. In the second one it is restored.

File test_persistent_storage.adb:
with Ada.Text_IO;                   use Ada.Text_IO;
with Test_Persistent_File_Storage;  use Test_Persistent_File_Storage;
with Test_Persistent_Tree;          use Test_Persistent_Tree;
with Deposit_Handles;               use Deposit_Handles;

procedure Test_Persistent_Storage is
   Root_Key : Key;
begin
   Clean_Up;
   Put_Line ("Session 1");
   declare
      DB   : aliased File_Storage;
      Root : Handle;
   begin
      Root :=
         Create_Node
         (  1,
            Create_Node (2),
            Create_Node
            (  3,
               Create_Node
               (  4,
                  Create_Node (5)
               ),
               Create_Node (6)
         )  );
      Print (Root);
      Root_Key := Store (DB'Access, Root);
   end;
   Put_Line ("Session 2");
   declare
      DB   : aliased File_Storage;
      Root : Handle;
   begin
      Root := Restore (DB'Access, Root_Key);
      Print (Root);
   end;
end Test_Persistent_Storage;

The test program first calls Clean_Up to delete any existing storage file. Then it declares DB, a File_Storage object. After that a tree is created and Root becomes a handle to the tree root node. The tree is printed and then its root node is stored into DB. There result of the operation is the external key of the root node. This key can be used to restore the object. Note that the whole tree is stored because the any node depends on its child nodes. What Store does depends on the implementation. In our case physical file writing happens either upon finalization of the storage object (DB) or upon finalization of the persistent object (Root). Both objects are go out of scope at end closing the first session. The second session uses Restore and the external key to bring the root node back from the storage. Again, all the objects it depends on are restored as well. Finally, the restored tree is printed.

2.4.4. Predefined persistent storage test

The test program that uses an ODBC data base as a persistent storage is shown below:

File test_ODBC_persistence.adb:
with Ada.Text_IO;           use Ada.Text_IO;
with Deposit_Handles;       use Deposit_Handles; 
with Persistent.Handle;     use Persistent.Handle;
with Test_Persistent_Tree;  use Test_Persistent_Tree;
with Test_ODBC_Session;     use Test_ODBC_Session;

procedure Test_ODBC_Persistence is
   Name : constant String := "The tree";
begin
   Put_Line ("Session 1");
   declare
      DB   : Storage_Handle := Open;
      Root : Handle;
   begin
      Root :=
         Create_Node
         (  1,
            Create_Node (2),
            Create_Node
            (  3,
               Create_Node
               (  4,
                  Create_Node (5)
               ),
               Create_Node (6)
         )  );
      Print (Root);
      Put (DB, Root, Name);
   end;
   Put_Line ("Session 2");
   declare
     DB   : Storage_Handle := Open;
     Root : Handle;
   begin
      Root := Get (DB, Name);
      Print (Root);
   end;
end Test_APQ_Persistence;

Then it declares DB, a Storage_Handle. The handle is initialized using the function Open defined in Test_ODBC_Session.adb. It prompts for connection parameters and then calls Persistent.ODBC.Create. After that a tree is created and Root becomes a handle to the tree root node. The tree is printed and then its root node is stored into DB as "The three". For this it calls Put. Note that the whole tree is stored because the any node depends on its child nodes. The second session uses Get and the name "The three" to bring the root node back from the storage. Again, all the objects it depends on are restored as well. Finally, the restored tree is printed. Carefully observe that the package Test_Persistent_Tree needed no modifications to be able to work with a different type of storage.

This test program modified for APQ and SQLite are in the files test_APQ_persistence.adb and test_APQ_persistence.adb correspondingly.

[Back][TOC][Next]

2.5. Abstract persistent storage

The package Persistent provides an abstract persistent storage communication object. The corresponding persistent storage can be implemented on the basis of a plain file, data base etc. Objects in the storage are identified by their names. Additionally anonymous objects can be created and deleted as required by the named ones. If an object depends on some other objects, then when stored into the storage, the referred objects are stored as well. If they do not already persist there, these objects will be anonymous. Anonymous persistent objects are subject of garbage collection. The way of collection is determined by the implementation.

The objects can be named. The object names are UTF-8 encoded strings. An  implementation can internally provide other encoding when the persistent storage natively supports Unicode different to UTF-8. Named objects are deleted only on explicit request or when they loose names becoming anonymous. Named objects build a hierarchy, where one named object can be a descendant of another. This hierarchy is a forest. The parent objects serve as folders for their children. It is not specified which nature parent objects should have. Objects of any kind can serve as parents. Also the parent-child relation does not impose any additional dependency between the objects. It is a relation solely between the names of.

The procedure Delete can be applied to a handle to the object in order to request its deletion. If the object cannot be deleted immediately it becomes anonymous for later collection. Persistent storage interfaces are itself objects and are a subject of garbage collection as well. When a named parent object becomes anonymous all its descendants do as well.

The package defines the abstract type Storage_Object which describes the interface of a persistent storage communication object. It is derived from Entity, so persistent storage interface objects are subject of garbage collection:

type Storage_Object is abstract new Object.Entity with private;
type
Storage_Object_Ptr is access Storage_Object'Class;
for
Storage_Object_Ptr'Storage_Pool
   use
Object.Entity_Ptr'Storage_Pool;

It is strongly recommended not to directly use derivatives of Storage_Object. For this purpose serve handles to the objects.

The subtype Deposit_Handle is provided for convenience in referring persistent objects. It "renames" the handle type of the package Deposit_Handles:

subtype Deposit_Handle is Deposit_Handles.Handle;

The root-level objects have no parent. When a subprogram requires a parent specification the constant Root_Directory is used:

Root_Directory : constant Deposit_Handle;

The package instantiates Generic_Set to obtain sets of object names.

package Catalogue is
   new
Generic_Set
       (  Object_Type  => Unbounded_String,
          Null_Element => Null_Unbounded_String
       );

The following operations are defined on Storage_Object:

function Get
         (  Storage : access Storage_Object;
            Name    : String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Deposit_Handle is abstract;

This function returns a handle to a persistent object by its name and a handle to the parent object. The root-level objects have no parents, in which case Parent is an invalid handle. An implementation should first check if the the persistent object already has a memory-resident counterpart. Otherwise it should create one from the persistent storage.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object
Use_Error The class of the object is unknown. This error means that there is no known Ada type yet registered to handle the objects from the persistent storage. Normally Ada types register their classes upon corresponding package elaboration. If the package is not used by the application, its persistent objects cannot be restored.

function Get_Class
         (  Storage : access Storage_Object;
            Name    : String;
            Parent  : Deposit_Handle := Root_Directory
         )  return String is abstract;

This function returns the class of a persistent object by its name and a handle to the parent object.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object

function Get_Creation_Time
         (  Storage : access Storage_Object;
            Name    : String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Time is abstract;

This function returns the creation time of a persistent object by its name and a handle to the parent object.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object

function Get_List
         (  Storage     : access Storage_Object;
            Prefix      : String := "";
            Suffix      : String := "";
            Equivalence : Unicode_Mapping_Function := null;
            Parent      : Deposit_Handle := Root_Directory
         )  return Catalogue.Set is abstract;

This function returns a complete list of all named objects persistent in Storage which have parent object specified by the parameter Parent. The list does not include anonymous persistent objects, which have neither parents nor names. Only names starting with Prefix and ending with Suffix are returned. When names are compared two characters are considered same if their corresponding values returned by Equivalence are same. When Equivalence is null, it is assumed an identity mapping. For case insensitive mappings see Strings_Edit.UTF8.Mapping.To_Lowercase. Prefix and Suffix may not overlap when matched. The list is a set of object names.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage

function Get_Name
         (  Storage : access Storage_Object;
            Object  : Deposit_Handle
         )  return String is abstract;

This function returns the object's name in Storage. The object is specified by its handle. Note that object names are relative to their parents, so only a pair name - parent does identify the object.

Exceptions
Constraint_Error Invalid handle or Object does not persist in Storage
Data_Error Inconsistent Storage
Name_Error Object is anonymous

function Get_Parent
         (  Storage : access Storage_Object;
            Object  : Deposit_Handle
         )  return Deposit_Handle is abstract;

This function returns the object's parent in Storage. The object is specified by its handle.

Exceptions
Constraint_Error Invalid handle or Object does not persist in Storage
Data_Error Inconsistent Storage
Name_Error Object is anonymous

function Is_Descendant
         (  Storage : access Storage_Object;
            Object  : Deposit_Handle;
            Parent  : Deposit_Handle
         )  return Boolean is abstract;

This function checks if Object is a direct or indirect descendant of Parent. The result is false if Object is invalid, or else specifies an anonymous or non-persisting in Storage object. Otherwise the result is true when Parent is invalid (i.e. identifies root-level objects) and false when Parent does not persist in Storage. Data_Error is propagated on error in Storage.

function Is_In
         (  Storage : access Storage_Object;
            Name    : String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Boolean is abstract;
function
Is_In
         (  Storage : access Storage_Object;
            Object  : Deposit_Handle
         )  return Boolean is abstract;

These functions check whether an object persists in Storage. The object can be identified either by its name and parent or by a handle to it. When Object is not a valid handle the result is false.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage

function Is_Named
         (  Storage : access Storage_Object;
            Object  : Deposit_Handle
         )  return Boolean is abstract;

These functions check whether Object persists and named in Storage. When Object is not a valid handle the result is false.

Exceptions
Data_Error Inconsistent Storage

procedure On_Error
          (  Storage : Storage_Object;
             Text    : String;
             Error   : Exception_Occurrence
          );

This procedure is called on exceptions which cannot be handled, e.g. in Finalize. The default implementation does nothing. It can be overridden in order to write a trace log.

procedure Put
          (  Storage : in out Storage_Object;
             Object  : in out Deposit_Handle;
             Name    : String;
             Parent  : Deposit_Handle := Root_Directory
          )  is abstract;
procedure
Put
          (  Storage : in out Storage_Object;
             Object  : in out Deposit_Handle
          )  is abstract;

These procedures are used to store Object in Storage. The parameters Name and Parent specify the object's name and parent in Storage. When omitted the object is stored as anonymous. Anonymous persistent objects are collected when not used, but not before their memory-resident counterpart vanishes. When Object already persists in Storage and Name and Parent are specified, then they are checked to be same. If this check fails, or Name is empty or illegal, or else conflicts with the name of another object Name_Error is propagated. When name is not specified, no check is made. 

Exceptions
Constraint_Error Invalid handle, Parent does not persist in Storage
Data_Error Inconsistent Storage
Name_Error Illegal name (such as empty) or name conflict

procedure Rename
          (  Storage    : in out Storage_Object;
             Old_Name   : String;
             Old_Parent : Deposit_Handle := Root_Directory
             New_Name   : String;
             New_Parent : Deposit_Handle := Root_Directory
          )  is abstract;
procedure
Rename
          (  Storage    : in out Storage_Object;
             Object     : in out Deposit_Handle;
             New_Name   : String;
             New_Parent : Deposit_Handle := Root_Directory
          )  is abstract;

These procedures change the name of the object specified by either its old name and parent (the parameters Old_Name, Old_Parent) or by a handle to it (the parameter Object). When renamed object was anonymous before renaming it becomes a named one. When Object is an invalid handle or does not refer to a persistent object then Constraint_Error is propagated. End_Error is propagated when Old_Name does not refer any persistent object. No object can become a parent of itself, so a check shall be made whether New_Parent specifies the object or any of its descendant. If yes, Name_Error is propagated.

Exceptions
Constraint_Error Object is invalid handle or does not refer to any object in Storage. New_Parent does not persist in Storage.
Data_Error Inconsistent Storage
End_Error Old_Name indicates no object
Name_Error Illegal name (such as empty) or name conflict. The object is an ancestor of its new parent.

procedure Unname
          (  Storage : in out Storage_Object;
             Name    : String;
             Parent  : Deposit_Handle := Root_Directory
          )  is abstract;
procedure
Unname
          (  Storage : in out Storage_Object;
             Object  : in out Deposit_Handle
          )  is abstract;

These procedures make object anonymous. The object can be specified either by its name and parent or by a handle to it. Unnamed objects are automatically deleted when no more in use. Nothing happens if the object is already unnamed. Nothing also happens if Object is an invalid handle, not a handle to a persistent object or does not exist. Note that anonymous objects are not deleted as long as they have memory-resident counterparts. Observe the difference between Unname and Delete (Object.Archived.Delete) called on an object handle. Delete requests object deletion from both memory and persistent storage. Unname does it for persistent storage only. Both may have no immediate effect if the object is still in use. Note that when a parent object becomes anonymous so all its descendants do.

Exceptions
Constraint_Error The object specified by Parent is not persistent in Storage
Data_Error Inconsistent Storage

[Back][TOC][Next]

2.6. Handles to persistent storage

A persistent storage interface is itself an object, which can be referenced by another object. Usually it is a persistent object which memory-resident counterpart of is a proxy to the data in the persistent storage. For example, for a large data structure it might be very inefficient to load it all into the memory. In this case in the memory one would create a small proxy object, which will query the persistent storage for parts of the object's data as necessary. Such proxy object will require a reference to its persistent storage. This also would prevent the persistent storage interface object from premature destruction. This is why it is strongly recommended to use handles to persistent storage interface objects.

The package Persistent.Handle provides the type Storage_Handle, which serves as a handle to an abstract persistent storage interface object. It is guarantied that a persistent storage interface object will not be destroyed as long at least one handle refers to it.

type Storage_Handle is private;

The following operations are defined on Storage_Handle:

function Get
         (  Storage : Storage_Handle;
            Name    : String / Wide_String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Deposit_Handle;

This function searches for the specified object by its name and parent. The name is an UTF-8 encoded string or else a wide string. If the object is already available a handle to it is returned. Otherwise it first is restored from the persistent storage.

Exceptions
Constraint_Error Invalid handle Storage, Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object
Use_Error The class of the object is unknown. This error means that there is no known Ada type yet registered to handle the objects from the persistent storage. Normally Ada types register their classes upon corresponding package elaboration. If the package is not used by the application, its persistent objects cannot be restored.

function Get_Class
         (  Storage : access Storage_Handle;
            Name    : String / Wide_String;
            Parent  : Deposit_Handle := Root_Directory
         )  return String;

These functions return the class of a persistent object by its name and parent. The name can be specified either an UTF-8 encoded string or as a wide string.

Exceptions
Constraint_Error Invalid handle Storage, Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object

function Get_Creation_Time
         (  Storage : access Storage_Handle;
            Name    : String / Wide_String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Time;

These functions return the creation time of a persistent object by its name and parent. The name can be specified either an UTF-8 encoded string or as a wide string.

Exceptions
Constraint_Error Invalid handle Storage, Parent is not persistent in Storage
Data_Error Inconsistent Storage
End_Error No such object

function Get_List
         (  Storage     : Storage_Handle;
            Prefix      : String := "";
            Suffix      : String := "";
            Equivalence : Unicode_Mapping_Function := null;
            Parent      : Deposit_Handle := Root_Directory
         )  return Catalogue.Set;
function Get_List
         (  Storage     : Storage_Handle;
            Prefix      : Wide_String;
            Suffix      : Wide_String;
            Equivalence : Unicode_Mapping_Function := null;
            Parent      : Deposit_Handle := Root_Directory
         )  return Catalogue.Set;

These functions return a list of all immediate children of Parent persistent in Storage. Only names starting with Prefix and ending with Suffix are eligible. When names are compared two characters are considered same if their corresponding values according to Equivalence are same. When Equivalence is null, it is assumed an identity mapping. For case insensitive mappings see Strings_Edit.UTF8.Mapping.To_Lowercase. Observe that Prefix may not overlap Suffix when matched. So if Prefix="AB" and Suffix="BC", then "ABC" does not fit, but "ABBC" does. The result of the function is a set of object names. Prefix and Suffix are either UTF-8 encoded or wide strings.

Exceptions
Constraint_Error Invalid handle Storage, Parent is not persistent in Storage
Data_Error Inconsistent Storage

function Get_Name
         (  Storage : Storage_Handle;
            Object  : Deposit_Handle
         )  return String;

This function returns the object's name in Storage. The object is specified by its handle. The result is an UTF-8 encoded string. Note that the object names are relative to the object's parent.

Exceptions
Constraint_Error Invalid handle or Object does not persists in Storage
Data_Error Inconsistent Storage
Name_Error Object is anonymous

function Get_Parent
         (  Storage : Storage_Handle;
            Object  : Deposit_Handle
         )  return Deposit_Handle;

This function returns the object's parent in Storage. The object is specified by its handle.

Exceptions
Constraint_Error Invalid handle or Object does not persists in Storage
Data_Error Inconsistent Storage
Name_Error Object is anonymous

procedure Invalidate (Storage : in out Storage_Handle);

This procedure makes handle pointing to nothing. If it was the last reference to the persistent storage interface object, the latter is destroyed.

function Is_Descendant
         (  Storage : Storage_Handle;
            Object  : Deposit_Handle;
            Parent  : Deposit_Handle
         )  return Boolean;

This function checks if Object is a direct or indirect descendant of Parent. The result is false if Object is invalid, or else specifies an anonymous or non-persisting in Storage object. Otherwise the result is true when Parent is invalid (i.e. identifies root-level objects) and false when Parent does not persist in Storage. Data_Error is propagated on error in Storage.

Exceptions
Constraint_Error Invalid handle Storage
Data_Error Inconsistent Storage

function Is_In
         (  Storage : Storage_Handle;
            Name    : String / Wide_String;
            Parent  : Deposit_Handle := Root_Directory
         )  return Boolean;
function
Is_In
         (  Storage : Storage_Handle;
            Object  : Deposit_Handle
         )  return Boolean;

These functions check whether an object persists in Storage. The object can be identified either by its name and parent or by a handle to it. When Object is not a valid handle the result is false. The name can be specified either an UTF-8 encoded string or as a wide string.

Exceptions
Constraint_Error Invalid handle (Storage), Parent does not persists in Storage
Data_Error Inconsistent Storage

function Is_Named
         (  Storage : Storage_Handle;
            Object  : Deposit_Handle
         )  return Boolean;

These functions check whether Object persists and named in Storage. When Object is not a valid handle the result is false.

Exceptions
Constraint_Error Invalid handle (Storage)
Data_Error Inconsistent Storage

function Is_Valid (Storage : Storage_ Handle) return Boolean;

This function checks whether a handle points to a persistent storage interface object.

function Ptr (Storage : Storage_ Handle) return Storage_Object_Ptr;

This function is used to get a pointer to the object the handle Storage points to. The pointer of to the object shall be used no longer the handle it was get from exists.

procedure Put
          (  Storage : in out Storage_Handle;
             Object  : in out Deposit_Handle;
             Name    : String;
             Parent  : Deposit_Handle := Root_Directory
          );
procedure
Put
          (  Storage : in out Storage_Handle;
             Object  : in out Deposit_Handle;
             Name    : Wide_String;
             Parent  : Deposit_Handle := Root_Directory
          );
procedure
Put
          (  Storage : Storage_Handle;
             Object  : in out Deposit_Handle
          );

These procedures are used to store Object in Storage. The parameters Name and Parent specify the object name there. It can be specified either an UTF-8 encoded string or as a wide string. When the name is omitted the object is stored anonymous. Anonymous persistent objects are collected when no more used. It is safe to put an anonymous object into Storage and then reference it in another persistent object. When Object already persists in Storage and Name is specified, then it is checked that it is same. If this check fails, Name is empty, illegal, or conflicts with the name of another object Name_Error is propagated.

Exceptions
Constraint_Error Invalid handle (Storage or Object), Parent is not persistent in Storage
Data_Error Inconsistent Storage
Name_Error Illegal name (such as empty), name conflict, a renaming attempt

function Ref (Storage : Storage_Object_Ptr) return Storage_Handle;

This function obtains a handle to the persistent storage interface object. Having a handle to the object prevents object's premature destruction.

procedure Rename
          (  Storage    : in out Storage_Handle;
             Old_Name   : String;
             Old_Parent : Deposit_Handle := Root_Directory;
             New_Name   : String;
             New_Parent
: Deposit_Handle := Root_Directory
          );
procedure
Rename
          (  Storage    : in out Storage_Handle;
             Object     : in out Deposit_Handle;
             New_Name   : String;
             New_Parent
: Deposit_Handle := Root_Directory;
          );
procedure
Rename
          (  Storage    : in out Storage_Handle;
             Old_Name   : Wide_String;
             Old_Parent : Deposit_Handle := Root_Directory;
             New_Name   : Wide_String;
             New_Parent : Deposit_Handle := Root_Directory
          );
procedure
Rename
          (  Storage    : in out Storage_Handle;
             Object     : in out Deposit_Handle;
             New_Name   : Wide_String;
             New_Parent : Deposit_Handle := Root_Directory
          );

These procedures change the name of the object specified either by its old name and parent (the parameter Old_Name, Old_Parent) or by a handle to it. The names can be specified either an UTF-8 encoded string or as a wide string. When the renamed object was anonymous before renaming it becomes a named one.

Exceptions
Constraint_Error Invalid handle or Object is not persistent in Storage, New_Parent does not persists in Storage
Data_Error Inconsistent Storage
End_Error Old_Name indicates no object
Name_Error Illegal name (such as empty) or name conflict. New_Parent is anonymous or a descendant of the renamed object

procedure Set (Storage : in out Storage_Handle; Object : Storage_Object_Ptr);

This procedure resets the handle Storage to a possibly another object. In the course of this operation the previously pointed object may be destroyed if Storage was the last handle pointing to it. It is safe when Object is the object already pointed by the handle. When Object is null, this procedure is equivalent to Invalidate.

procedure Unname
          (  Storage : in out Storage_Handle;
             Name    : String / Wide_String;
             Parent
 : Deposit_Handle := Root_Directory
          );
procedure
Unname
          (  Storage : in out Storage_Handle;
             Object  : in out Deposit_Handle
          );

These procedures make an object anonymous. The object can be specified either by its name and parent object or by a handle to it. The name is either an UTF-8 encoded string or a wide string. Unnamed objects are automatically deleted when no more in use. Nothing happens if the object is already unnamed. Nothing also happens if Object is an invalid handle, not a handle to a persistent object or does not exist. Note that anonymous objects are not deleted before objects pointed by either Object or Storage destroyed. There is a difference between Unname and Delete called on an object handle. Delete requests object deletion from both memory and persistent storage. Unname does it for persistent storage only. Both may have no immediate effect if the object is still in use. When an object becomes anonymous so do all its descendants.

Exceptions
Constraint_Error Storage is ot a valid handle, Parent does persists in Storage
Data_Error Inconsistent Storage

[Back][TOC][Next]

2.7. Persistent storage factory

The package Persistent.Handle.Factory provides a factory of persistent storage objects.

function Create_APQ
         (  Server_Type    : Database_Type;
            Data_Base_Name : String;
            User_Name      : String;
            Password       : String;
            Host_Name      : String  := "localhost";
            Port_Number    : Natural := 0;
            Erase          : Boolean := False
         )  return Storage_Handle;

This function creates an APQ persistent storage interface object and returns a handle to it. The object is responsible for interacting with a data base via APQ bindings. A connection is established to the server specified by the parameter Host_Name. The parameter Server_Type identifies the data base engine. It can be Engine_PostgreSQL, Engine_MySQL etc, one of the supported by APQ engines. The enumeration type Database_Type is defined in the package APQ delivered with the APQ distribution. User_Name and Password identify the data base user. Data_Base_Name is the name of a data base managed by the server. Port_Number specifies the TCP/IP port listened by the server. When specified as 0, a reasonable default is used. The parameter Erase when true erases the data base contents by dropping all the tables used for storing persistent objects. If the data base contains any additional tables, they remain untouched.

Exceptions
Data_Error Data base error
Use_Error Connection problem. Either of the parameters identifying server, data base or user might be wrong

function Create_ODBC
         (  Server_Name : String;
            User_Name   : String;
            Password    : String;
            Erase       : Boolean := False
         )  return Storage_Handle;
function Create_ODBC
         (  Server_Name : Wide_String;
            User_Name   : Wide_String;
            Password    : Wide_String;
            Erase       : Boolean := False
         )  return Storage_Handle;

This function creates a connection to an ODBC data base, i.e. any data base that has an ODBC driver and returns a valid handle to the persistent storage interface object to communicate the data base. The parameter Server_Name specifies the data server name. It denotes both the data base and the server (driver). The parameters User_Name and Password specify the user and the password to access the data base. All names here are UTF-8 encoded or wide strings.When the parameter Erase is set to true, all used tables are erased upon establishing the connection. One can use it if there is a possibility that the data base contains some corrupted or undesired data. So the data base would initially contain no persistent objects.

Exceptions
Data_Error Data base error
Use_Error Connection problem. Either of the parameters Server_Name, User_Name, Password might be wrong

[Back][TOC][Next]

2.8. Persistent storage implementations

Simple components provide ready-to-use persistent storage implementations. The package Persistent.Handle.Factory supports run-time selection of the most suitable implementation. That might be undesirable, because the implementations rely on third party products such as GNADE and APQ. So Persistent.Handle.Factory needs all of them installed. Alternatively, if it is known that only a particular implementation will be actually used, one can do it directly without the factory. This will remove any dependency on other implementations. This section describes presently available implementations.

2.8.1. ODBC databases

The package Persistent.Native_ODBC provides an implementation of abstract persistent storage based on Open Database Connectivity (ODBC) interface to data bases. ODBC is provided for a great variety of platforms and data bases. The package declares the following subroutines:

function Create
         (  Server_Name : String;
            User_Name   : String;
            Password    : String;
            Erase       : Boolean := False
         )  return Storage_Handle;

This function creates a connection to an ODBC data base, i.e. any data base that has an ODBC driver and returns a valid handle to the persistent storage interface object to communicate the data base. The parameter Server_Name specifies the data server name. It denotes both the data base and the server (driver). The parameters User_Name and Password specify the user and the password to access the data base. All these parameters are UTF-8 encoded strings. When the parameter Erase is set to true, all used tables are erased upon establishing the connection. One can use it if there is a possibility that the data base contains some corrupted or undesired data. So the data base would initially contain no persistent objects.

Exceptions
Data_Error Data base error
Use_Error Connection problem. Either of the parameters Server_Name, User_Name, Password might be wrong

procedure Disable_Tracing
          (  Storage : in out Storage_Handle
          );

This procedure disables tracing of SQL requests. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage.

procedure Enable_Tracing
          (  Storage : in out Storage_Handle;
             Name    : String
          );

This procedure starts tracing SQL requests using trace file Name. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage. Data_Error is propagated on any other error.

function Get_Server_Name (Storage : Storage_Handle) return String;

This function returns the server name. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage.

function Is_ODBC (Storage : Storage_Handle) return Boolean;

This function returns true if Storage is a valid handle to an ODBC persistent storage interface object.

function Serializable (Storage : Storage_Handle) return Boolean;

This function returns true if the ODBC driver communicated through Storage supports serializable transactions. Constraint_Error is propagated when Storage is not a valid handle to an ODBC persistent storage interface object.

function Unicode (Storage : Storage_Handle) return Boolean;

This function returns true if the ODBC driver communicated through Storage natively supports Unicode. Constraint_Error is propagated when Storage is not a valid handle to an ODBC persistent storage interface object.

Implementation notes. The implementation uses a minimal set of SQL features to support a greater number of data bases. Therefore almost everything, from generating unique keys to ON DELETE CASCADE is implemented without the data base engine. The most suitable types are selected according to the results of SQLGetTypeInfo. As the result the performance might be not optimal.

The minimal requirements for an ODBC driver:

32-bit integers SQL_INTEGER. When 64-bit integers (SQL_BIGINT) are supported, they are used for object unique keys. Otherwise, it is (signed) 32-bit ones
Time stamping SQL_TIMESTAMP.
Variable character strings SQL_LONGVARCHAR
PRIMARY KEY Object primary keys are integers.
MAX() In SELECT
DISTINCT In SELECT
NOW() In INSERT as a value for SQL_TIMESTAMP
NULL In INSERT as a value for string

The implementation tries to serialize data base transactions if the ODBC driver support it. In any case the manual-commit mode is used to provide atomic data base changes. The data base structure consists of three tables:

Table objects:

Column Type Description
object_id 64- or 32-bit integer, primary key, unique Object key
catalogue_name UTF-8 string Object name. Unset if object is anonymous
class_name UTF-8 string Object's class
object_data UTF-8 string Object data
parameters_list UTF-8 string The dependency list
created_at Time stamp Object creation time
parent_id 64- or 32-bit integer The key of the object's parent object

Tables backward_links and direct_links:

Column Type Description
dependant 64- or 32-bit integer Object key
referent 64- or 32-bit integer Object key, the object 

2.8.2. GNADE ODBC databases

The package Persistent.ODBC provides an implementation of abstract persistent storage based on Open Database Connectivity (ODBC) interface to data bases. ODBC is provided for a great variety of platforms and data bases. The package declares the following subroutines:

function Create
         (  Server_Name : String;
            User_Name   : String;
            Password    : String;
            Erase       : Boolean := False
         )  return Storage_Handle;

This function creates a connection to an ODBC data base, i.e. any data base that has an ODBC driver and returns a valid handle to the persistent storage interface object to communicate the data base. The parameter Server_Name specifies the data server name. It denotes both the data base and the server (driver). The parameters User_Name and Password specify the user and the password to access the data base. All these parameters are UTF-8 encoded strings. When the parameter Erase is set to true, all used tables are erased upon establishing the connection. One can use it if there is a possibility that the data base contains some corrupted or undesired data. So the data base would initially contain no persistent objects.

Exceptions
Data_Error Data base error
Use_Error Connection problem. Either of the parameters Server_Name, User_Name, Password might be wrong

procedure Disable_Tracing
          (  Storage : in out Storage_Handle
          );

This procedure disables tracing of SQL requests. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage.

procedure Enable_Tracing
          (  Storage : in out Storage_Handle;
             Name    : String
          );

This procedure starts tracing SQL requests using trace file Name. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage. Data_Error is propagated on any other error.

function Get_Server_Name (Storage : Storage_Handle) return String;

This function returns the server name. Constraint_Error is propagated when Storage is not a handle to ODBC persistent storage.

function Is_ODBC (Storage : Storage_Handle) return Boolean;

This function returns true if Storage is a valid handle to an ODBC persistent storage interface object.

function Serializable (Storage : Storage_Handle) return Boolean;

This function returns true if the ODBC driver communicated through Storage supports serializable transactions. Constraint_Error is propagated when Storage is not a valid handle to an ODBC persistent storage interface object.

function Unicode (Storage : Storage_Handle) return Boolean;

This function returns true if the ODBC driver communicated through Storage natively supports Unicode. Constraint_Error is propagated when Storage is not a valid handle to an ODBC persistent storage interface object.

Implementation notes. The implementation uses a minimal set of SQL features to support a greater number of data bases. Therefore almost everything, from generating unique keys to ON DELETE CASCADE is implemented without the data base engine. The most suitable types are selected according to the results of SQLGetTypeInfo. As the result the performance might be not optimal.

The minimal requirements for an ODBC driver:

32-bit integers SQL_INTEGER. When 64-bit integers (SQL_BIGINT) are supported, they are used for object unique keys. Otherwise, it is (signed) 32-bit ones
Time stamping SQL_TIMESTAMP.
Variable character strings SQL_LONGVARCHAR. Also when Unicode is supported (SQL_WLONGVARCHAR) it is used to keep object names. When not supported, object names are stored in plain strings.
PRIMARY KEY Object primary keys are integers.
MAX() In SELECT
DISTINCT In SELECT
NOW() In INSERT as a value for SQL_TIMESTAMP
NULL In INSERT as a value for string

The implementation tries to serialize data base transactions if the ODBC driver support it. In any case the manual-commit mode is used to provide atomic data base changes. The data base structure consists of three tables:

Table objects:

Column Type Description
object_id 64- or 32-bit integer, primary key, unique Object key
catalogue_name UTF-8 string Object name. Unset if object is anonymous
class_name UTF-8 string Object's class
object_data UTF-8 string Object data
parameters_list UTF-8 string The dependency list
created_at Time stamp Object creation time
parent_id 64- or 32-bit integer The key of the object's parent object

Tables backward_links and direct_links:

Column Type Description
dependant 64- or 32-bit integer Object key
referent 64- or 32-bit integer Object key, the object 

The software was tested with:

Some words of warning:

Installation notes. The implementation is based on GNADE 1.5.3a (GNat Ada Database Environment). The GNADE project is distributed under modified GNU Public License. To compile the package Persistent.Handle.Factory you will need a GNADE distribution, at least its part related to ODBC bindings. If you do not use Persistent.Handle.Factory, you need not compile it. For ODBC driver installation refer your data base documentation.

2.8.3. APQ-interfaced databases

The package Persistent.APQ provides an implementation of abstract persistent storage based on Ada95 Database Binding to PostgreSQL/MySQL by Warren W. Gay VE3WWG (APQ). APQ supports a number of data bases accessed via a unified interface. The package Persistent.APQ provides the following subroutines:

function Create
         (  Server_Type    : Database_Type;
            Data_Base_Name : String;
            User_Name      : String;
            Password       : String;
            Host_Name      : String  := "localhost";
            Port_Number    : Natural := 0;
            Erase          : Boolean := False
         )  return Storage_Handle;

This function creates an APQ persistent storage interface object and returns a handle to it. The object is responsible for interacting with a data base via APQ bindings. A connection is established to the server specified by the parameter Host_Name. The parameter Server_Type identifies the data base engine. It can be Engine_PostgreSQL, Engine_MySQL etc, one of the supported by APQ engines. The enumeration type Database_Type is defined in the package APQ delivered with the APQ distribution. User_Name and Password identify the data base user. Data_Base_Name is the name of a data base managed by the server. Port_Number specifies the TCP/IP port listened by the server. When specified as 0, a reasonable default is used. The parameter Erase when true erases the data base contents by dropping all the tables used for storing persistent objects. If the data base contains any additional tables, they remain untouched.

Exceptions
Data_Error Data base error
Use_Error Connection problem. Either of the parameters identifying server, data base or user might be wrong

procedure Disable_Tracing
          (  Storage : in out Storage_Handle
          );

This procedure disables tracing of SQL requests. Constraint_Error is propagated when Storage is not a handle to APQ persistent storage.

procedure Enable_Tracing
          (  Storage : in out Storage_Handle;
             Name    : String
          );

This procedure starts tracing SQL requests using trace file Name. Constraint_Error is propagated when Storage is not a handle to APQ persistent storage. Data_Error is propagated on any other error.

function Is_APQ (Storage : Storage_Handle) return Boolean;

This function returns true if Storage is a valid handle to an APQ persistent storage interface object.

Implementation notes. The data base structure consists of three tables:

Table objects:

Column Type Description
object_id 64- or 32-bit integer, primary key, unique, auto-incremented Object key
catalogue_name UTF-8 string Object name. Unset if object is anonymous
class_name UTF-8 string Object's class
object_data UTF-8 string Object data
parameters_list UTF-8 string The dependency list
created_at Time stamp Object creation time
parent_id 64- or 32-bit integer Parent object key

Tables backward_links and direct_links:

Column Type Description
dependant 64- or 32-bit integer Object key
referent 64- or 32-bit integer Object key, the object 

The software was tested with:

It was not tested under Linux because APQ 2.1 was targeted to 3.x versions of MySQL.

Installation notes. The implementation is based on APQ 2.1. It can be found here. The APQ project is distributed under modified GNU Public License 2 and Ada Community Licenses. To compile the package Persistent.Handle.Factory you will need an APQ distribution. If you do not use Persistent.Handle.Factory, you need not to compile it. You might need to modify the sources in order to be able to work with the recent versions of GNAT compiler, PostgreSQL or MySQL.

2.8.4. SQLite3 databases

The package Persistent.SQLite provides an implementation of abstract persistent storage backed by SQLite databases. SQLite is a data base engine that can be integrated into an application. It does not require a server application. The clients access the data base directly. SQLite is quite useful for lightweight persistence since SQLite requires no installation.

Note that SQLite is also accessible through Persistent.ODBC since SQLite has an ODBC interface. This would rather eliminate the core advantages of SQLite. Unlikely to Persistent.ODBC, the implementation provided by Persistent.SQLite is based on the native bindings with the SQLite database engine statically linked.

The package Persistent.SQLite provides the following subroutines:

function Create
         (  File_Name : String;
            Erase     : Boolean := False
         )  return Storage_Handle;

This function creates an SQLite persistent storage interface object and returns a handle to it. The parameter File_Name is the data base file name (UTF-8 encoded). When the file does not exist, it is created new. The parameter Erase when true erases the data base contents by dropping all the tables used for storing persistent objects. If the data base contained any additional tables, they remain untouched.

Exceptions
Data_Error Data base error
Use_Error File open or creation problem

function Get_File_Name (Storage : Storage_Handle) return String;

This function returns the name of the database backing Storage. Constraint_Error is propagated when Storage is not a handle to SQLite persistent storage.

function Is_SQLite (Storage : Storage_Handle) return Boolean;

This function returns true if Storage is a valid handle to an SQLite persistent storage interface object.

Implementation notes. The data base structure consists of three tables:

Table objects:

Column Type Description
object_id 64-bit integer, primary key Object key
catalogue_name UTF-8 string Object name. Unset if object is anonymous
class_name UTF-8 string Object's class
object_data UTF-8 string Object data
parameters_list UTF-8 string The dependency list
created_at UTF-8 string Object creation time YYYY-MM-DD hh::mm:ss.ssss
parent_id 64-bit integer Parent object key

Tables backward_links and direct_links:

Column Type Description
dependant 64-bit integer Object key
referent 64-bit integer Object key, the object 

2.8.5. Single file implementation

The package Persistent.Single_File provides an implementation of abstract persistent storage backed by persistent transactional files. The package Persistent.SQLite provides the following subroutines:

function Create
         (  File_Name : String;
            Erase     : Boolean  := False;
            Hash_Size : Positive := 256;
            Map_Size  : Positive := 100
         )  return Storage_Handle;

This function creates a persistent storage interface object and returns a handle to it. The parameter File_Name is the data base file name. When the file does not exist, it is created new. The parameter Erase when true erases the data base contents by dropping all the tables used for storing persistent objects. Hash_Size is the number of file blocks kept in the memory. Map_Size is the number of virtual block map stored in the memory.
 

Exceptions
Data_Error Data base error
Use_Error File open or creation problem

function Get_File_Name (Storage : Storage_Handle) return String;

This function returns the name of the database backing Storage. Constraint_Error is propagated when Storage is not a handle to single file persistent storage.

function Is_Single_File (Storage : Storage_Handle) return Boolean;

This function returns true if Storage is a valid handle to a single file persistent storage interface object.

[Back][TOC][Next]

2.9. Implementation of a new persistent storage

This chapter describes the internal packages used to ease implementation of a persistent storage backed by a data base.

2.9.1. Databases

Usually persistent storage is implemented on the basis of an external data base engine. In that data base persistent objects are represented by records or other data structures identified by keys. The packages Persistent.Data_Bank, Persistent.Data_Bank.Index and Persistent.Data_Bank.Indexed are provided for interfacing such data bases. The package Persistent.Data_Bank is the parent package providing basic types. The package Persistent.Data_Bank.Index defines a storage index object to be used at run-time by the storage object. The package Persistent.Data_Bank.Indexed provides a specialized abstract storage which implements the abstract storage operation used the interface defined in Persistent.Data_Bank. That is used to derive a concrete implementation of persistent storage object, that will override the remaining abstract operations.

2.9.2. Storages with keys

The package Persistent.Data_Bank defines abstract interface of the storage objects which identify stored objects using a key. It derives the abstract base type Data_Bank_Object from Storage_Object:

type Data_Bank_Object is abstract
   new
Storage_Object with private;

The keys are provided by implementations by deriving from the abstract base type Persistent_Key:

type Persistent_Key is abstract
   new
Ada.Finalization.Controlled with null record;
type Persistent_Key_Ptr is access Persistent_Key'Class;

The arrays of keys are to be implemented by deriving from the abstract base type Persistent_Key_Array:

type Persistent_Key_Array is abstract
   new
Ada.Finalization.Limited_Controlled with null record;

In order to support data base transactions a special access policy is imposed on Storage_Objects. The type Access_Mutex is used to represent transactions:

type Access_Mutex (Storage : access Data_Bank_Object'Class) is
   abstract new
Ada.Finalization.Limited_Controlled with private;

This type is used as the base for storage specific objects that represent atomic actions on storage, such as data base transactions. Two concrete types are derived from it. Read_Mutex is used for viewing storage content without modification. Write_Mutex is used for full access.

type Read_Mutex is new Access_Mutex with private;
type Write_Mutex is new Access_Mutex with private;

An operation that requires access to Storage_Object that might require data base communication should do it as follows:

declare
  
Transaction : Write_Mutex (DB'Access);
begin
 
  -- Do something with DB
  
Commit (Transaction);
end
;

When Commit is not called on Transaction, because of exception propagation for instance, then Roll_Back will be in the course of Transaction finalization.

type Sharing_Type is (Fully, Read_Only, Read_Write);

Operations defined on mutexes:

procedure Commit (Mutex : in out Access_Mutex);

This procedure is basically one call:

Commit (Mutex.Storage.all);

Commit can be called only once. Multiple commits cause Use_Error propagation. Any other exception indicates a data base error.

procedure Finalize (Mutex : in out Access_Mutex);

The destructor calls Roll_Back if no Commit was called before. This ensures data base consistency upon transaction errors.

Operations defined on keys. Normally an implementation of a persistent storage would provide a derived key type. That should override the following abstract operations:

function Image
         (  Storage : Data_Bank_Object'Class;
            Key     : Persistent_Key
         )  return String is abstract;

This function returns a string unambiguously identifying Key in Storage. Constraint_Error is propagated when Key cannot be used for Storage.

function Null_Key return Persistent_Key is abstract;

This function returns a value that serves as an illegal key which can never indicate an object.

function Value
         (  Storage : Data_Bank_Object;
            Key     : String
         )  return Persistent_Key'Class is abstract;

This function converts string to a key. Data_Error is propagated when Key does not identify a valid key for Storage. The implementation should not check for any objects existing under the key.

function "<" (Left, Right : Persistent_Key)
   return Boolean is abstract;
function "=" (Left, Right : Persistent_Key)
   return Boolean is abstract;

Persistent keys are comparable to provide ordered containers.

Operations defined on arrays of keys. The following abstract operations shall be overridden by an implementation:

function Get
         (  Container : Persistent_Key_Array;
            Index     : Integer
         )  return Persistent_Key'Class is abstract;

This function returns a key by its index. Contraint_Error is propagated when index is wrong.

procedure Put
          (  Container : in out Persistent_Key_Array;
             Index     : Integer;
             Key       : Persistent_Key'Class
          )  is abstract;

This procedure places Key at the position in the array Container specified by Index. The array is expanded as necessary. When an implementation chooses a dense representation of the array it is allowed to fill unspecified array elements with Null_Key, which can be returned by Get without raising Constraint_Error.

Operations defined to handle transactions. Data_Bank_Object declares abstract operations on persistent storage supporting transaction framework:

function Get_Access_Mode (Storage : Data_Bank_Object)
   return Sharing_Type is abstract;

This function returns present sharing mode to Storage.

procedure Commit (Storage : in out Data_Bank_Object) is abstract;

This abstract procedure is called at the end of each transaction: an atomic modification of the persistent storage. There should be no difference between Roll_Back and Commit if the transaction was initiated by Seize_Read. Normally, Commit is never called directly, but only through Commit of a mutex object.

Exceptions
Data_Error Data base error
Use_Error No transaction active

procedure Roll_Back (Storage : in out Data_Bank_Object) is abstract;

This procedure is called when a transaction fails, due to an exception. It is always called from an exception handler which re-raises the exception. For this reason it is not recommended to raise any exceptions in Roll_Back. There is no difference between Roll_Back and Commit if the transaction was initiated by Seize_Read. For a transaction initiated by Seize_Write an implementation should discard any changes made.

procedure Seize_Read
          (  Storage : in out Data_Bank_Object
          )  is abstract;

This procedure is called to initiate a read-only transaction with Storage. Only one transaction can be active at a time. The transaction is finished by either a call to Commit or to Roll_Back. For a read-only transaction there should be no sufficient difference between Commit and Roll_Back

Exceptions
Data_Error Data base error
Use_Error A transaction is already active (optional)

procedure Seize_Write
          (  Storage : in out Data_Bank_Object
          )  is abstract;

This procedure is called to initiate a read/write transaction with Storage. Only one transaction can be active at a time. The transaction is finished by either a call to Commit or to Roll_Back.

Exceptions
Data_Error Data base error
Use_Error A transaction is already active (optional)

Operations defined in terms of keys. It is recommended to check active transaction in implementations of abstract operations and to raise Use_Error. Though it is not mandatory. Carefully observe that object key is a class-wide parameter. An implementation would usually check if the key's specific type is one supported by the data base. If it is not then End_Error should be used to indicate an absent object, except when otherwise is explicitly specified.

The following operations should be implemented:

procedure Delete
          (  Storage : in out Data_Bank_Object;
             Key     : Persistent_Key'Class
          )  is abstract;

This procedure deletes an object by its key. An implementation may proceed from the assumption that all dependent objects are already deleted and no object refers to the deleted one. It can be called only within a transaction following a call Seize_Write.

Exceptions
Data_Error Data base error
Use_Error No write transaction active (optional)

function Find
         (  Storage : access Data_Bank_Object;
            Name    : Wide_String;
            Parent  : Persistent_Key'Class
         )  return Persistent_Key'Class is abstract;

This procedure is used to determine the object's key by the object's name and the key of its immediate parent. It is allowed only within a transaction initiated either by Seize_Read or Seize_Write. The result is Null_Key when the object does not exist.

Exceptions
Data_Error Data base error
End_Error No such table (optional)
Use_Error No transaction active (optional)

function Get
         (  Storage : access Data_Bank_Object;
            Key     : Persistent_Key'Class
         )  return Deposit_Handle is abstract;

This procedure restores a persistent object by its key. An implementation shall check if the object for the specified key is already memory-resident. It is allowed to call only within a transaction initiated either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object
Use_Error No transaction active (optional)

procedure Get_Children
          (  Storage  : in out Data_Bank_Object;
             Key      : Persistent_Key'Class;
             Children : in out Persistent_Key_Array'Class;
             Pointer  : in out Integer
          )  is abstract;

Implementation adds the keys of the immediate children of the object specified by Key into the array Children. The first item is placed at Pointer. Then Pointer is advanced. Get_Children is allowed to call only within a transaction initiated either by Seize_Read or Seize_Write. An implementation need not to check that, but if it does then Use_Error should indicate failed check.

Exceptions
Data_Error Data base error
Use_Error No transaction active (optional)

function Get_Class
         (  Storage    : in out Data_Bank_Object;
            Key        : Persistent_Key'Class;
         )  return String is abstract;

Implementation returns the object's class. The function is allowed only within a transaction initiated either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object
Use_Error No transaction active (optional)

function Get_Creation_Time
         (  Storage    : in out Data_Bank_Object;
            Key        : Persistent_Key'Class;
         )  return Time is abstract;

Implementation returns the object's creation time. The function is allowed only within a transaction initiated either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object
Use_Error No transaction active (optional)

procedure Get_Data
          (  Storage    : in out Data_Bank_Object;
             Key        : Persistent_Key'Class;
             Class      : out Unbounded_String;
             Data       : out Unbounded_String;
             Parameters : out Unbounded_String
          )  is abstract;

Implementation returns the object's description stored in Storage under Key. The description is used to restore the object. The output parameters are the object's class and data as they were generated by Object.Archived.Store and internally used Parameters, which describe the dependency list of the object being restored. The procedure is allowed only within a transaction initiated either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object
Use_Error No transaction active (optional)

function Get_Dependant
         (  Storage : access Data_Bank_Object;
            Key     : Persistent_Key'Class;
            No      : Positive
         )  return Persistent_Key'Class is abstract;

This function is used to enumerate objects having backward links to the object specified by Key. That are ones which have specified the object in the list of backward links (the parameter Backward_Links of Store and Update). All dependants are enumerated starting from 1. The parameter No specifies the number of a dependant to get. An implementation is allowed to use a cache, so the caller should not undertake any actions which may lead to updating the dependency list of the object. The function is allowed only within a transaction initiated either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
End_Error No dependant found, end of list, no such object
Use_Error No transaction active (optional)

function Get_Name
         (  Storage : access Data_Bank_Object;
            Key     : Persistent_Key'Class;
            Parent  : access Persistent_Key'Class
         )  return String is abstract;

Implementation returns the object's name stored in Storage under Key. The result is UTF-8 encoded. When the object has a parent, then the implementation sets Parent to the key of. Otherwise it sets Null_Key there. The function is allowed only within a transaction initiated either by either by Seize_Read or Seize_Write

Exceptions
Constraint_Error The type of Parent does not match one of the object's parent
Data_Error Data base error
End_Error No such object
Name_Error Anonymous object
Use_Error No transaction active (optional)

procedure Get_References
          (  Storage    : in out Data_Bank_Object;
             Key        : Persistent_Key'Class;
             References : in out Persistent_Key_Array'Class;
             Pointer    : in out Integer
          )  is abstract;

Implementation adds the keys of the immediate the objects referenced by the object specified by Key into the array References. The first item is placed at Pointer. Then Pointer is advanced. An implementation need not to go after the references of the references. The procedure Get_References is allowed to call only within a transaction initiated either by Seize_Read or Seize_Write. An implementation need not to check that, but if it does then Use_Error should indicate failed check.

Exceptions
Data_Error Data base error
Use_Error No transaction active (optional)

function Has_Dependants
         (  Storage   : access Data_Bank_Object;
            Key       : Persistent_Key'Class;
            All_Links : Boolean
         )  return Boolean is abstract;

An anonymous object that has no dependants can be deleted, but not before its memory-resident counterpart disappears. It counts only direct links to the object when All_Links is false. Otherwise it counts all links, direct and backward. When key does not specify any object, the result is false. This function is allowed only within a transaction initiated either by either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
Use_Error No transaction active (optional)

function Is_In
         (  Storage : access Data_Bank_Object;
            Key     : Persistent_Key'Class
         )  return Boolean is abstract;

This function checks whether Key specify an object persistent in Storage. It is allowed only within a transaction initiated either by either by Seize_Read or Seize_Write

Exceptions
Data_Error Data base error
Use_Error No transaction active (optional)

procedure Put
          (  Storage : in out Data_Bank_Object;
             Key     : Persistent_Key'Class;
             Object  : Deposit'Class
          )  is abstract;

This procedure updates a persistent object by its key. Usually it calls Update for this purpose. It is within a transaction initiated by Seize_Write

Exceptions
Data_Error Data base error
End_Error Key does not identify an object
Use_Error No write transaction active (optional)

procedure Rename
          (  Storage : in out Data_Bank_Object;
             Key     : Persistent_Key'Class;
             Name    : Wide_String;
             Parent  : Persistent_Key'Class
          )  is abstract;

This procedure changes the name of the object specified by Key to Name. The object's parent is specified by the parameter Parent. It is specified as Null_Key for a root-level object. When the renamed object was anonymous before renaming it becomes a named one. I.e. it will not deleted when no more in use. An implementation can proceed from the assumption that the caller has already checked for illegal and conflicting names. This procedure is allowed only within a transaction initiated by Seize_Write.

Exceptions
Data_Error Data base error
End_Error Key does not identify an object (optional)
Name_Error Name conflict, there is another object named so (optional)
Use_Error No write transaction active (optional)

function Store
         (  Storage        : access Data_Bank_Object;
            Name           : String;
            Parent         : Persistent_Key'Class;
            Class          : String;
            Data           : String;
            Parameters     : String;
            Direct_Links   : Deposit_Set;
            Backward_Links : Deposit_Set
         )  return Persistent_Key'Class is abstract;
function Store
         (  Storage        : access Data_Bank_Object;
            Class          : String;
            Data           : String;
            Parameters     : String;
            Direct_Links   : Deposit_Set;
            Backward_Links : Deposit_Set
         )  return Persistent_Key'Class is abstract;

These functions are used to write a persistent object. They are called internally. The parameters Name and Parent specify the name of the object in the storage and its parent. The name should be an unique UTF-8 encoded name. When not specified, the object is anonymous. The parameter Data contains a string unambiguously describing the object of the class specified by the parameter Class. It is normally obtained using Object.Archived.Store. Parameters is used to store additional information about links. The parameters Direct_Links and Backward_Links define the set of objects in Storage the object depends on. Objects mentioned in the set Backward_Links are those which can be deleted without deletion of the object itself. The union of Direct_Links and Backward_Links specifies only directly visible dependencies, it is nCocsure. An implementation usually stores Class and Data under the name Name and corrects a persistent dependency table according to Direct_Links and Backward_Links. Note that initially written object is not referenced. Store is allowed only within a transaction by Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object
Use_Error No write transaction active (optional)

procedure Unname
          (  Storage : in out Data_Bank_Object;
             Key     : Persistent_Key'Class
          )  is abstract;

This procedure makes the object specified by Key anonymous. The object object should be automatically deleted when no more in use, but not before it has a memory-resident counterpart. An implementation can proceed from the assumption that the caller already checked for object existence. The procedure is allowed only within a transaction by Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object (optional)
Use_Error No write transaction active (optional)

procedure Update
          (  Storage        : in out Data_Bank_Object;
             Key            : Persistent_Key'Class;
             Class          : String;
             Data           : String;
             Parameters     : String;
             Direct_Links   : Deposit_Set;
             Backward_Links : Deposit_Set
          )  is abstract;

This procedure is used to update a modified persistent object. It is called internally. The parameter Data contains a string unambiguously describing the object of the class specified by the parameter Class. Parameters is used internally to store additional information about links. It is normally obtained using Object.Archived.Store. The parameters Direct_Links and Backward_Links are same as in Store. An implementation would normally update Class and Data in the object's record and correct persistent dependency table. Update is allowed only within a transaction by Seize_Write

Exceptions
Data_Error Data base error
End_Error No such object (optional)
Use_Error No write transaction active (optional)

2.9.3. Storage index

The child generic package Persistent.Data_Bank.Index implements an index of persistent objects:

generic
   type Data_Bank is abstract new Data_Bank_Object with private;
   type Key is new Persistent_Key with private;
package Persistent.Data_Bank.Index is
   type
Catalogue (Storage : access Data_Bank'Class) is
      new
Ada.Finalization.Limited_Controlled with private;
   type Catalogue_Ptr is access all Catalogue;
   ...

Persistent objects having memory-resident counterparts are said to be bound. For each bound object the storage index of the Catalogue type contains a record. When an object is requested from the persistent storage it is first searched in the index. The index also contains information about object's keys and names. Additionally the index registers a notification object to catch bound objects destruction. Upon destruction of a bound object index checks if the object was anonymous and no more referenced in the persistent storage, if so the object is deleted from the storage. If the memory-resident object was modified it is synchronized with the storage.

The package has two generic parameters:

2.9.4. Indexed storage

The child generic package Persistent.Data_Bank.Indexed implements persistent storage interface using the operations defined in Persistent.Data_Bank:

generic
   type Data_Bank is abstract new Data_Bank_Object with private;
   type Key is new Persistent_Key with private;
package Persistent.Data_Bank.Indexed is ...

The generic parameters:

The package provides the abstract type Indexed_Storage_Object which can be used as the base type for a concrete implementation of a data base interface:

type Indexed_Storage_Object is abstract new Data_Bank with private;

The derived type shall implement the following remaining operations:

Tasking. The implementation provided by default is task-safe. The operations on  Indexed_Storage_Object can be called from concurrent tasks. An unsafe implementation is provided in the subdirectory single-task. The implementation choice in GNAT Ada projects is controlled by the variable "Tasking." When compiled manually or with a compiler other than GNAT, the corresponding implementation must be chosen manually.

2.9.5. Proxy objects

Persistent objects that are not fully represented by their memory-resident counterparts require a reference to the storage they persist in. This is necessary at least to prevent persistent storage interface object from being prematurely destroyed. Further the operation Object.Archived.Restore does not contain a parameter referencing the storage. Special objects of the type Self_Reference defined in the child package Persistent.Data_Bank.Reference serve this purpose. An object may put a Self_Reference in its dependency list (see Object.Archived.Get_Referents) by calling the procedure Add from this package. If it does so then in its Restore it will find a Self_Reference again. The fields of that object denote the persistent storage and the object's key there.

type Self_Reference is new Deposit with record
   Storage : Storage_Handle;
   Key     : Persistent_Key_Ptr;
end record;

The following operations are defined on Self_Reference:

procedure Add
          (  List    : in out Deposit_Container'Class;
             Storage : Storage_Handle;
             Key     : Persistent_Key'Class
          );

This procedure adds to List a reference to Storage. Key is the Storage key of the object that requires a reference to Storage. The reference is placed at the list end. Other operations are implementations of the interface defined in Object.Archived.

The following sample code illustrates using Self_Reference objects. A user-defined persistent object is Proxy_Object. It contains a handle to the storage where it persists and implements some of its operations through communication to the storage. For example, it can be a large array of data stored there. When a piece of data is requested Proxy_Object routes the request to the storage and returns the result. Additionally Proxy_Object contains its key in the storage. Proxy_Object should call Add from its Get_Referents to add reference to the storage in its dependency list. Then upon restore it will find a Self_Reference object in the list passed to its Restore:

type Proxy_Object is new Deposit with record
   Storage : Storage_Handle; -- The storage used
   Key     : Storage_Key;    -- The storage key of the object
   ... 
end record;

procedure
Get_Referents
          (  Object : Proxy_Object;
             List   : in out Deposit_Container'Class
          )  is
begin

   Add
   (  List,
      Object.Storage,
      Object.Key
   );
   ... -- adding other dependencies if any
end Get_Referents;

procedure Restore
          (  Source  : String;
             Pointer : in out Integer;
             Class   : String;
             List    : Deposit_Container'Class;
             Object  : out Deposit_Ptr
          )  is
   Object    : Deposit_Ptr := new Proxy_Object;
   Proxy     : Proxy_Object renames Proxy_Object (Result.all);
   Reference : Self_Reference'Class renames
                  Self_Reference'Class (Get (List, 1).all);
begin
   Proxy.Storage := Reference.Storage;
   Proxy.Key     := Storage_Key (Reference.Key.all);
   ... -- restoring the rest of Proxy_Object as necessary
end Restore;

[Back][TOC][Next]

2.10. Visual browsing of a persistent storage

The package Gtk.Persistent_Storage_Browser provides GTK+ widgets for visual browsing of persistent storages. It is a part of the GtkAda contribution software.

[Back][TOC][Next]

2.11. Blocking files

The package Persistent.Blocking_Files provides blocking access file based on the package Direct_IO from the standard library. The file consists of fixed-size blocks which can be mapped onto the memory cache and accessed there. The size of the cache can be specified upon file opening. When a file block is read it is stored in the cache. On a next read attempt the block is accessed from the cache if the block is still there. Updates of a block in the cache does not cause physical output until the file is closed or else the cache is flushed.

The package defines the following constants and types:

Byte_Offset_Bits : constant := implementation defined;

The number of bits used for the byte offset within the block.

Block_Byte_Size : constant := 2 ** Byte_Offset_Bits;

The size of a block in bytes.

type Byte_Index is mod 2 ** 64;

The index type used to point to bytes of the file. The first file byte has the index 0.

type Block_Offset is mod Block_Byte_Size;

This is the index type used within the block.

type Block_Count is implementation defined;
subtype Block_Index is Block_Count range 1..Block_Count'Last;

The type Block_Count is to count file blocks. The type Block_Index is used to enumerate blocks of a file. The first block has the index 1.

type Block_Type is array (Block_Offset) of Unsigned_8;
type Block_Type_Ptr is access all Block_Type;
type Block_Type_Ref is access constant Block_Type;

This is the type of the block.

type Access_Mode is (Read_Mode, Read_Write_Mode, Create_Mode);

The modes of access to the file:

type Persistent_Array is
   new
Ada.Finalization.Limited_Controlled with private;

This type is used to access a blocking file.

Note that the implementation of Persistent_Array is not task-safe. If an object of this type is to be used from concurrent tasks its operations must be called mutually exclusively.

 The following operations are defined on the type.

procedure Close (Container : in out Persistent_Array);

This procedure is used to close file previously opened with Open. All updated cached blocks are written back to the file before it is physically closed. I/O exceptions are propagated on errors.

function Compose
         (  Index  : Block_Index;
            Offset : Block_Offset
         )  return Byte_Index;

This function byte index corresponding to the block Index and the offset Offset within the block. See also Get_Index and Get_Offset.

procedure Finalize (Container : in out Persistent_Array);

This procedure is called upon object finalization. The implementation calls Close. When overridden by a derived type, it must be called from the derived type implementation.

procedure Flush (Container : in out Persistent_Array);

This procedure writes all updated blocks from the cache back to the file. I/O exceptions are propagated on errors.

function Get
         (  Container : access Persistent_Array;
            Index     : Byte_Index
         )  return Block_Type_Ptr;

This function returns a pointer to the block corresponding to Index. The index is zero based byte offset it can point anywhere in the block. The block is read into the memory as necessary. When the file already contains the block corresponding to Index in the file the function is equivalent to Update. Otherwise the procedure allocates a new block. The block is marked as updated. It is written back to the file once removed from the memory. Use_Error is propagated when no file is open or else when the file is opened in read-only mode. I/O exceptions are propagated on other errors. See also Load, Update.

function Get_Block_Size
         (  Pool : Persistent_Array
         )  return Byte_Count;

This function returns file size in blocks. Use_Error is propagated when no file open.

function Get_Index (Index : Byte_Index) return Block_Index;

This function returns the file block number corresponding to Index. See also Compose.

function Get_First (Index : Byte_Index) return Byte_Index;

This function returns the offset to the first byte of the block corresponding to Index.

function Get_Name (Container : Persistent_Array) return String;

This function returns name of the file when the file is open. Otherwise Use_Error is propagated.

function Get_Offset (Index : Byte_Index) return Block_Offset;

This function returns the offset corresponding to Index when the block is loaded in the memory. See also Compose.

function Get_Size (Container : Persistent_Array) return Byte_Index;

This function returns the file size in bytes. Use_Error is propagated when no file open.

function Is_Open (Container : Persistent_Array) return Boolean;

This function returns true if the file was open with Open.

function Is_Resident
         (  Container : Persistent_Array;
            Index     : Byte_Index
         )  return Boolean;
function
Is_Resident
         (  Container : Persistent_Array;
            Index     : Block_Index
         )  return Boolean;

This function returns true if the block corresponding to Index is memory-resident.

function Is_Writable (Container : Persistent_Array) return Boolean;

This function returns true if the file was open with Open for writing.

function Load
         (  Container : access Persistent_Array;
            Index     : Byte_Index
         )  return Block_Type_Ref;

This function returns a pointer to the block corresponding to Index. The index is zero based byte offset it can point anywhere in the block. The block is read into the memory as necessary. The result is an immutable pointer, so the function can be used for read-only files. If the file does not have a block corresponding to Index, the result is null. Use_Error is propagated when no file is open. I/O exceptions are propagated on other errors. See also Get, Update.

procedure Open
          (  Container : in out Persistent_Array;
             Name      : String;
             Mode      : Access_Mode := Read_Mode;
             Hash_Size : Positive    := 256;
             Form      : String      := ""
          );

This procedure opens a file specified by Name. Hash_Size specifies the number of blocks kept resident in the memory. Mode is the access mode. Form is the OS-specific parameters to use when opening the file. I/O exceptions are propagated on errors.

procedure Open
          (  Container : in out Persistent_Array;
             Hash_Size : Positive := 256;
             Form      : String   := ""
          );

This variant of Open is used to create a temp file.

procedure Read
          (  Container : in out Persistent_Array;
             Index     : Byte_Index
             Block     : out Block_Type
          );

This procedure is used to explicitly read a block corresponding to Index working around the memory cache. The index is zero based byte offset it can point anywhere in the block. The block is read into Block. If the block was memory-resident, it is taken from there and then removed from the cache in order to prevent duplicity. End_Error is propagated if the file does not have a block containing Index. Use_Error is propagated when no file is open. I/O exceptions are propagated on other errors. See also Write.

function Update
         (  Container : access Persistent_Array;
            Index     : Byte_Index
         )  return Block_Type_Ptr;

This function returns a pointer to the block corresponding to Index. The index is zero based byte offset it can point anywhere in the block. The result is a mutable pointer, so the function can be used only for files opened for writing. The block is read into the memory as necessary and marked as updated. It is written back to the file once removed from the memory. If the file does not have a block containing Index, the result is null. Use_Error is propagated when no file is open or when file is open read-only. I/O exceptions are propagated on other errors. See also Get, Load.

procedure Write
          (  Container : in out Persistent_Array;
             Index     : Byte_Index;
             Block     : Block_Type
          );

This procedure is used to explicitly write a block corresponding to Index working around the memory cache. The index is zero based byte offset it can point anywhere in the block. The block is rewritten with the contents of Block. If the block was memory-resident, it is removed from there any changes made are discarded. If the file does not have a block containing Index, it is padded with blocks which contents is set to the one of Block. Use_Error is propagated when no file is open or when file is open read-only. I/O exceptions are propagated on other errors. See also Read.

2.11.1. Text I/O

The package Persistent.Blocking_Files.Text_IO provides output operations for byte index and byte offset.

procedure Get
          (  Source  : in String;
             Pointer : in out Integer;
             Value   : out Byte_Index
          );

This procedure gets byte index from the string Source. The process starts from Source (Pointer). The parameter Base indicates the base of the expected number. The exception Constraint_Error is propagated if block number or byte offset is out of range. Data_Error indicates a syntax error in the number. End_Error is raised when no number was detected. Layout_Error is propagated when Pointer is not in the range Source'First .. Source'Last + 1.

function Image
         (  Value      : Byte_Index;
            Put_Offset : Boolean := True
         )  return String;

This function returns textual representation of Value. When Put_Offset is true both the block number and the hexadecimal offset within the block are output. Otherwise, it is only the block number.

function Image (Value : Block_Offset) return String;

This function returns textual representation byte offset Value in a block.

function Image (Value : Block_Count) return String;

This function returns textual representation block number Value.

procedure Put
          (  Destination : in out String;
             Pointer     : in out Integer;
             Value       : Byte_Index;
             Put_Offset  : Boolean   := True;
             Field       : Natural   := 0;
             Justify     : Alignment := Left;
             Fill        : Character := ' '
          );

This procedure outputs Value starting from Destination (Pointer). Pointer is advanced after the output. Field, Justify and Fill control output. Layout_Error is propagated when there is no room for output or Pointer is invalid. When Put_Offset is true both the block number and the hexadecimal offset within the block are output. Otherwise, it is only the block number.

procedure Put
          (  Destination : in out String;
             Pointer     : in out Integer;
             Value       : Byte_Offset;
             Field       : Natural   := 0;
             Justify     : Alignment := Left;
             Fill        : Character := ' '
          );

This procedure outputs Value starting from Destination (Pointer). Pointer is advanced after the output. Field, Justify and Fill control output. Layout_Error is propagated when there is no room for output or Pointer is invalid.

procedure Put
          (  Destination : in out String;
             Pointer     : in out Integer;
             Value       : Block_Count;
             Field       : Natural   := 0;
             Justify     : Alignment := Left;
             Fill        : Character := ' '
          );

This procedure outputs Value starting from Destination (Pointer). Pointer is advanced after the output. Field, Justify and Fill control output. Layout_Error is propagated when there is no room for output or Pointer is invalid.

function Value (Source : String) return Byte_Index;

This function gets byte index from the string Source. The index can be surrounded by spaces and tabs. The whole string Source should be matched. Otherwise the exception Data_Error is propagated. Also Data_Error indicates a syntax error in the block number or byte offset. The exception Constraint_Error is propagated if the number is not in the range First..Last. End_Error is raised when no number was detected.

[Back][TOC][Next]

2.12. Transactional blocking files

The package Persistent.Blocking_Files.Transactional provides Persistent_Transactional_Array, a variant of Persistent_Array, supporting transactions. A transaction is an atomic file update. Database transactions must be atomic, consistent, isolated and durable. Transactions on Persistent_Transactional_Array have similar properties:

The implementation maps virtual file blocks as seen by the application onto physical file blocks. When a virtual block is updated its physical counterpart is not changed on the disk. Instead of that an unused physical block is allocated and the virtual block is remapped to it. This new physical block is kept overwritten until closing the transaction. The old physical block is said disposed. A disposed block is not changed until an end of the transaction. When the transaction is committed the disposed physical block becomes free to use. When the transaction is rolled back the new block is discarded and becomes free and the disposed block takes its place. Since the physical blocks are not changed during the transaction a system crash before committing it rolls the file, as viewed by the application, back.

The virtual to physical block mapping is stored in the file's physical blocks in the form of segments. Each segment fits one physical block. Changes to the mapping are a part of the transaction.

When the whole map does not fit into a single segment it is split into several segments referenced from the segment of the next level. The depth of this segment tree does not necessarily means that the tree should be actually traversed in order to obtain the physical block. If the segment of the lowest level is already in the memory it is used directly to resolve the virtual block number. Only when the segment is not in the memory the segment of the next level is referenced in order to get the physical block containing the missing segment. Thus the tree is fully traversed only when none of the segments along the path is in the memory. The root segment is always in the memory.

The package defines the file type:

type Persistent_Transactional_Array is
   new
Persistent_Array with private;

This type is used to access a blocking file.

Note that the implementation of Persistent_Transactional_Array is not task-safe. If an object of this type is to be used from concurrent tasks its operations must be called mutually exclusively.

 The following operations are defined on the type.

procedure Close (Container : in out Persistent_Transactional_Array);

This procedure is used to close file previously opened with Open. The pending transaction is rolled back. I/O exceptions are propagated on errors.

procedure Commit (Container : in out Persistent_Transactional_Array);

This procedure commits current transaction and opens a new one.

procedure Finalize (Container : in out Persistent_Transactional_Array);

This procedure is called upon object finalization. The implementation calls Close. When overridden by a derived type, it must be called from the derived type implementation.

procedure Flush (Container : in out Persistent_Transactional_Array);

This procedure writes all updated blocks from the cache back to the file. It is equivalent to Commit. I/O exceptions are propagated on errors.

function Get_Allocated_Size
         (  Container : Persistent_Transactional_Array
         )  return Byte_Index;

This function returns the total physical size of the file in bytes. The function Get_Size returns the total virtual size of the file. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

function Get_Disposed_Blocks
         (  Container : Persistent_Transactional_Array
         )  return Block_Count;

This function returns the number of disposed physical blocks. Disposed blocks cannot be reused during current transaction. They become available when the transaction is committed. When the transaction is rolled back the disposed blocks become used again. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

function Get_Free_Blocks
         (  Container : Persistent_Transactional_Array
         )  return Block_Count;

This function returns the number of free physical blocks. When there is no free blocks new blocks are acquired by expanding the file. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

function Get_Map_Depth (Size : Byte_Index) return Natural;

This function returns depth of the virtual to physical mapping. The mapping is organized in segments fitting a file block. When the map does not fit into single segment it is split into several segments all reverenced from the segment of the next level. The depth is the number of levels in this tree including the root segment.

function Get_Map_Size (Size : Byte_Index) return Natural;

This function returns the size of virtual to physical map needed for 1..Size bytes. The result -1 can be used as the Map_Size parameter of Open.

function Get_Physical
         (  Container : Persistent_Transactional_Array;
            Virtual   : Block_Index
         )  return Block_Count;

This function returns the physical block corresponding to Virtual. When the block is not mapped the result is 0. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

function Get_Sequence_No
         (  Container : Persistent_Transactional_Array
         )  return Unsigned_64;

This function returns current transaction number. Each transaction has an unique sequence number. Use_Error is propagated when no file open.

function Get_Used_Size
         (  Container : Persistent_Transactional_Array
         )  return Byte_Index;

This function returns the total number of used file bytes. It can be less than the total file size returned by Get_Allocated_Size. It is greater than the virtual file size returned by Get_Size. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

function Is_Updated
         (  Container : Persistent_Transactional_Array;
            Virtual   : Block_Index
         )  return Boolean;

This function returns true if the file block Virtual was updated. All updated blocks are committed or rolled back upon transaction completion. Use_Error is propagated when no file open. I/O exceptions are propagated on errors.

procedure Open
          (  Container : in out Persistent_Transactional_Array;
             Name      : String;
             Mode      : Access_Mode := Read_Mode;
             Hash_Size : Positive    := 256;
           [ Map_Size  : Positive; ]
             Form      : String      := ""
          );

This procedure opens a file specified by Name. Mode is the file access mode. Hash_Size specifies the number of virtual blocks kept resident in the memory. Map_Size specifies how many segments of the virtual-to-physical mapping are kept cached in the memory. The root segment is always cached. It is recommended that the whole mapping were memory-resident, but for very large files this might be impossible. Get_Map_Size can be used to estimate the required space. Form is the OS-specific parameters to use when opening the file. I/O exceptions are propagated on errors.

procedure Open
          (  Container : in out Persistent_Transactional_Array;
             Hash_Size : Positive := 256;
           [ Map_Size  : Positive; ]
             Form      : String   := ""
          );

This variant of Open is used to create a temp file.

procedure Rollback (Container : in out Persistent_Transactional_Array);

This procedure rolls back current transaction. I/O exceptions are propagated on errors.

2.12.1. Textual output of internal structures

The package Persistent.Blocking_Files.Transactional.Dump provides procedures to output internal structures of a transactional file. The flags controls the output:

type Dump_Flags is mod 2**5;
Dump_General_Information  : constant Dump_Flags := 2**0;
Dump_Virtual_Block_Map    : constant Dump_Flags := 2**1;
Dump_Block_Map_Segments   : constant Dump_Flags := 2**2;
Dump_Free_Blocks_List     : constant Dump_Flags := 2**3;
Dump_Disposed_Blocks_List : constant Dump_Flags := 2**4;
Dump_All                  : constant Dump_Flags := Dump_Flags'Last;

The procedures defined in the package are:

procedure Put
          (  File      : File_Type;
             Container : Persistent_Transactional_Array'Class;
             Flags     : Dump_Flags := Dump_All
          );
procedure Put
          (  Container : Persistent_Transactional_Array'Class;
             Flags     : Dump_Flags := Dump_All
          );

The parameter File is the file to output into. If omitted the standard output is used. Container is the object to output. Flags controls the output.


[Back][TOC][Next]

3. Sets and Maps

The packages Generic_Set and Generic_Map provide sets and associative arrays of private types. Objects in a set are directly comparable which makes them distinguishable and so allows to decide whether an object is in a set or not. Objects in a map are indistinguishable and so an additional object called key is associated with each object in the map. In other words a map represents a mapping key to object. Both sets and maps are implemented using reference counting which allows a relatively efficient assigning of sets and maps.

Note that only objects of non-limited type can be used in sets and maps. To have sets of limited objects use pointers or handles as elements. For sets of handles also see Object.Handle.Generic_Set. For maps of strings see Tables.

[Back][TOC][Next]

3.1. Sets

The package Generic_Set defines the type Set. An instance of the type is a set of items. One can add to and remove from items of the set. Items of the set can be accessed using the positive index. They are ordered, so the set implementation may use binary search. There is a null item, which is never included into the set and is used to mark free memory slots. The package is generic and has the following generic parameters:

generic
   type Object_Type is private;
   Null_Element : Object_Type;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
   with function "<" (Left, Right : Object_Type) return Boolean is <>;
   with function "=" (Left, Right : Object_Type) return Boolean is <>;
package Generic_Set is
   type
Set is new Ada.Finalization.Controlled with private;
   ...

Here:

Sets can be assigned. Assignment makes no deep copy, which is delayed until the time moment when the original and a copy become different. Items in the set are ordered so that lesser items have lesser indices, when indexed. The first item in the set has index 1.

Note that Generic_Set cannot be instantiated with Object_Type set to Integer or any its subtype. This feature is per design for safety reasons. The elements in the set are enumerated by Integer, so if sets of Integer are required then the Object_Type must be made different from Integer. For example as.
type Integer_Object is new Integer;
package Integer_Sets is
   new
Generic_Set (Object_Type => Integer_Object, ...);

The following operations are defined on Set:

procedure Add (Container : in out Set; Item  : Object_Type);
procedure
Add (Container : in out Set; Items : Set);

These procedures are used to add an item to a set or all items of one set to another. Nothing happens if the item is already in the set or is a Null_Element. Note that items are compared using the provided operations "<" and "=". It is possible that these operations treat different items as same. Only one item from such equivalence class may be in a set. To control which one will be inserted use Insert and Replace.

function Create return Set;

This function returns an empty set.

procedure Erase (Container : in out Set);

This procedure removes all items from the set.

function Find (Container : Set; Item : Object_Type)
   return Integer;

This function is used to find an item in the set Container. The result is either a positive index of the found item or a negated index of the place where the item should be if it were in the set.

function Get (Container : Set; Index : Positive)
   return Object_Type;
This function is used to get an item of the set Container using a positive index. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Set) return Natural;

This function returns the number of items in the set.

procedure Insert (Container : in out Set; Item : in out Object_Type);

This procedure inserts an item into a set. Nothing happens if the item is Null_Element. When Container already has an element equivalent to Item, then Item will not replace it. Instead of that the element from Container will be returned through Item. So upon completion Item always has the value of the element in Container.

procedure Insert (Container : in out Set; Item : Object_Type; Inserted : out Boolean);

This procedure inserts an item into a set. Item is inserted only if it is not Null_Element and is not already in Container. When inserted Inserted is set to true. Otherwise it is to false..

function Is_Empty (Container : Set) return Boolean;

True is returned if Container is empty.

function Is_In (Container : Set; Item : Object_Type)
   return Boolean;

True is returned if Item is in Container.

procedure Remove (Container : in out Set; Item  : Object_Type);
procedure Remove (Container : in out Set; Items : Set);

These procedures are used to remove items from the set Container. An item can be removed either explicitly, or by specifying a set of items to be removed. If a particular item is not in the set, then nothing happens.

procedure Remove
          (  Container : in out Set;
             Item      : Object_Type;
             Removed   : out Boolean);

This procedure is a variant of the procedure Remove with the third parameter set to true when Item was in the set before its removal. Otherwise it is set to false.

procedure Remove (Container : in out Set; Index : Positive);

This procedures removes an item from the set Container by its positive index. Constraint_Error is propagated when item index is wrong.

procedure Replace (Container : in out Set; Item : Object_Type);
procedure
Replace (Container : in out Set; Items : Set);
These procedures are used to add to / replace in an item or all items of a set. Nothing an is a Null_Element. Any duplicated items are replaced by new ones. This operation has sense only if the equality operation defined on Object_Type does not distinguish some objects.

function "and" (Left, Right : Set) return Set;
function "or"  (Left, Right : Set) return Set;
function "xor" (Left, Right : Set) return Set;

These functions are conventional set operations - intersection, union, difference. Difference is defined as a set which items are only in one of the sets Left and Right.

function "-" (Left, Right : Set) return Set;

This function returns a set containing all elements of Left not present in Right.

function "=" (Left, Right : Set) return Boolean;

True is returned if both sets contain same items.

3.1.1. Sets of indefinite elements

The package Generic_Indefinite_Set is similar to the package Generic_Set, but allows instantiation with an indefinite type:

generic
   type Object_Type (<>) is private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
   with function "<" (Left, Right : Object_Type) return Boolean is <>;
   with function "=" (Left, Right : Object_Type) return Boolean is <>;
package Generic_Set is
   type
Set is new Ada.Finalization.Controlled with private;
   ...

Note that there is no formal parameter Null_Element.

3.1.2 Sets of discrete elements

The package Generic_Discrete_Set is similar to the package Generic_Set provided specifically for discrete types allowing large sets of elements as well as their complement sets:

generic
   type Object_Type is (<>);
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Discrete_Set is
   type
Set is new Ada.Finalization.Controlled with private;
   ...

The set supports adding and removing whole ranges of elements. The set cardinality is not limited, but the number of non-intersecting ranges must be no greater than Integer'Last. differently to the package Generic_Set the elements of the set are enumerated through the ranges 1..Get_Size. The following operations are defined on Set:

procedure Add (Container : in out Set; Item     : Object_Type);
procedure
Add (Container : in out Set; From, To : Object_Type);
procedure
Add (Container : in out Set; Items    : Set);

These procedures are used to add an item, a range of items, all items of one set to another. Nothing happens if an item is already in the set or when From..To is an empty range. Constraint_Error is propagated when From > To such that Object_Type'Pred (From) /= To.

function Create return Set;

This function returns an empty set.

function Create (Item     : Object_Type) return Set;
function Create (From, To : Object_Type) return Set;

These functions return a singleton set containing Item or a set consisting of the range From..To. Constraint_Error is propagated when From > To such that Object_Type'Pred (From) /= To.

procedure Erase (Container : in out Set);

This procedure removes all items from the set.

function Find (Container : Set; Item     : Object_Type) return Integer;
function Find (Container : Set; From, To : Object_Type) return Integer;

This function is used to find an item or a range of items in the set Container. The result is either a positive index of an range containing Item or whole range From..To or a negated index of the place where the item should be if it were in the set. Ranges in the set are ordered according to their lower bounds. Intersecting ranges are considered equal. Constraint_Error is propagated when From > To.

function From (Container : Set; Index : Positive) return Object_Type;
This function returns the lower bound of a range from the set Container using its positive index. Constraint_Error is propagated if Index is wrong.
procedure Get
          (  Container : Set;
             Index     : Positive;
             From      : out Object_Type;
             To        : out Object_Type
          );
This function is used to get a range from the set Container using a positive index. The ranges of elements are enumerated by integers from 1..Get_Size. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Set) return Natural;

This function returns the number of ranges in the set. Elements of a set can be enumerated by enumerating elements from the ranges 1..Get_Size (Container)

function Is_Empty (Container : Set) return Boolean;

This function returns true if Container is empty.

function Is_In (Container : Set; Item     : Object_Type) return Boolean;
function
Is_In (Container : Set; From, To : Object_Type) return Boolean;

This function returns true if Item or whole From..To is in Container.

function Is_Not_In (Container : Set; From, To : Object_Type) return Boolean;

This function returns true if none of the items from From..To is in Container. Both Is_In and Is_Not_In are false when some elements from From..To belong to the set and some do not.

procedure Range_Remove (Container : in out Set; Index : Positive);

This procedure removes a range of elements by its index. Constraint_Error is propagated when Index does not specify any range. The number of elements ranges is obtaining using the function Get_Size.

procedure Remove (Container : in out Set; Item     : Object_Type);
procedure
Remove (Container : in out Set; From, To : Object_Type);
procedure Remove (Container : in out Set; Items    : Set);

These procedures are used to remove items from the set Container. An item can be removed either explicitly, or by specifying a set of items to be removed. If a particular item is not in the set, then nothing happens. When From..To is an illegal or empty range, the operation does nothing.

function To (Container : Set; Index : Positive) return Object_Type;

This function returns the upper bound of a range from the set Container using its positive index. Constraint_Error is propagated if Index is wrong.

function "and" (Left, Right : Set) return Set;
function "or"  (Left, Right : Set) return Set;
function "xor" (Left, Right : Set) return Set;

These functions are conventional set operations - intersection, union, difference. Difference is defined as a set which items are only in one of the sets Left and Right.

function "-" (Left, Right : Set) return Set;

This function returns a set containing all elements of Left not present in Right.

function "=" (Left, Right : Set) return Boolean;

This function returns true is if both sets contain same items.

[Back][TOC][Next]

3.2. Maps

The package Generic_Map defines the type Map which represents an associative array. One can add to and remove from items of the map. Each item has an unique key associated with it. In other word a map is a function which for a given key yields an item. Items of the map can be also accessed using the positive index. Items in the map are ordered according to their keys, so the map implementation may use binary search. Reference counting is used for the objects of the type Map, which means that assigning Map objects is relatively cheap. The package is generic and has the following generic parameters:

generic
   type Key_Type is private;
   type Object_Type is private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Map is
   type
Map is new Ada.Finalization.Controlled with private;
   ...

Here:

Both Key_Type and Object_Type can be controlled. The implementation warranties that when an item or key is no more used in the map it is erased by assigning it a value created by the default constructor (if any). This behavior ensures that items and keys removed from the map will be always finalized upon the operation. For example, when Object_Type is controlled, then Finalize will be called upon an item of Object_Type even if the item is not replaced but removed from a map. This happens through assigning some other object of Object_Type to the removed item. So when item is a Handle, then the reference count of an object it refers will be decreased as expected. On assignment no deep copy of a map is made. Deep copy is postponed till the time moment when the original and a copy become different. Items in the map are ordered according to their keys, so that items with lesser keys have lesser indices, when indexed. The first item in the map has index 1.

Note that Generic_Map cannot be instantiated with Integer or any its subtype as Key_Type. This feature is per design for safety reasons. The objects in the map are enumerated by Integer, so if maps indexed by Integer are required then Generic_Discrete_Map should be used instead or else the Key_Type must be made different from Integer. For example as:
type Integer_Key is new Integer;
package Integer_Maps is
   new
Generic_Map (Key_Type => Integer_Key, ...);

The following operations are defined on the type Map:

procedure Add
          (  Container : in out Map;
             Key       : Key_Type;
             Item      : Object_Type
          );

This procedure adds a new item (Item) to the map Container. Constraint_Error propagates if Container already contains an item with the key equal to Key.

procedure Add (Container : in out Map; Items : Map);

This procedure adds all items of Items to Container. If Container already has an item with the key equal to an item from Items, then that item from Items is ignored.

function Create return Map;

This function returns an empty map.

procedure Erase (Container : in out Map);

This procedure removes all items from Container.

function Find (Container : Map; Key : Key_Type) return Integer;

This function is used to find an item in the map Container. The result is either a positive index of the found item or a negated index of the place where the item should be if it were in the map.

function Get (Container : Map; Key : Key_Type) return Object_Type;

This returns an item of the map Container by its key. Constraint_Error is propagated if there is no item with the key equal to Key.

function Get (Container : Map; Index : Positive) return Object_Type;

This function is used to get an item of the map Container using positive index. Constraint_Error is propagated if Index is wrong. Note that item index may change when items are added or removed.

function Get_Key (Container : Map; Index : Positive) return Key_Type;
This functions returns the key of an item in Container. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Map) return Natural;

This function returns the number of items in the map.

function Is_Empty (Container : Map) return Boolean;

True is returned if Container is empty.

function Is_In (Container : Map; Key : Key_Type)
   return Boolean;

True is returned if Container has an item for Key.

procedure Remove (Container : in out Map; Item  : Key_Type);
procedure Remove (Container : in out Map; Items : Set);

These procedures are used to remove items from the map Container. An item can be removed either by its key, or by specifying a map of items to be removed. If a particular item is not in the map, then nothing happens.

procedure Remove (Container : in out Map; Index : Positive);

This procedures removes an items from the map Container by its positive index. Constraint_Error is propagated when item index is wrong.

procedure Replace
          (  Container : in out Map;
             Key       : Key_Type;
             Item      : Object_Type
          );
procedure
Replace
          (  Container : in out Map;
             Items     : Map
          );
These procedures are used to add or replace items. An can be either added or replaced by its key. That is when Container does contain an item with the key equal to Key, then it is replaced by Item, otherwise Item is added under Key. The second  variant adds or replaces all items from the map Items.
procedure Replace
          (  Container : in out Map;
             Index     : Positive;
             Item      : Object_Type
          );
This procedure replaces an items by its positive index. Contraint_Error is propagated when Index is wrong.

function "=" (Left, Right : Map) return Boolean;

This function returns true is if both parameters map same keys to same items.

3.2.1. Maps of indefinite keys and objects

The package Generic_Indefinite_Map is exactly as the package Generic_Map, but also allows keys and objects of indefinite types:

generic
   type Key_Type (<>) is private;
   type Object_Type (<>) is private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Generic_Map is
   type
Map is new Ada.Finalization.Controlled with private;
   ...

3.2.2. Maps of discrete keys

The package Generic_Discrete_Map is designed to provide maps of discrete keys. The implementation takes advantage of using ranges of keys allowing very large maps. Differently to Generic_Map it maps ranges of keys to object. The ranges are split and merged transparently when individual (key, object) pairs added. The package is generic and has the following generic parameters:

generic
   type Key_Type is (<>);
   type Object_Type is private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Discrete_Map is
   type
Map is new Ada.Finalization.Controlled with private;
   ...

Here:

The following operations are defined on the type Map:

procedure Add
          (  Container : in out Map;
             Key       : Key_Type;
             Item      : Object_Type
          );
procedure Add
          (  Container : in out Map;
             From, To  : Key_Type;
             Item      : Object_Type
          );

This procedure adds to Container a key or a range of keys mapped to the Item. Constraint_Error propagates if Container already maps another item to any of the required keys. It is also propagated when From > To such that Key_Type'Pred (From) /= To.

procedure Add (Container : in out Map; Items : Map);

This procedure adds all items of Items to Container. If Container already has an item with the key equal to an item from Items, then that item from Items is ignored.

function Create return Map;

This function returns an empty map.

function Create (Keym     : Key_Type; Item : Object_Type) return Map;
function Create (From, To : Key_Type; Item : Object_Type) return Set;

These functions return a mapping of the specified keys to Item. Constraint_Error is propagated when From > To such that Object_Type'Pred (From) /= To.

procedure Erase (Container : in out Map);

This procedure removes all items from Container.

function Find (Container : Map; Key      : Key_Type) return Integer;
function Find (Container : Map; From, To : Key_Type) return Integer;

This function is used to find an item mapping by a key or a range keys. The result is either a positive index of an range containing all keys or a negated index of the place where the item should be if it were in the set. Ranges in the map are ordered according to their lower bounds. Intersecting ranges are considered equal. Constraint_Error is propagated when From > To.

function From (Container : Map; Index : Positive) return Key_Type;
This function returns the lower bound of a range of keys the map Container using its positive index. Constraint_Error is propagated if Index is wrong.
function Get (Container : Map; Key : Key_Type) return Object_Type;
This function returns the item corresponding to the specified key. Constraint_Error is propagated if there is no such item.
procedure Get_Key
          (  Container : Map;
             Index     : Positive;
             From      : out Key_Type;
             To        : out Key_Type
          );
This function is used to get a range of keys from the map Container using a positive index. Constraint_Error is propagated if Index is wrong.

function Get_Size (Container : Map) return Natural;

This function returns the number of key ranges in the map.

function Is_Empty (Container : Set) return Boolean;

This function returns true if Container is empty.

function Is_In (Container : Map; Item     : Key_Type) return Boolean;
function
Is_In (Container : Map; From, To : Key_Type) return Boolean;

This function returns true if Item or whole From..To is in Container.

function Is_Not_In (Container : Map; From, To : Object_Type) return Boolean;

This function returns true if none of the keys from From..To is in Container. Note that it both Is_In and Is_Not_In are false when From..To contains keys from the map and keys outside it.

function Range_Get
         (  Container : Map;
            Index     : Positive;
         )  return Object_Type;
This function returns an item corresponding to the range of keys specified by its index. The ranges are enumerated using indices from 1..Get_Size. Constraint_Error is propagated if Index is wrong.

procedure Range_Remove (Container : in out Map; Index : Positive);

This procedure removes a range of keys by its index. Constraint_Error is propagated when Index does not specify any range.

procedure Range_Replace
          (  Container : in out Map;
             Index     : Positive;
             Item      : Object_Type
          );

This procedure replaces a range of keys specified by its index. Constraint_Error is propagated when Index does not specify any range.

procedure Remove (Container : in out Map; Item     : Key_Type);
procedure
Remove (Container : in out Map; From, To : Key_Type);
procedure Remove (Container : in out Map; Items    : Map);

These procedures are used to remove mappings from the set Container. An item can be removed either explicitly, or by specifying a set of items to be removed. If a particular item is not in the set, then nothing happens. When From..To is an illegal or empty range, the operation does nothing.

procedure Replace
          (  Container : in out Map;
             Key       : Key_Type;
             Item      : Object_Type
          );
procedure Replace
          (  Container : in out Map;
             From, To  : Key_Type;
             Item      : Object_Type
          );

This procedure replaces or adds to Container a key or a range of keys mapped to the Item. Constraint_Error is propagated when From > To.

procedure Replace (Container : in out Map; Items : Map);

This procedure replaces or adds all items from Items in Container.

function To (Container : Map; Index : Positive) return Key_Type;

This function returns the upper bound of a range of keys from the set Container using its positive index. Constraint_Error is propagated if Index is wrong.

function "=" (Left, Right : Map) return Boolean;

This function returns true is if both parameters map same keys to same items.

3.2.3. Maps of discrete keys to indefinite objects

The package Generic_Discrete_Indefinite_Map is exactly like Generic_Discrete_Map but allows mapping to the objects of indefinite types (e.g. String):

generic
   type Key_Type is (<>);
   type Object_Type (<>) is private;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Discrete_Indefinite_Map is
   type
Map is new Ada.Finalization.Controlled with private;
   ...

The implementation tries to reuse allocated objects where possible using a reference counting scheme. Thus the same object can be referenced by several ranges of keys. If this behaviour is undesirable, Generic_Indefinite_Map should be used instead. The latter has a separate object for each key.

[Back][TOC][Next]

3.3. B-trees

A B-tree is a map effective for large sets of keys allocated in a storage supporting random access to fixed blocks of memory. B-trees are used for implementation of file systems and databases. A B-tree is balanced. A node of the tree has up to fixed number of keys. Each nodes has a bucket with sorted keys and values. Binary search is used to within the bucket. Keys in the non-leaf nodes have to children. Keys of branch nodes may have up to two children on the left and on the right. The left child and its children contains keys lesser than the key itself. The right one contains greater keys. Adjacent keys in the bucket share the child which is the right child of the first key and the left child of the second key. The keys of subtree rooted in the child are greater than the first key and lesser than the second key. Each child bucked keeps an upward link to its parent. The keys of the tree can be effectively traversed in ascending and descending order.

3.3.1. B-trees of definite keys and objects

The generic package Generic_B_Tree provides an implementation of B-trees with definite keys and values. The package formal parameters are:

generic
   type Key_Type is private;
   type Object_Type is private;
   Width : Positive := 256;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Generic_B_Tree is ...

The generic formal parameters are:

The type of the B-tree is declared as

type B_Tree is new Ada.Finalization.Limited_Controlled with private;

The following operations are defined on the type:

procedure Add
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Value     : Object_Type
          );

This procedure adds new key-value pair to the tree. Constraint_Error is propagated when Key is already present in the tree.

procedure Erase (Container : in out B_Tree);

This procedure removes all pairs from the tree.

procedure Finalize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Find (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function is used to search the tree for given key. The result is a pointer to the found key-value pair or No_Item if the key is not in the tree.

function Get (Container : B_Tree; Key : Key_Type) return Object_Type;

This function is returns the value associated with the key. Constraint_Error is propagated when the key is not in the tree.

function Get_First (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the least key. The result is No_Item if the tree is empty.

function Get_Last (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the greatest key. The result is No_Item if the tree is empty.

function Inf (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-value pair with the key less than or equal to Key. The result is No_Item if the tree is empty.

function Is_Empty (Container : B_Tree) return Boolean;

This function returns true if the tree is empty.

function Is_In (Container : B_Tree; Key : Key_Type) return Boolean;

This function returns true if Key is in the tree.

procedure Remove
          (  Container : in out B_Tree;
             Key       : Key_Type
          );

This procedure removes a key-value pair by the key. Nothing happens if the key is not in the tree.

procedure Replace
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Value     : Object_Type
          );

This procedure adds new key-value pair if Key is not in the tree or else replaces the value in the pair if the Key is already in the tree.

function Sup (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-value pair with the key greater than or equal to Key. The result is No_Item if the tree is empty.

function "=" (Left, Right : B_Tree) return Boolean;

This function returns true if both trees contains same sets of key-value pairs.

Pointers to the key-value pairs. The type Item_Ptr is used to point a key-value pair in the tree:

type Item_Ptr is private;
No_Item : constant Item_Ptr;

The value No_Item is used to indicate no item. Note that key-value pointers are volatile, any tree update operation can potentially invalidate any pointer. The following operations are defined on pointers:

function Get_Bucket_Address (Item : Item_Ptr) return System.Address;

This function returns the address of the bucket pointed by Item. The result is Null_Address when Item is No_Item.

function Get_Bucket_Size (Item : Item_Ptr) return Natural;

This function returns the number of used slots in the bucket. The result is 0 when Item is No_Item.

function Get_Index (Item : Item_Ptr) return Positive;

This function returns the position in the bucket of the key-value pair pointed by Item. The result is in the range 1..Get_Size (Item). Constraint_Error is propagated when Item is No_Item.

function Get_Key (Item : Item_Ptr) return Key_Type;

This function returns the key in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Next (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the next key-value pair. The result No_Item when there is no such pair.

function Get_Previous (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the previous key-value pair. The result No_Item when there is no such pair.

function Get_Root (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the first key-value pair in the root bucket. The result No_Item when there is no such pair.

function Get_Value (Item : Item_Ptr) return Object_Type;

This function returns the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

procedure Remove (Item : in out Item_Ptr);

This procedure removes the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item. After removal Item is set to No_Item.

procedure Replace (Item : in out Item_Ptr; Value : Object_Type);

This procedure changes the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

3.3.2. B-trees of indefinite keys and objects

The package Generic_Indefinite_B_Tree is exactly as Generic_B_Tree except that it allows indefinite key and object types used in an instantiation:

generic
   type Key_Type (<>) is private;
   type Object_Type (<>) is private;
   Width : Positive := 256;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Generic_B_Tree is ...

The generic formal parameters are:

3.3.3 Persistent B-trees

The generic child package Persistent.Memory_Pools.Streams.Generic_External_B_Tree provides B-trees resident in a persistent memory pool. When the tree is updated the changes are kept in the storage. The tree object can then be finalized and the storage file closed. When the storage is re-opened the tree object can created new and bound to the stored content (see Set_Root_Address and Get_Root_Address).

The implementation of the package is task-safe, the B-tree object can be concurrently accessed from several tasks.

The package formal parameters are:

generic
   type Key_Type (<>) is private;
   type Object_Type (<>) is private;
   with function Input_Key
                 (  Stream : access Root_Stream_Type'Class
                 )  return Key_Type is <>;
   with function Input_Value
                 (  Stream : access Root_Stream_Type'Class
                 )  return Object_Type is <>;
   with procedure Output_Key
                  (  Stream : access Root_Stream_Type'Class;
                     Key    : Key_Type
                  )  is <>;
   with procedure Output_Value
                  (  Stream : access Root_Stream_Type'Class;
                     Value  : Object_Type
                  )  is <>;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Persistent.Memory_Pools.Stream.Generic_External_B_Tree is ...

The generic formal parameters are:

The type of the B-tree is declared as:

type B_Tree
     (  Pool : access Persistent_Pool'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

Here Pool is the persistent memory to allocate the tree in. The following operations are defined on the type:

procedure Add
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Value     : Object_Type
          );

This procedure adds new key-value pair to the tree. Constraint_Error is propagated when Key is already present in the tree.

procedure Add
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Producer  : in out Abstract_Value_Access'Class
          );

This variant of the procedure uses Producer object's operation Put to store the value for the added key.

procedure Erase (Container : in out B_Tree);

This procedure removes all key-value pairs from the tree.

procedure Finalize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Find (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function is used to search the tree for given key. The result is a pointer to the found key-value pair or No_Item if the key is not in the tree.

function Get (Container : B_Tree; Key : Key_Type) return Object_Type;

This function is returns the value associated with the key. Constraint_Error is propagated when the key is not in the tree.

procedure Get
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Consumer  : in out Abstract_Value_Access'Class
          );

This variant uses Consumer object's operation Get to obtain the value corresponding to Key.

function Get_First (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the least key. The result is No_Item if the tree is empty.

function Get_Last (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the greatest key. The result is No_Item if the tree is empty.

function Get_Root_Address (Container : B_Tree) return Byte_Index;

The result of this function is the byte index of the root bucket of the tree. Note that the index may change as the tree gets updated. The tree root is set using Set_Root_Address when the tree object has to be restored from the persistent storage. Typically before object finalization its actual root is obtained and stored somewhere in the persistent storage. When the storage is re-opened the root index is read from the storage, a tree object is created and then initialized using Set_Root_Address.

function Inf (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-value pair with the key less than or equal to Key. The result is No_Item if there is no such pair.

procedure Initialize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Is_Empty (Container : B_Tree) return Boolean;

This function returns true if the tree is empty.

function Is_In (Container : B_Tree; Key : Key_Type) return Boolean;

This function returns true if Key is in the tree.

procedure Remove
          (  Container : in out B_Tree;
             Key       : Key_Type
          );

This procedure removes a key-value pair by the key. Nothing happens if the key is not in the tree.

procedure Replace
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Value     : Object_Type
          );

This procedure adds new key-value pair if Key is not in the tree or else replaces the value in the pair if the Key is already in the tree.

procedure Replace
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Producer  : in out Abstract_Value_Access'Class
          );

This variant of the procedure uses Producer object's operation Put to update or store the value for the added or existing key.

procedure Set_Root_Address
          (  Container : in out B_Tree;
             Root      : Byte_Index
          );

This procedure sets the byte index of the tree root. Typically it is the value obtained using Get_Root_Address before finalization of the object in the previous session. The value must be kept between the sessions for instance in a memory pool root index (See Get_Root_Index and Set_Root_Index). When new session begins the and an instance of B_Tree is created, Set_Root_Address must be called before any other operation.

function Sup (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-value pair with the key greater than or equal to Key. The result is No_Item if there is no such pair.

Pointers to the key-value pairs. The type Item_Ptr is used to point a key-value pair in the tree:

type Item_Ptr is private;
No_Item : constant Item_Ptr;

The value No_Item is used to indicate no item. Note that key-value pointers are volatile, any tree update operation can potentially invalidate any pointer. The following operations are defined on the key-value pointer:

function Get_Bucket_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the bucket pointed by Item. The result is 0 when Item is No_Item.

function Get_Bucket_Size (Item : Item_Ptr) return Natural;

This function returns the number of used slots in the bucket. The result is 0 when Item is No_Item.

function Get_Index (Item : Item_Ptr) return Positive;

This function returns the position in the bucket of the key-value pair pointed by Item. The result is in the range 1..Get_Size (Item). Constraint_Error is propagated when Item is No_Item.

function Get_Key (Item : Item_Ptr) return Key_Type;

This function returns the key in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Key_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the key in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Next (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the next key-value pair. The result No_Item when there is no such pair.

function Get_Previous (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the previous key-value pair. The result No_Item when there is no such pair.

function Get_Root (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the first key-value pair in the root bucket. The result No_Item when there is no such pair.

function Get_Value (Item : Item_Ptr) return Object_Type;

This function returns the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

procedure Get_Value
          (  Item     : Item_Ptr;
             Consumer : in out Abstract_Value_Access'Class
          );

This variant uses Consumer object's operation Get to obtain the value of the key-value pair. Constraint_Error is propagated when Item is No_Item.

function Get_Value_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

procedure Remove (Item : in out Item_Ptr);

This procedure removes the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item. After removal Item is set to No_Item.

procedure Replace (Item : in out Item_Ptr; Value : Object_Type);

This procedure changes the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

procedure Replace
          (  Item     : Item_Ptr;
             Producer : in out Abstract_Value_Access'Class
          );

This variant of the procedure uses Producer object's operation Put to update or store the value for the added or existing key.

Stream access to values. The type:

type Abstract_Value_Access is abstract
   new
Ada.Finalization.Limited_Controlled with null record;

is used to access values of the key-value pair in the tree using a stream object. The type declares two abstract primitive operations to implement:

procedure Get
          (  Consumer : in out Abstract_Value_Access;
             Stream   : in out Root_Stream_Type'Class
          )  is abstract;

This procedure is called when the value of the key-value pair has to be read from the B-tree. The parameter Consumer is the user-defined object passed to the tree operation getting the value. Stream is the stream to read the value from, e.g. using Object_Type'Input attribute (provided Object_Type'Output was used to store the value). Note that Input_Value and Output_Value generic formal parameters of the package are used to access the value in other cases. The method chosen in Get must be compatible with those.

procedure Put
          (  Producer : in out Abstract_Value_Access;
             Stream   : in out Root_Stream_Type'Class
          )  is abstract;

This procedure is called when the value of the key-value pair has to be written into the B-tree. The parameter Producer is the user-defined object passed to the tree operation getting the value. Stream is the stream to write the value into, e.g. using Object_Type'Output attribute Note that Input_Value and Output_Value generic formal parameters of the package are used to access the value in other cases. The method chosen in Put must be compatible with those.

3.3.4 Persistent pointer-valued B-trees

The generic child package Persistent.Memory_Pools.Streams.Generic_External_Ptr_B_Tree provides a variant of the persistent B-tree with pointers as values. Instead of a custom value type as in Generic_External_B_Tree this tree maps key to plain persistent pointers of the Byte_Index type.

The implementation of the package is task-safe, the B-tree object can be concurrently accessed from several tasks.

The package formal parameters are:

generic
   type Key_Type (<>) is private;
   with function Input_Key
                 (  Stream : access Root_Stream_Type'Class
                 )  return Key_Type is <>;
   with procedure Output_Key
                  (  Stream : access Root_Stream_Type'Class;
                     Key    : Key_Type
                  )  is <>;
   with function "<" (Left, Right : Key_Type) return Boolean is <>;
   with function "=" (Left, Right : Key_Type) return Boolean is <>;
package Persistent.Memory_Pools.Stream.Generic_External_B_Tree is ...

The generic formal parameters are:

The type of the B-tree is declared as:

type B_Tree
     (  Pool : access Persistent_Pool'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

Here Pool is the persistent memory to allocate the tree in. The following operations are defined on the type:

procedure Add
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Pointer   : Byte_Index
          );

This procedure adds new key-pointer pair to the tree. Constraint_Error is propagated when Key is already present in the tree.

procedure Erase (Container : in out B_Tree);

This procedure removes all key-pointer pairs from the tree.

procedure Finalize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Find (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function is used to search the tree for given key. The result is a pointer to the found key-value pair or No_Item if the key is not in the tree.

function Get (Container : B_Tree; Key : Key_Type) return Byte_Index;

This function is returns the pointer associated with the key. Constraint_Error is propagated when the key is not in the tree.

function Get_First (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-pointer pair with the least key. The result is No_Item if the tree is empty.

function Get_Last (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-pointer pair with the greatest key. The result is No_Item if the tree is empty.

function Get_Root_Address (Container : B_Tree) return Byte_Index;

The result of this function is the byte index of the root bucket of the tree. Note that the index may change as the tree gets updated. The tree root is set using Set_Root_Address when the tree object has to be restored from the persistent storage. Typically before object finalization its actual root is obtained and stored somewhere in the persistent storage. When the storage is re-opened the root index is read from the storage, a tree object is created and then initialized using Set_Root_Address.

function Inf (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-pointer pair with the key less than or equal to Key. The result is No_Item if there is no such pair.

procedure Initialize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Is_Empty (Container : B_Tree) return Boolean;

This function returns true if the tree is empty.

function Is_In (Container : B_Tree; Key : Key_Type) return Boolean;

This function returns true if Key is in the tree.

procedure Remove
          (  Container : in out B_Tree;
             Key       : Key_Type
          );
procedure
Remove
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Pointer   : out Byte_Index
          );

This procedure removes a key-pointer pair by the key. Nothing happens if the key is not in the tree. When the output parameter Pointer is specified it is set to the pointer from the removed pair. If no pair was removed Pointer is set to 0.

procedure Replace
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Pointer   : Byte_Index
          );
procedure
Replace
          (  Container : in out B_Tree;
             Key       : Key_Type;
             Pointer   : Byte_Index;
             Replaced  : out Byte_Index
          );

This procedure adds new key-pointer pair if Key is not in the tree or else replaces the pointer  in the pair if the Key is already in the tree. When the parameter Replaced is specified it is set to the old pointer if the pair was replaced. If the pair was added Replaced is set to 0.

procedure Set_Root_Address
          (  Container : in out B_Tree;
             Root      : Byte_Index
          );

This procedure sets the byte index of the tree root. Typically it is the value obtained using Get_Root_Address before finalization of the object in the previous session. The value must be kept between the sessions for instance in a memory pool root index (See Get_Root_Index and Set_Root_Index). When new session begins the and an instance of B_Tree is created, Set_Root_Address must be called before any other operation.

function Sup (Container : B_Tree; Key : Key_Type) return Item_Ptr;

This function returns a pointer to the key-pointer pair with the key greater than or equal to Key. The result is No_Item if there is no such pair.

Pointers to the key-value pairs. The type Item_Ptr is used to point a key-value pair in the tree:

type Item_Ptr is private;
No_Item : constant Item_Ptr;

The value No_Item is used to indicate no item. Note that key-pointer pointers are volatile, any tree update operation can potentially invalidate any pointer. The following operations are defined on the key-pointer pointer:

function Get_Bucket_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the bucket pointed by Item. The result is 0 when Item is No_Item.

function Get_Bucket_Size (Item : Item_Ptr) return Natural;

This function returns the number of used slots in the bucket. The result is 0 when Item is No_Item.

function Get_Index (Item : Item_Ptr) return Positive;

This function returns the position in the bucket of the key-pointer pair pointed by Item. The result is in the range 1..Get_Size (Item). Constraint_Error is propagated when Item is No_Item.

function Get_Key (Item : Item_Ptr) return Key_Type;

This function returns the key in the key-pointer pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Key_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the key in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Next (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the next key-pointer pair. The result No_Item when there is no such pair.

function Get_Pointer (Item : Item_Ptr) return Byte_Index;

This function returns the pointer from the key-pointer pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Previous (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the previous key-value pair. The result No_Item when there is no such pair.

function Get_Root (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the first key-pointer pair in the root bucket. The result No_Item when there is no such pair.

procedure Remove (Item : in out Item_Ptr);
procedure
Remove (Item : in out Item_Ptr; Pointer : out Byte_Index);

This procedure removes the key-pointer pair pointed by Item. Constraint_Error is propagated when Item is No_Item. After removal Item is set to No_Item. When the parameter Pointer is specified it accepts the pointer from the removed pair. It is set to 0 when no pair is removed.

procedure Replace
          (  Item     : in out Item_Ptr;
             Pointer  : Byte_Index
          );
procedure
Replace
          (  Item     : in out Item_Ptr;
             Pointer  : Byte_Index;
             Replaced : out Byte_Index
          );

This procedure changes the value in the key-pointer pair pointed by Item. Constraint_Error is propagated when Item is No_Item. The parameter Replaced when specified accepts the replaced pointer.

3.3.5 Persistent raw B-trees

The generic child package Persistent.Memory_Pools.Streams.External_B_Tree provides a variant of the persistent B-tree with weakly typed keys and values. For both the type Byte_Index is used. Usually the tree is used as private parent type for an implementation which either allocates keys and/or values in the pool and passes the resulting Byte_Index to the operations of B-tree. Alternatively it can pack key and/or value into Byte_Index if these fit into the Byte_Index's range. The ordering of keys can be changed by overriding the primitive operation Compare.

The implementation of the package is task-safe, the B-tree object can be concurrently accessed from several tasks.

The type of the B-tree is declared as:

type B_Tree
     (  Pool : access Persistent_Pool'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

Here Pool is the persistent memory to allocate the tree in. The following operations are defined on the type:

procedure Add
          (  Container : in out B_Tree;
             Key       : Byte_Index;
             Value     : Byte_Index
          );

This procedure adds new key-value pair to the tree. Constraint_Error is propagated when Key is already present in the tree.

type Outcome is (Before, Same, After);
function Compare
         (  Container : B_Tree;
            Left      : Byte_Index;
            Right     : Byte_Index
         )  return Outcome;

This function is used to compare two keys. It can be overridden in order to change the ordering of keys.

procedure Erase (Container : in out B_Tree);

This procedure removes all key-value pairs from the tree.

procedure Finalize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Find
         (  Container : B_Tree;
            Key       : Byte_Index
         )  return Item_Ptr;

This function is used to search the tree for given key. The result is a pointer to the found key-value pair or No_Item if the key is not in the tree.

function Get
         (  Container : B_Tree;
            Key       : Byte_Index
         )  return Byte_Index;

This function is returns the value associated with the key. Constraint_Error is propagated when the key is not in the tree.

function Get_First (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the least key. The result is No_Item if the tree is empty.

function Get_Last (Container : B_Tree) return Item_Ptr;

This function returns a pointer to the key-value pair with the greatest key. The result is No_Item if the tree is empty.

function Get_Root_Address (Container : B_Tree) return Byte_Index;

The result of this function is the byte index of the root bucket of the tree. Note that the index may change as the tree gets updated. The tree root is set using Set_Root_Address when the tree object has to be restored from the persistent storage. Typically before object finalization its actual root is obtained and stored somewhere in the persistent storage. When the storage is re-opened the root index is read from the storage, a tree object is created and then initialized using Set_Root_Address.

function Inf (Container : B_Tree; Key : Byte_Index) return Item_Ptr;

This function returns a pointer to the key-value pair with the key less than or equal to Key. The result is No_Item if there is no such pair.

procedure Initialize (Container : in out B_Tree);

This procedure, when overridden in the child type must be called from the new implementation.

function Is_Empty (Container : B_Tree) return Boolean;

This function returns true if the tree is empty.

function Is_In (Container : B_Tree; Key : Byte_Index) return Boolean;

This function returns true if Key is in the tree.

procedure Remove
          (  Container : in out B_Tree;
             Key       : Byte_Index
          );
procedure
Remove
          (  Container : in out B_Tree;
             Key       : Byte_Index;
             Value     : out Byte_Index
          );

This procedure removes a key-value pair by the key. Nothing happens if the key is not in the tree. When the output parameter Value is specified it is set to the value from the removed pair. If no pair was removed Value is set to 0.

procedure Replace
          (  Container : in out B_Tree;
             Key       : Byte_Index;
             Value     : Byte_Index
          );
procedure
Replace
          (  Container : in out B_Tree;
             Key       : Byte_Index;
             Value     : Byte_Index;
             Replaced  : out Byte_Index
          );

This procedure adds new key-value pair if Key is not in the tree or else replaces the value  in the pair if the Key is already in the tree. When the parameter Replaced is specified it is set to the old value if the pair was replaced. If the pair was added Replaced is set to 0.

procedure Set_Root_Address
          (  Container : in out B_Tree;
             Root      : Byte_Index
          );

This procedure sets the byte index of the tree root. Typically it is the value obtained using Get_Root_Address before finalization of the object in the previous session. The value must be kept between the sessions for instance in a memory pool root index (See Get_Root_Index and Set_Root_Index). When new session begins the and an instance of B_Tree is created, Set_Root_Address must be called before any other operation.

function Sup (Container : B_Tree; Key : Byte_Index) return Item_Ptr;

This function returns a pointer to the key-value pair with the key greater than or equal to Key. The result is No_Item if there is no such pair.

Pointers to the key-value pairs. The type Item_Ptr is used to point a key-value pair in the tree:

type Item_Ptr is private;
No_Item : constant Item_Ptr;

The value No_Item is used to indicate no item. Note that key-value pointers are volatile, any tree update operation can potentially invalidate any pointer. The following operations are defined on the key-value pointer:

function Get_Bucket_Address (Item : Item_Ptr) return Byte_Index;

This function returns the address of the bucket pointed by Item. The result is 0 when Item is No_Item.

function Get_Bucket_Size (Item : Item_Ptr) return Natural;

This function returns the number of used slots in the bucket. The result is 0 when Item is No_Item.

function Get_Index (Item : Item_Ptr) return Positive;

This function returns the position in the bucket of the key-value pair pointed by Item. The result is in the range 1..Get_Size (Item). Constraint_Error is propagated when Item is No_Item.

function Get_Key (Item : Item_Ptr) return Byte_Index;

This function returns the key in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

function Get_Next (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the next key-value pair. The result No_Item when there is no such pair.

function Get_Previous (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the previous key-value pair. The result No_Item when there is no such pair.

function Get_Root (Item : Item_Ptr) return Item_Ptr;

This function returns the pointer to the first key-pointer pair in the root bucket. The result No_Item when there is no such pair.

function Get_Value (Item : Item_Ptr) return Byte_Index;

This function returns the value from the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item.

procedure Remove (Item : in out Item_Ptr);
procedure
Remove (Item : in out Item_Ptr; Value : out Byte_Index);

This procedure removes the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item. After removal Item is set to No_Item. When the parameter Value is specified it accepts the value from the removed pair. It is set to 0 when no pair is removed.

procedure Replace
          (  Item   : in out Item_Ptr;
             Value  : Byte_Index
          );
procedure
Replace
          (  Item     : in out Item_Ptr;
             Value    : Byte_Index;
             Replaced : out Byte_Index
          );

This procedure changes the value in the key-value pair pointed by Item. Constraint_Error is propagated when Item is No_Item. The parameter Replaced when specified accepts the replaced pointer.

3.3.6 Persistent multi-keyed tables

The generic child package Persistent.Memory_Pools.Streams.External_B_Tree.Generic_Table provides a table allocated in an external storage. The table can be searched by any of the keys identified by the generic formal discrete type Key_Index.

k11 k12 ... k1N v11 v12 ... v1M
k21 k22 ... k2N v21 v22 ... v2M

...

kL1 kL2 ... kLN vL1 vL2 ... vLM

Each row i of the table is associated with a tuple of unique keys (ki1, ki2, ..., kiN). Any of the keys can be used to identify the row. Additionally the row contains a tuple of  values (vi1, vi2, ..., viM) identified by the generic formal discrete type Value_Index. Internally for each type of keys has a B-tree of its own. Items of the trees point to the rows. Keys and values can be queried from the row.

The implementation is raw and untyped. All keys and values are of the type Byte_Index.

generic
   type
Key_Index is (<>);
   type Value_Index is (<>);
package Persistent.Memory_Pools.Streams.External_B_Tree.
        Generic_Table is ...
The implementation of the package is task-safe, the table object can be concurrently accessed from several tasks.

The package declares:

type Keys_Tuple is array (Key_Index) of Byte_Index;

This is the tuple of keys associated with each table row. The row is uniquely identified by any of the keys from the tuple. The table can be searched for any of the keys. The row ordering induced by a key is independent on other keys.

type Values_Tuple is array (Values_Index) of Byte_Index;

This is the tuple of data kept by each table row.

The type of the table is declared as:

type Table
     (  Pool : access Persistent_Pool'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

Here Pool is the persistent memory to allocate the tree in. The following operations are defined on the type:

procedure Add
          (  Container : in out Table;
             Keys      : Keys_Tuple;
             Values    : Values_Tuple
          );

This procedure adds a new row to the table. Keys specifies the row's keys. Values does the row's data. Constraint_Error is propagated when Keys contains a key already used for a table row.

type Outcome is (Before, Same, After);
function Compare
         (  Container : Table;
            Index     : Key_Index;
            Left      : Byte_Index;
            Right     : Byte_Index
         )  return Outcome;

This function is used to compare two keys of the type specified by Index. It can be overridden in order to change the ordering of keys.

procedure Erase (Container : in out Table);

This procedure removes all table rows.

procedure Finalize (Container : in out Table);

This procedure, when overridden in the child type must be called from the new implementation. Note that Get_Root_Address should be called before object finalization and the obtained value stored somewhere else.

function Find
         (  Container : Table;
            Index     : Key_Index;
            Key       : Byte_Index
         )  return Row_Ptr;

This function is used to search the table for given key identified by its type (Index) and value (Key). The result is a pointer to the found table row or No_Row if no row was found.

function Get
         (  Container : Table;
            Index     : Key_Index;
            Key       : Byte_Index
         )  return Values_Tuple;

This function is returns the values associated with the key identified by its type (Index) and value (Key). Constraint_Error is propagated when the row does not exist.

function Get
         (  Container : Table;
            Index     : Key_Index;
            Key       : Byte_Index;
            Column    : Value_Index
         )  return Byte_Index;

This function is returns the value associated with the key identified by its type (Index) and value (Key) from the column specified by the parameter Column. Constraint_Error is propagated when the row does not exist.

function Get_First
         (  Container : Table;
            Index
     : Key_Index
         )  return Row_Ptr;

This function returns a pointer to the row with the least key. The parameter Index specifies the key type. The result is No_Row if the table is empty.

function Get_Last
         (  Container : Table;
            Index
     : Key_Index
         )  return Row_Ptr;

This function returns a pointer to the row with the greatest key of the type Index. The result is No_Row if the table is empty.

function Get_Root_Address (Container : Table) return Byte_Index;

The result of this function is the byte index of the root bucket of the table. Note that the index may change as the table gets updated. The table root is set using Set_Root_Address when the table object has to be restored from the persistent storage. Typically before object finalization its actual root is obtained and stored somewhere in the persistent storage. When the storage is re-opened the root index is read from the storage, a table object is created and then initialized using Set_Root_Address.

function Inf
         (  Container : Table;
            Index
     : Key_Index;
            Key       : Byte_Index
         )  return Row_Ptr;

This function returns a pointer to the row with the key less than or equal the key identified by its type (Index) and value (Key). The result is No_Row if there is no such row.

procedure Initialize (Container : in out Table);

This procedure, when overridden in the child type must be called from the new implementation. Note that Set_Root_Address must be called after initialization if the table is persistent in the storage.

function Is_Empty (Container : Table) return Boolean;

This function returns true if the table is empty.

function Is_In
         (  Container : Table;
            Index
     : Key_Index;
            Key       : Byte_Index
         )  return Boolean;

This function returns true if the table contains a row identified by its type (Index) and value (Key).

procedure Remove
          (  Container : in out Table;
             Index     : Key_Index;
             Key       : Byte_Index
          );
procedure
Remove
          (  Container : in out Table;
             Index     : Key_Index;
             Key       : Byte_Index;
             Values    : out Values_Tuple
          );
procedure
Remove
          (  Container : in out Table;
             Index     : Key_Index;
             Key       : Byte_Index;
             Keys      : out Keys_Tuple;
             Values    : out Values_Tuple
          );

These procedures remove a row identified by its type (Index) and value (Key). Nothing happens if the row is not in the table. When the output parameters Keys and Value are specified they are filled with removed row's keys and values. If no row was removed they are filled with zeros.

procedure Replace
          (  Container : in out Table;
             Keys      : Keys_Tuple;
             Values    : Values_Tuple
          );
procedure
Replace
          (  Container : in out B_Tree;
             Keys      : Keys_Tuple;
             Values    : Values_Tuple;
             Replaced  : out Values_Tuple
          );

These procedures adds a new or replace an existing row indicated by Keys. When the parameter Replaced is specified it is filled with the replaced values. If the row was added Replaced is filled with zeros.

procedure Replace
          (  Container : in out Table;
             Index     : Key_Index;
             Key       : Byte_Index;
             Column    : Value_Index;
             Value     : Byte_Index
          );
procedure Replace
          (  Container : in out Table;
             Index     : Key_Index;
             Key       : Byte_Index;
             Column    : Value_Index;
             Value     : Byte_Index;
             Replaced  : out Byte_Index
          );

These procedures replace a single row value specified by the parameter Column. The row is identified by its type (Index) and value (Key). When the parameter Replaced is specified it is set to the replaced value. Contstraint_Error is propagated when there is no such row.

procedure Set_Root_Address
          (  Container : in out B_Tree;
             Root      : Byte_Index
          );

This procedure sets the byte index of the tree root. Typically it is the value obtained using Get_Root_Address before finalization of the object in the previous session, for instance in a memory pool root index (See Get_Root_Index and Set_Root_Index). When a new session begins the and an instance of Table is created, Set_Root_Address must be called before any other operation.

function Sup
         (  Container : Table;
            Index
     : Key_Index;
            Key       : Byte_Index
         )  return Row_Ptr;

This function returns a pointer to the row with the key greater than or equal to Key. The result is No_Row if there is no such row.

procedure Update
          (  Container : Table;
             Index
     : Key_Index;
             Key       : Byte_Index;
             Handler   : in out Update_Handler'Class
          );

This procedure changes values of the row identified by its type (Index) and value (Key) using primitive operation Update of Handler. Constraint_Error is propagated when there is no such row.

Pointers to the rows. The type Row_Ptr is used to point a key-value pair in the tree:

type Row_Ptr is private;
No_Row : constant Row_Ptr;

The value No_Row is used to indicate no row. Note that row pointers are volatile, any table update operation can potentially invalidate any pointer. The following operations are defined on the row pointer:

function Get_Bucket_Address (Row : Row_Ptr) return Byte_Index;

This function returns the address of the bucket pointed by Row. The result is 0 when Row is No_Row.

function Get_Bucket_Size (Row : Row_Ptr) return Natural;

This function returns the number of used slots in the bucket. The result is 0 when Row is No_Row.

function Get_Index (Row : Row_Ptr) return Positive;

This function returns the position in the bucket of the row pointed by Row. The result is in the range 1..Get_Size (Row). Constraint_Error is propagated when Row is No_Row.

function Get_Key
         (  Row   : Row_Ptr;
            Index : Key_Index
         )  return Byte_Index;

This function returns the key indicated by the type Index and corresponding to Row. Constraint_Error is propagated when Row is No_Row.

function Get_Keys (Row : Row_Ptr) return Keys_Tuple;

This function returns keys corresponding to Row. Constraint_Error is propagated when Row is No_Row.

function Get_Next
         (  Row   : Row_Ptr;
            Index : Key_Index
         )  return Row_Ptr;

This function returns the pointer to the row next to one pointed by Row according to the key type Index. The result No_Row when there is no such row.

function Get_Previous
         (  Row   : Row_Ptr;
            Index : Key_Index
         )  return Row_Ptr;

This function returns the pointer to the row previous to one pointed by Row according to the key type Index. The result No_Row when there is no such row.

function Get_Root
         (  Row   : Row_Ptr;
            Index : Key_Index
         )  return Row_Ptr;

This function returns the pointer to the first row in the root bucket of the key type Index. The result No_Row when there is no such row.

function Get_Value
         (  Row    : Row_Ptr;
            Column : Value_Index
         )  return Byte_Index;

This function returns the value indicated by Row and Column. Constraint_Error is propagated when Row is No_Row.

procedure Remove (Item : in out Row_Ptr);
procedure
Remove (Item : in out Row_Ptr; Values : out Values_Tuple);

This procedure removes the row pointed by Row. Constraint_Error is propagated when Row is No_Row. After removal Row is set to No_Row. When the parameter Values is specified it accepts the values from the removed row. It is filled with zeros when no row was removed.

procedure Replace
          (  Row    : in out Row_Ptr;
             Column : Value_Index;
             Value  : Byte_Index
          );
procedure
Replace
          (  Row      : in out Row_Ptr;
             Column   : Value_Index;
             Value    : Byte_Index;
             Replaced : out Byte_Index
          );

This procedure changes the value in the row indicated by Row and Column. Constraint_Error is propagated when Row is No_Row. The parameter Replaced when specified accepts the replaced value.

procedure Replace
          (  Row    : in out Row_Ptr;
             Values : Values_Tuple
          );
procedure
Replace
          (  Row      : in out Row_Ptr;
             Value    : Values_Tuple;
             Replaced : out Values_Tuple
          );

This procedure changes values of the row indicated by Row. Constraint_Error is propagated when Row is No_Row. The parameter Replaced when specified accepts the replaced value.

procedure Update
          (  Row     : Row_Ptr;
             Handler : in out Update_Handler'Class
          );

This procedure changes values of the row indicated by Row using primitive operation Update of Handler. Constraint_Error is propagated when Row is No_Row.

User-defined update handler. The type Update_Handler is used for custom table row updates:

type Update_Handler is abstract
   new
Ada.Finalization.Limited_Controlled with null record;

The primitive operation is used to update table row:

procedure Update
          (  Handler : in out Update_Handler;
             Keys    : Keys_Tuple;
             Values  : in out Values_Tuple
          )  is abstract;

The parameter Keys is the keys of the row being modified. Values is the row values initialized by the actual row data. It can be updated to change row data.


[Back][TOC][Next]

4. Unbounded arrays

The package Generic_Unbounded_Array defines the type Unbounded_Array. An instance of the type is a dynamically expanded vector of elements. The implementation keeps vector contiguous, so it might be very inefficient to put complex data structures into the array. In many cases it is better to put pointers to elements there. See also the package Generic_Unbounded_Ptr_Array which instantiates Generic_Unbounded_Array for this purpose. The type wraps the component Vector which is a pointer to an array of elements. One can use Vector to access array elements and query its present bounds, which are rather arbitrary. The unused  elements of the array vector are padded using a distinguished null-element value The package Generic_Unbounded_Array is generic and has the following generic parameters:

generic
   type Index_Type is (<>);
   type Object_Type is private;
   type Object_Array_Type is
      array (Index_Type range <>) of Object_Type;
   Null_Element : Object_Type;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Unbounded_Array is ...

Here:

The type Unbounded_Array is declared as follows:

type Object_Array_Ptr is access Object_Array_Type;
type
Unbounded_Array is
   new Ada.Finalization.Limited_Controlled with
record
   Vector : Object_Array_Ptr := null;
end record
;

Array elements can be accessed through indexing the component Vector. Note that single what can be said about the length of the vector is that it is big enough to keep all elements put into the array. The unused elements in the vector are padded using the value Null_Element. The implementation is very straightforward. It does not implement any optimization of assignments, like the implementation of Generic_Set does. This choice was intentionally made to mimic arrays as close as possible. If reference counting is needed a wrapper type could be built around Unbounded_Array. The following operations are defined on Unbounded_Array:

procedure Erase (Container : in out Unbounded_Array);

This procedure removes all elements from Container making it empty.

procedure Finalize (Container : in out Unbounded_Array);

The destructor frees the memory allocated for the array vector.

function Fetch
         (  Container : Unbounded_Array;
            Index     : Index_Type
         )  return Object_Type;

This function returns a container element or Null_Element if Index is out of vector range.

function Get
         (  Container : Unbounded_Array;
            Index     : Index_Type
         )  return Object_Type;

This function is an equivalent to Container.Vector (Index). Constraint_Error is propagated if Index is out of vector range.

procedure Put
          (  Container : in out Unbounded_Array;
             Index     : Index_Type;
             Element   : Object_Type
          );
This procedure is used to put / replace an element in array using its index. The array vector is expanded as necessary. Unused elements are padded with Null_Element.

[Back][TOC][Next]

5. Unbounded arrays of pointers

The package Generic_Unbounded_Ptr_Array defines the type Unbounded_Ptr_Array. An instance of Unbounded_Ptr_Array is a dynamically expanded vector of pointers to elements. Upon destruction objects pointed by array elements are destroyed. Same happens when an element is replaced. The package has the following generic parameters:

generic
   type Index_Type is (<>);
   type Object_Type (<>) is limited private;
   type Object_Ptr_Type is access Object_Type;
   type Object_Ptr_Array_Type is
      array (Index_Type range <>) of Object_Ptr_Type;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Unbounded_Ptr_Array is ...

Here:

The type Unbounded_Ptr_Array is declared through an instantiation of the package Generic_Unbounded_Array. Array elements can be accessed through indexing the component Vector which are pointers to the elements. Note that single what can be said about the length of the vector is that it is big enough to keep all elements put into the array. The unused elements in the vector are padded using null. The following operations are defined on Unbounded_Ptr_Array:

procedure Erase (Container : in out Unbounded_Array);

This procedure removes all elements from Container making it empty.

procedure Finalize (Container : in out Unbounded_Ptr_Array);

The destructor frees the memory allocated for the array vector and all elements it refers to.

function Get
         (  Container : Unbounded_Ptr_Array;
            Index     : Index_Type
         )  return Object_Ptr_Type;

This function is an equivalent to Container.Vector (Index) with the exception that null is returned when Index is out of vector range.

procedure Put
          (  Container : in out Unbounded_Ptr_Array;
             Index     : Index_Type;
             Element   : Object_Ptr_Type
          );

This procedure is used to put in / replace an array element using its index. If the replaced array element is not null then the object it points to is destroyed. Note that the object pointed by Element is not copied. Thus it is not a responsibility of the caller to destroy the object. It will be automatically destroyed upon array destruction or replacing the element in the array. The array vector is expanded as necessary. Unused elements are padded with null.

The implementation of Generic_Segmented_Stack provides an illustration of use Generic_Unbounded_Ptr_Array. A segmented stack consists of segments of same size. The list of segments is viewed as an abstract array used to instantiate Generic_Stack. The array index is split into the high-order index indicating a segment and the low-order one specifying the element in the segment. The list of segments is implemented as an Unbounded_Ptr_Array indexed by the high-order index. Observe that once allocated a segment gets referenced in Unbounded_Ptr_Array, so there is no need to explicitly deallocate segments, Unbounded_Ptr_Array willl do it. So the implementation of Generic_Segmented_Stack can be as straightforward as:


[Back][TOC][Next]

6. Stacks

Stack, also LIFO Stack (Last in First Out), is a container in which the only accessible element is the last one.

[Back][TOC][Next]

6.1. Stacks based on abstract arrays

The package Generic_Stack defines the type Stack which provides a generic stack. The stack is built upon an array type which might be a Unbounded_Array, Unbounded_Ptr_Array, array of handles or some other type (like Unbounded_String). The package has the following generic parameters:

generic
   type Index_Type is (<>);
   type Object_Type (<>) is limited private;
   type Array_Type is limited private;
   Null_Element : Object_Type;
   with function Get
                 (  Container : Array_Type;
                    Index     : Index_Type
                 )  return Object_Type is <>;
   with procedure Put
                  (  Container : in out Array_Type;
                     Index     : Index_Type;
                     Element   : Object_Type
                  )  is <>;
package Generic_Stack is
   type Stack is new Ada.Finalization.Limited_Controlled with private;

Here the formal parameters are:

The following operations are defined on Stack:

procedure Erase (Container : in out Stack);

This procedure pops all items from the stack Container.

function Get (Container : Stack; Index : Index_Type)
   return Object_Type;

This function returns the stack item with the index specified by the parameter Index. The item item on the stack top has the index returned by Mark, so that

Top (Container) = Get (Container, Mark (Container))

Constraint_Error is propagated if Index points out of stack.

function Is_Empty (Container : Stack) return Boolean;

This function returns true if Container is empty.

function Mark (Container : Stack) return Index_Type;

The value returned by this function can be used in the procedure Release to pop all the items pushed in between. When the type Index_Type is an integer type, then the difference between two values returned by Mark is the number of stack items.

procedure Pop (Container : in out Stack; Count : Natural := 1);

This procedure pops Count items from the top of Container. If the stack does not contain enough items, it is emptied.

procedure Push (Container : in out Stack; Item : Object_Type);

This procedure pushes Item onto Container.

procedure Put
          (  Container : in out Stack;
             Index     : Index_Type;
             Element   : Object_Type
          );

This procedure replaces the stack item specified by the parameter Index with Element. The index is same as described in Get. Constraint_Error is propagated if Index points out of stack.

procedure Release (Container : in out Stack; Mark : Index_Type);

This procedure is used to pop all items pushed since a call to the function Mark which result was the value of the parameter Mark. Nothing happens if the stack was already popped below Mark.

function Top (Container : Stack) return Object_Type;

This function returns the topmost stack item. Constraint_Error is propagated if Container is empty.

[Back][TOC][Next]

6.2. Segmented stacks

The package Generic_Segmented_Stack instantiates Generic_Stack so that the stack will use a list of segments of same size. The number of stack segments is unlimited. New segments are allocated as necessary. The package is generic:

generic
   type Index_Type is (<>);
   type Object_Type is private;
   Null_Element : Object_Type;
   Segment_Size : Positive := 128;
   Minimal_Size : Positive := 64;
   Increment    : Natural  := 50;
package Generic_Segmented_Stack is
   ...
   package
Segmented_Stack is new Generic_Stack ...

Here the formal parameters are:

The package can be used as follows:

package Float_Stack is
   new Generic_Segmented_Stack (Integer, Float, 0.0);
use Float_Stack.Segmented_Stack;
...
LIFO : Stack;


[Back][TOC][Next]

7. Pools

User-defined storage pools can be used for objects which creation / destruction policy allows a more efficient memory management strategy than the standard heap offers, but yet not enough strict to allocate them on the system stack.

[Back][TOC][Next]

7.1. Stack pool

The package Stack_Storage provides an implementation of a user-defined pool organized as a stack. The package the type Pool derived form System.Storage_Pools.Root_Storage_Pool:

type Pool
     (  Initial_Size : Storage_Count;
        Items_Number : Positive
     )  is new Root_Storage_Pool with private;

A stack pool consists of contiguous segments allocated dynamically as necessary. The discriminants control the stack segments allocation policy. Initial_Size determines the initial default size of a newly allocated segment. If this size is less than the size of the object being allocated the default size is set to the object size multiplied to Items_Number. This value will then used as the default size for all further segments. The segments allocated earlier having lesser size will be freed when possible. Otherwise, they remain allocated until pool destruction. Upon stack pool destruction, all the stack segments are deallocated. No checks made whether some objects remain allocated on the stack. Note also that no checks made whether objects allocation / deallocation order is indeed LIFO (last in, first out). Deallocation of an object frees the memory of all objects allocated after it. The stack pool is not task-safe. If that is required it has to be protected from a concurrent access.

procedure Deallocate_All (Stack : in out Pool);

This procedure deallocates everything allocated in the pool. It should be used with great care.

function Get_Last_Segment (Stack : Pool) return Natural;

This function returns the number of the last segment in Stack holding some allocated data.

function Get_Segments_Number (Stack : Pool) return Natural;

This function returns the total number of segments in Stack.

procedure Get_Segment_Data
          (  Stack : Pool;
             Index : Positive;
             Size  : out Storage_Count;
             Used  : out Storage_Count;
             Start : out Address
          );

This function returns information about a segment in Stack specified by Index in the range 1..Get_Segments_Number. Size is the segment size. Used is the space allocated in the segment. Start is the first memory address of the segment. The first free address is Start + Used. Free space in the segment is Size - Used. Free space of the segments before Get_Last_Segment is not used until deallocation of memory in next segments. Constraint_Error is propagated when Index is illegal.

[Back][TOC][Next]

7.2. Mark and release pool for controlled objects

The generic child package Stack_Storage.Mark_And_Release provides an implementation of a mark and release pool for limited controlled objects:

generic
  
Stack : in out Pool'Class;
package
Stack_Storage.Mark_And_Release is ...

The generic parameter Stack is a descendant of Pool, a stack pool. The package defines:

type Pool_Object is
   new
Ada.Finalization.Limited_Controlled with private;

This is the base type for all objects to be allocated on Stack. The pool objects should be allocated only in the pool (using an allocator new). If they are destroyed explicitly using Unchecked_Deallocation, then it should happen LIFO and never under the last pool mark. The type Pool_Object has the following operations:

procedure Finalize (Object : in out Pool_Object);

The destructor has to be called by all descendants of Pool_Object. Storage_Error is propagated if Object is not the last allocated object in the pool.

procedure Initialize (Object : in out Pool_Object);
The constructor has to be called by all descendants.

type Pool_Object_Ptr is access Pool_Object'Class;
for
Pool_Object_Ptr'Storage_Pool use Stack;

This is the access type, which can be used as the target for an allocator of a Pool_Object descendant. If other access type used as the target, then it has to be specific to the pool Stack.

type Pool_Mark is
   new Ada.Finalization.Limited_Controlled with private;

Objects of Pool_Mark are used as snap-shots of the pool state. When such a pool mark object is created it remembers the pool state. Upon its destruction it finalizes all the objects allocated in the pool since its construction and reclaims the storage occupied by the objects. If some pool objects have to be destroyed explicitly, then that shall be ones created after the last pool mark creation only. The following operations are defined on Pool_Mark:

procedure Finalize (Snap : in out Pool_Mark);

The destructor removes all objects remaining in the pool since construction of Snap. Storage_Error is propagated on object finalization errors.

procedure Initialize (Snap : in out Pool_Mark);

The constructor remembers the pool state.

The following short code sample illustrates use of mark and release pool:

declare
   Snap : Pool_Mark;  -- Mark the pool state
   Ptr  : Pool_Object_Ptr;
begin

   ...
   Ptr := new Derived_Pool_Object;         -- Allocate
   ...
   Ptr := new Another_Derived_Pool_Object; -- Allocate
   ...
end;                  -- Release all allocated objects

[Back][TOC][Next]

7.3. Persistent storage memory pool

The child package Persistent.Memory_Pools provides a persistent storage memory pool. The pool implementation sits upon the direct access file provided by the package Persistent.Blocking_Files. The file keeps the memory blocks from the pool. It can be closed and reopened again. The file format and the structure of the memory pool is portable so long the underlying direct I/O access is. That means precisely that the file can be accessed on different platforms if its blocks can be read and written there.

The following data types are defined in the package:

type Root_Index is range 1..16;

This is the index of 16 user-defined byte indices. The indices can be read (Get_Root_Index) and written (Set_Root_Index). Typically the root memory block index is stored as an index.

type Persistent_Pool
     (  File : access Persistent_Array'Class
     )  is new Ada.Finalization.Limited_Controlled with private;

A instance of this type represents a persistent memory pool. The file object indicated by the discriminant File must be open before the pool object is created and remain open until object finalization.

Note that the implementation of Persistent_Pool is task-safe. The type operations can be used from concurrent tasks.

 The following operations are defined on the type:

function Allocate
         (  Pool : Persistent_Pool;
            Size : Byte_Count
         )  return Byte_Index;

This function allocates a memory block of at least Size byte large in the persistent pool. The result is the byte index of the first byte of the allocated memory block. The memory block is freed using Deallocate. Use_Error is propagated when no memory pool file is open, or when the file was opened read-only. See also Fetch for an eager allocator.

Allocate and Fetch cannot allocate more memory than fits into one file block. Larger objects can be allocated and used through the stream interfaces provided in the package Persistent.Memory_Pools.Streams.

procedure Commit (Pool : in out Persistent_Pool);

This procedure commits the pending transaction on the underlying file and opens a new one. The operation is task-safe. It does nothing if the file does not support transactions. Note that there is no corresponding rollback operation because rolling back the file would corrupt the pool's state. In order to return the pool to its previous state the current pool object must be finalized, the file rolled back, and a new pool object created.

procedure Deallocate
          (  Pool  : in out Persistent_Pool;
             Index : Byte_Index
          );

This procedure frees the memory block of which byte index is Index. Use_Error is propagated when no memory pool file is open, or when the file was opened read-only.

function Expand
         (  Pool  : Persistent_Pool;
            Index : Byte_Index
         )  return Byte_Count;

This function expands the memory block pointed by Index if there is a free space behind it. The result is the new block size. Use_Error is propagated when no memory pool file is open, or when the file was opened read-only.

function Fetch
         (  Pool : Persistent_Pool;
            Size : Byte_Count
         )  return Byte_Index;

This procedure allocates at least Size bytes in Pool. It tries to allocate as much space as possible. When a fitting block is found it is allocated full. The actual size of the allocated block can be obtained using Get_Size. The result is the byte index of the first byte of the allocated memory block. The memory block is freed using Deallocate. Use_Error is propagated when no memory pool file is open, or when the file was opened read-only. See also Allocate for a conservative allocator.

procedure Finalize (Pool: in out Persistent_Pool);

This procedure is called upon object destruction. When the type is derived from and this procedures is overridden, the new implementation must call it from inside.

procedure Flush (Pool: in out Persistent_Pool);

This procedure writes all cached updated file blocks back to the file. I/O errors are propagated on system errors.

function Get_Block_Size
         (  Pool  : Persistent_Pool;
            Index : Byte_Index
         )  return Byte_Count;

This function returns the total size of the block containing the byte specified by Index. Use_Error is propagated when no memory pool file is open. See also Get_Size.

function Get_Blocks_Free (Pool : Persistent_Pool) return Block_Count;

This function returns the number unused file blocks. New file blocks are allocated in the file as necessary. It is 0 when no file is open.

function Get_Blocks_Used (Pool : Persistent_Pool) return Block_Count;

This function returns the number used file blocks. It is 0 when no file is open.

function Get_Bytes_Free (Pool : Persistent_Pool) return Byte_Index;

This function returns the number unused bytes in the pool. The count does not include the memory used to maintain the internal structures of the pool. The result is 0 when no file is open.

function Get_Bytes_Used (Pool : Persistent_Pool) return Byte_Index;

This function returns the number used bytes from the pool. This does not include the memory used to maintain the pool. The result is 0 when no file is open.

function Get_Name (Pool : Persistent_Pool) return String;

This function returns the name of the file used by the pool. Use_Error is propagated when no memory pool file is open.

function Get_Root_Index
         (  Pool  : Persistent_Pool;
            Index : Root_Index
         )  return Byte_Count;

This function returns the root index corresponding to Index. Root indices are used to keep user information, e.g. the index of the master block allocated in the pool. All root indices are initialized 0. When the master blocks gets allocated or relocated Set_Root_Index can be used to set an index to point to it.

function Get_Size
         (  Pool  : Persistent_Pool;
            Index : Byte_Index
         )  return Byte_Count;

This function returns the number of bytes available to use in the block containing the byte specified by Index. Use_Error is propagated when no memory pool file is open.

function Get_Space (Pool : Persistent_Pool) return Byte_Index;

This function returns the number of bytes available for allocation in the file. The result is equal to the number of file blocks multiplied by the block size minus the length of the file header it is also equal to the sum number of free and used bytes plus the number of free and used file blocks multiplied by 4 bytes of the block margin length. Use_Error is propagated when no memory pool file is open.

procedure Initialize (Pool : in out Persistent_Pool);

This procedure must be called when overridden by derived type. The file indicated in the discriminant must be open.

function Is_Open (Pool : Persistent_Pool) return Boolean;

This function returns true if the pool file is open.

procedure Set_Root_Index
          (  Pool  : in out Persistent_Pool;
             Index : Root_Index;
             Value : Byte_Index
          );

This procedure sets the root index corresponding to Index. Root indices are persistent. They can be read back using Get_Root_Index.

procedure Truncate
          (  Pool  : in out Persistent_Pool;
             Index : Byte_Index;
             Size  : Byte_Count
          );

This procedure truncates the memory block pointed by Index to Size. Nothing happens if the new size is greater than the current one or when the freed space is less than minimal possible size. Use_Error is propagated when no memory pool file is open, or when the file was opened read-only.

7.3.1. Concurrent access to the container file

The type Holder declared in the package Persistent.Memory_Pools allows to access the underlying container file in a task-safe way.

type Holder (Pool : access Persistent_Pool'Class) is
   new
Ada.Finalization.Limited_Controlled with private;

In the scope of the object an access to the file Pool.File is exclusive.

[Back][TOC][Next]

7.4. Streams to persistent storage memory pool

The child package Persistent.Memory_Pools.Streams provides stream interfaces to the persistent storage memory pool. The interface can be used to allocate objects larger than the file block length. The contents is split into a set of linked memory blocks. The stream interface transparently crosses block borders when data are read (Input_Stream) or written (Output_Stream). Blocks are allocated transparently when the stream is written. The memory allocation strategy of output stream is eager. When an output stream is closed the unused allocated space is reclaimed. The memory allocated by writing can also be freed using Deallocate. This is the only operation that should be used on the memory allocated trough output stream. Operations like Allocate, Expand, Fetch, Truncate may not be mixed with stream operations.

7.4.1. Output streams

type Output_Stream
     (  Pool : access Persistent_Pool'Class
     )  is new Root_Stream_Type with private;

This stream object is used to store objects into the pool specified as the object's discriminant Pool. The output stream allocates memory blocks as necessary. The object can be read back from an Input_Stream. When a new stream object is written it automatically allocates the first memory block. The index of the first block can be obtained using Get_First. The storage written using streams shall not be modified otherwise than using streams defined in this package. The memory allocated by writing Output_Stream can be reclaimed using Deallocate with the index returned by Get_First. Reading from Output_Stream causes propagation of Use_Error.

procedure Append
          (  Stream : in out Output_Stream;
             Index  : Byte_Index
          );

This procedure opens previously written storage allocated at Index. Newly written data are appended to the end of used storage. Use_Error is propagated when no pool file is open. See also Open.

procedure Close (Stream : in out Output_Stream);

This procedure disconnects the stream from memory and brings it into the state of a newly created object. When closed unused memory allocated for the stream is freed. The stream contents can be read back using Input_Stream.

function Get_First (Stream : Output_Stream) return Byte_Index;

This function returns the index of the first byte allocated. It can be used in Deallocate and in operations like Append and Open. Use_Error is propagated when no stream is open or written.

function Get_Written (Stream : Output_Stream)
   return
Stream_Element_Count;

This function returns the number of stream elements written into Stream. For a newly created object the result is 0.

procedure Open
          (  Stream : in out Output_Stream;
             Index  : Byte_Index
          );

This procedure opens previously written storage allocated at Index for rewriting. Newly written data will be placed from the beginning of the allocated storage. Use_Error is propagated when no pool file is open. See also Append.

procedure Read
          (  Stream : in out Output_Stream;
             Item   : out Stream_Element_Array;
             Last   : out Stream_Element_Offset
          );

This procedure propagates Use_Error.

procedure Write
          (  Stream : in out Output_Stream;
             Item   : Stream_Element_Array
          );

The implementation of stream interface stores written element into the memory blocks allocated in the pool. Use_Error is propagated when no memory pool file is open. I/O errors are propagated on other errors.

The following code sample illustrates usage of Output_Stream and Input_Stream:

declare
   Pool  : aliased Persistent_Pool;
   Hello : Byte_Index;
begin
   Open (Pool, "my_storage.dat"); -- Open external file
   declare
      Output : aliased Output_Stream (Pool'Access);
   begin
      String'Output (Output'Access, "Hello World!");
      Hello := Get_First (Output);
   end;
   -- Now "Hello World!" is stored in the pool at Hello
   -- The memory pool can be closed and the application
   -- exited. Another application can open the pool and
   -- read stored string at Hello as follows:
   ...
   declare
      Input : aliased Input_Stream (Pool'Access);
  
begin
      Open (Input, Hello); -- Set input stream to Hello
      declare
         Data : String := String'Input (Input'Access);
      begin -- Now Data is "Hello World!"
         ...
      end;
   end;
   ...

7.4.2. Input streams

type Input_Stream
     (  Pool : access Persistent_Pool'Class
     )  is new Root_Stream_Type with private;

The input stream is set to the first allocated memory block written using Output_Stream. When reading from the stream the internal pointer moves through the allocated memory up to the last stored stream element.

procedure Close (Stream : in out Input_Stream);

This procedure disconnects the stream from memory and brings it into the state of a newly created object.

function Compare
         (  Left  : Input_Stream;
            Right : Stream_Element_Array
         )  return Precedence;
function
Compare
         (  Left  : Input_Stream;
            Right : String
         )  return Precedence;

These functions compare the unread contents of stream with another stream or an array of stream elements or characters of a string. The result is of the enumeration Less, Equal, Greater defined in Strings_Edit.Lexicographical_Order. An unopened stream is considered empty.

function End_Of (Stream : Input_Stream) return Boolean;

This function returns true if the end of stream is reached. For a newly created object the result is 0.

function Equal
         (  Stream : Input_Stream;
            Item   : Stream_Element_Array
         )  return Boolean;
function
Equal
         (  Stream : Input_Stream;
            Text   : String
         )  return Boolean;

These functions compare the unread contents of Stream with an array of stream elements or characters of a string. The result is true if both are equal. An unopened stream is considered empty.

function Get_First (Stream : Input_Stream) return Byte_Index;

This function returns the index of the first byte allocated. It can be used in Deallocate and in operations like Append and Open. Use_Error is propagated when no stream is open or written.

function Get_Length (Stream : Input_Stream) return Stream_Element_Count;

This function returns the number of elements allocated. For a newly created object the result is 0.

function Get_Unread (Stream : Input_Stream) return Stream_Element_Count;

This function returns the number of elements to read. At the beginning it is equal to Get_Length, at the end it is 0. For a newly created object the result is 0.

function Less
         (  Stream : Input_Stream;
            Item   : Stream_Element_Array
         )  return Boolean;
function
Less
         (  Stream : Input_Stream;
            Text   : String
         )  return Boolean;

These functions compare the unread contents of Stream with an array of stream elements or characters of a string. The result is true if the unread content of Stream is less than the second parameter. An unopened stream is considered empty.

procedure Open
          (  Stream : in out Input_Stream;
             Index  : Byte_Index
          );

This procedure sets the stream to read from the storage at Index. It must be called before reading from the stream. Use_Error is propagated when no memory pool file is open.

procedure Read
          (  Stream : in out Input_Stream;
             Item   : out Stream_Element_Array;
             Last   : out Stream_Element_Offset
          );

The implementation of stream interface read elements from the memory blocks allocated in the pool. Use_Error is propagated when no memory pool file is open. I/O errors are propagated on other errors.

procedure Rewind (Stream : in out Input_Stream);

This procedure re-opens the stream from the beginning.

procedure Write
          (  Stream : in out Input_Stream;
             Item   : Stream_Element_Array
          );

This procedure propagates Use_Error.

7.4.3. Generic look ahead

The generic procedure Look_Ahead is used to scan the unread contents of the stream without actually reading it:

generic
   type
User_Data_Type (<>) is limited private;
   type
Visitor_Type is access procedure
       
Contents  : Byte_Array;
           User_Data : in out User_Data_Type;
           Continue  : out Boolean
        );
procedure
Look_Ahead
          (  Stream    : Input_Stream'Class;
             Visit     : Visitor_Type;
             User_Data : in out User_Data_Type
          );

The parameter Stream is the input stream. User_Data is the data to pass along to the visitor call-back. Visit is the callback called on chucks of the allocated data not yet read through the stream. The procedure's first parameter Contents is the array of stream bytes to process. The parameter User_Data is same as in the call to Look_Ahead. The parameter Continue is used to indicate premature completion. When set to true the process is continued to the next chuck of unread allocated data. When set to false Look_Ahead returns immediately. Use_Error is propagated when the stream is not open.


[Back][TOC][Next]

8. Doubly-linked networks

The generic package Generic_Doubly_Linked_Web provides double-linked networks of items:

generic
   type
List_Identification_Type is (<>);
   type List_Item_Type (<>) is limited private;
   Pool : in out Root_Storage_Pool'Class;
package Generic_Doubly_Linked_Web is ...

The items can be of any type as specifies the formal parameter List_Item_Type. This includes limited and unconstrained types. They are not required to be tagged. So protected objects or tasks can be items. The items are never copied when inserted into, moved along or removed from a list. All operations on the network lists and their items are referential. Insertion and removal are O(1). An item of the network may participate several lists of different types. The set of distinct list types is determined by the formal parameter List_Identification_Type, which is a discrete type. For each value of this type each item has a pair of pointers (links). So the number of values of List_Identification_Type is the number of lists an item can be simultaneously situated in. For a standard doubly-linked list where an item can be in only one list, the parameter List_Identification_Type could be, for example:

   type List_Identification is (The_List);

For multiple lists as illustrated on the figure below, it could be:

   type List_Identification is (Blue, Green, Red);

doubly-linked list

The figure shows 5 items forming a network of 4 lists of 3 different types. For instance, the item B is in the blue list A-B-C-D, green list B-C-D and red list B-C-D-E.

The items are allocated in the storage pool specified by the formal parameter Pool. The service data (links) associated with an item are allocated in Pool.

The package provides the access type Node for referencing the items and the access type Web to reference the head items of lists. Note that each list is circular, so any of its items can be considered as a head. All list operations are defined in terms of Node and Web. Naturally, Web and Node are freely convertible to each other:

type Node is access List_Item_Type;
type
Web is new Node;

A distinct type was chosen to separate pointers to items from ones to lists. This was important for aliasing prevention. For example if Node were used in Delete, then the following would be legal:

Delete (Messages, List_Head, List_Head);

So the operation Delete could finalize the item referenced by the third parameter, and thus set List_Head to null. At the same time it would set the second parameter to point to the next item in the list, setting List_Head to some not null value. The result would depend on the compiler and the program were erroneous. This manifests an aliasing problem, which cannot occur because in Delete the second parameter has the type Web, making it impossible to mistakenly alias it to another type.

The representation clause

for Node'Size use Integer_Address'Size;

is used to prevent the compiler from making "fat" pointers out of Node and Web. This should actually be Address'Size, but that would be illegal because Address'Size is not a static expression in Ada. The type Integer_Address should have same size as Address on almost all architectures. If it is not, change it to an explicit number. Remember that the size is specified in bits.

A list item is created by using the allocator new. The obtained pointer is passed to Append (Prepend) or Insert as appropriate. The procedure Append is used for creating a new list. The list is specified by a pointer to its head. So it can be created like:

   Head : Web; -- Empty list
begin
   Append (Messages, Head, new Object);

Now Head points to the newly allocated item in the list. Subsequent items can be created as:

   Append (Messages, Head, new Object);

The first parameter of all list operations is the type of the list. If there were several types of lists, we could place the same item into different lists. For example:

type Signal is
   new abstract
Ada.Finalization.Limited_Controlled with private;
type Signal_List is (Alarm, Log);
type Some_Ptr is access Any; -- The default storage pool
package Signal_Lists is
   new
Generic_Doubly_Linked_Web
       (  Signal_List,
          Signal'Class,
          Some_Ptr'Storage_Pool
       );
...
Message := new Error_Message; -- Derived from Signal
Append (Alarm, Notifications_List, Message);
Append (Log,   System_Trace_List,  Message);

Both Append or Insert are intended for placing newly allocated items or items removed from their lists before. To move an item from one list to another of the same type they take an additional parameter Source to specify the head of the list, the element is removed from. These procedures are equivalent to a call to Remove with a subsequent Append or Insert as required. The difference between  Append and Insert is that for Append the list head is specified and thus the list can be empty. For Insert the list head is not identified and the list cannot be empty. The design of these operations was chosen to prevent, when possible, dangling pointers and garbage. For this reason all operations that remove an item from a list refer to the list head. When appropriately used, the rest of the list should not become unreferenced. The deallocator of the storage pool where the list items are kept, checks freed items for being unreferenced. When a freed item is still in a list, Program_Error is propagated out of Unchecked_Deallocation.

There is no special function to obtain the first element in the list because the list head is also the first element. So:

Element := Node (Container);

would do the job.

The following list operations are defined:

procedure Append
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : Node;
          );

This procedure inserts Element is at the end of Container. Element is either a newly allocated item or an item outside any lists of the type Brand. Constraint_Error is propagated when Element already is in a list. This includes Container. Container can be empty before a call to the procedure, in which case Element becomes the head of it. See also Prepend.

procedure Append
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : Node;
             Source    : in out Web
          );

This procedure is an equivalent to Remove followed by Append without the parameter Source. It moves Element from Source to Container. When Source and Container is the same list Container parameter takes advantage. Constraint_Error is propagated when Element is null. See also Prepend.

procedure Delete
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : in out Node
          );

This procedure removes Element from Container. The item following Element becomes the new list head. The operation is void when Element is null. The parameter Container is ignored when null. When Element after its removal does not belong to any list its target object is finalized, freed, and then Element is set to null.

procedure Erase
          (  Brand     : List_Identification_Type;
             Container : in out Web
          );

This procedure removes all elements from Container. When an element after its removal does not belong to any list its target object is finalized and freed. 

procedure Insert
          (  Brand    : List_Identification_Type;
             Position : Node;
             Element  : Node
          );

This procedure inserts Element after the item specified by the parameter Position. Element may not be in any list. Constraint_Error is propagated otherwise or when Element is null. Constraint_Error is also propagated when Position is null or not in a list of Brand type. Insert is similar to Append, with the difference that an arbitrary list item is used to indicate the insertion position. For this reason Append can deal with empty lists, while Insert requires at least one item in. To insert Element before Position use:

Insert (Brand, Previous (Brand, Position), Element); 

procedure Insert
          (  Brand    : List_Identification_Type;
             Position : Node;
             Element  : Node;
             Source   : in out Web
          );

This procedure is an equivalent to Remove followed by Insert. It moves Element from Source to the list of Position. The parameter has the same meaning as in Insert. When Position and Element refer the same item, the procedure does nothing. Constraint_Error is propagated when Element or Position is null. It is also propagated when Position is not in a list of Brand type.

function Is_Empty
         (  Brand     : List_Identification_Type;
            Container : Web
         )  return Boolean;

This function return true if Container is null. For containers of he type Web emptiness is equivalent to being null.

function Is_In
         (  Brand   : List_Identification_Type;
            Element : Node
         )  return Boolean;

This function return false if Element is null or else is not in any list of Brand type. Where Is_In returns false Next and Previous would raise Contraint_Error.

function Is_In (Element : Node) return Boolean;

This function return false if Element is null or else is not in any list of any type.

procedure Merge
          (  Brand : List_Identification_Type;
             Head  : in out Web;
             Tail  : in out Web
          );

This procedure merges two lists. The list Tail is appended to the list Head. Either of the list can be null. The operation is void if Head = Tail. After completion Head and Tail point to the merged sublists.

function Next
         (  Brand   : List_Identification_Type;
            Element : Node
         )  return Node;
function Next
         (  Brand     : List_Identification_Type;
            Container : Web
         )  return Node;

These functions return item following either Element or the head of Container. Constraint_Error is propagated in all cases when there is no next item. Note that when the element is in a list of Brand type, it always has a next element, maybe itself. The list is circular.

procedure Prepend
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : Node;
          );

This procedure inserts Element is in front of Container. Element is either a newly allocated item or an item outside any lists of the type Brand. Constraint_Error is propagated when Element already is in a list. This includes Container. Container can be empty before a call to the procedure, in which case Element becomes the head of it. See also Append.

procedure Prepend
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : Node;
             Source    : in out Web
          );

This procedure is an equivalent to Remove followed by Prepend without the parameter Source. It moves Element from Source to the beginning of Container. When Source and Container is the same list Container parameter takes advantage. Constraint_Error is propagated when Element is null. The operation is void when Container and Element refer to the same item See also Append.

function Previous
         (  Brand   : List_Identification_Type;
            Element : Node
         )  return Node;
function Previous
         (  Brand     : List_Identification_Type;
            Container : Web
         )  return Node;

These functions return item preceding either Element or the head of Container. Constraint_Error is propagated in all cases when there is no previous item. When the element is in a list of Brand type, it always has a next element, maybe itself, because the list is circular.

procedure Remove
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : Node
          );

This procedure removes Element from Container. The item following Element becomes the new list head. The operation is void when Element is not in a list or null. The parameter Container is ignored when null. Unlikely to Delete Element is never freed.

procedure Take
          (  Brand     : List_Identification_Type;
             Container : in out Web;
             Element   : out Node
          );

This procedure removes the first element from Container. The item following it becomes the new list head. The removed element is returned through the parameter Element. It is set to null when Container is empty. When returned Element is not null and not in any list (Is_In (Element) = false), then it becomes the caller's responsibility either to destroy Element or to return it back to a list.

function Dope_Size return Storage_Offset;

This informational function returns the number of storage elements the compiler places in front of an item. The value is estimated and is available only after first call to a list operation. Constraint_Error is propagated when the size is yet not determined.

[Back][TOC][Next]

8.1. Doubly-linked lists of networks (specialization)

The generic child package Generic_Doubly_Linked_Web.Generic_List provides a specialization of Generic_Doubly_Linked_Web constrained to one type of lists:

generic
   type
Brand : List_Identification_Type;
package
Generic_Doubly_Linked_Web.Generic_List is ...

The formal parameter Brand specifies the type of the list. The package defines specialized types of list nodes and list heads corresponding to Node and Web:

type Item is new Node;
type
List is new Web;

Items of the network can be allocated using either of these access types. The purpose of Item and List is specify which type links are involved in the specialized operations:

procedure Append (Container : in out List; Element : Item);

This procedure is specialized version of Append.

procedure Append
          (  Container : in out List;
             Element   : Item;
             Source    : in out List
          );
procedure
Append
          (  Container : in out List;
             Element   : Node;
             Source    : in out List
          );

This procedure is specialized version of moving Append. The parameter Element can be of either Item or Node types.

procedure Delete (Container : in out List; Element : in out Item);
procedure
Delete (Container : in out List; Element : in out Node);

This is a specialized version of Delete. The parameter Element can be of either Item or Node types.

procedure Erase (Container : in out List);

This is specialized version of Erase. It removes all elements from Container. When an element after its removal does not belong to any list its target object is finalized and freed. 

procedure Insert (Position : Item; Element : Item);
procedure
Insert (Position : Node; Element : Item);

This is a specialized version of Insert. The parameter Position can be of either Item or Node types. The parameter Element is only of Item type, because otherwise it were impossible to resolve names overloading. Though Item and Node resemble base and derived tagged types, they are not.

procedure Insert
          (  Position : Item;
             Element  : Item;
             Source   : in out List
          );
procedure
Insert
          (  Position : Item;
             Element  : Node;
             Source   : in out List
          );
procedure
Insert
          (  Position : Node;
             Element  : Item;
             Source   : in out List
          );
procedure
Insert
          (  Position : Node;
             Element  : Node;
             Source   : in out List
          );

These procedures are specialized versions of moving Insert. The parameters Position and Element can be of any combination of Item or Node types.

function Is_In (Element : Item) return Boolean;

These function return false if Element is null or else is not in any list of the Brand type.

procedure Merge (Head : in out List; Tail : in out List);

This procedure merges two lists. It is a specialized version of Merge.

function Next(Element : Item) return Item;
function Next(Container : List) return Item;

These are specialized versions of Next.

procedure Prepend (Container : in out List; Element : Item);

This procedure is specialized version of Prepend.

procedure Prepend
          (  Container : in out List;
             Element   : Item;
             Source    : in out List
          );
procedure
Prepend
          (  Container : in out List;
             Element   : Node;
             Source    : in out List
          );

This procedure is specialized version of moving Prepend. The parameter Element can be of either Item or Node types.

function Previous (Element : Item) return Item;
function Previous (Container : List) return Item;

These are specialized versions of Previous.

procedure Remove
          (  Container : in out List;
             Element   : Item
          );
procedure
Remove
          (  Container : in out List;
             Element   : Node
          );

This is specialized version of Remove. The parameter Element can be of either Item or Node types.

procedure Take
          (  Container : in out List;
             Element   : out Item
          );
procedure
Take
          (  Container : in out List;
             Element   : out Node
          );

This is a specialized version of Take. The parameter Element can be of either Item or Node types.

[Back][TOC][Next]

8.2. Doubly-linked lists

The generic package Generic_Doubly_Linked provides plain double-linked lists of elements allocated in the standard storage pool. The package is provided to simplify use of Generic_Doubly_Linked_Web for this case.

generic
   type
List_Item_Type (<>) is limited private;
package Generic_Doubly_Linked is
   ...
   package
Doubly_Linked is ...

The typical use of the package is as follows:

type My_Item is ...;
package
My_Lists is new Generic_Doubly_Linked (My_Item);
use
My_Lists.Doubly_Linked;

The package Doubly_Linked is an instance of Generic_Doubly_Linked_Web.Generic_List, which provides the types  Item and List and operations on them (see warning).

8.2.1. Doubly-linked list example

The example represents an implementation of a simple scheduler of jobs. There is a pool of worker tasks and a queue of abstract jobs. The tasks take jobs from the queue, process them and then return them back to the queue. A doubly-linked list us used as the queue implementation. Jobs are tagged, so the queue contains class-wide objects. The example is located in the test_components subdirectory.

File test_linked_lists_scheduler.ads:
with Ada.Finalization;
with Generic_Doubly_Linked;

package Test_Linked_Lists_Scheduler is
   --
   -- Job -- Abstract piece of work
   --
   type Job is
      abstract new
Ada.Finalization.Controlled with
         null record
;
   procedure Do_It (Work : in out Job) is abstract;

   package Job_List  is new Generic_Doubly_Linked (Job'Class);
   use Job_List.Doubly_Linked;

The package Test_Linked_List_Scheduler declares an abstract type Job, which is a piece of work to be done. The abstract procedure Do_It is to be overridden by a concrete job. It is called by a worker task to accomplish the job. The package Job_List instantiates Generic_Doubly_Linked with Job'Class as the parameter. The package Job_List.Doubly_Linked provides a doubly linked list of Job'Class objects. Note that the list elements are class-wide, i.e. it can contain any kind of jobs.

File test_linked_lists_scheduler.ads (continuation):
   --
   -- Worker -- A task doing jobs
   --

   task type Worker;
   --
   -- Submit -- A new job for processing
   --
   procedure Submit (Work : Item);
   --
   -- Shut_Down -- Purge the jobs queue and stop workers
   --
   procedure Shut_Down;

The type Worker is a task doing jobs. The procedure Submit is used to submit a job. It has the parameter of the type Item which is an access to Job'Class. The procedure Shut_Down is used to purge the jobs queue and stop all workers.

File test_linked_lists_scheduler.ads (continuation):
   --
   -- Print_Me -- A concrete job, prints some text
   --

   type Print_Me (Length : Natural) is new Job with record
      Text : String (1..Length);
   end record;
   procedure Do_It (Work : in out Print_Me);
   function Have_To_Print (Text : String) return Item;

end Test_Linked_Lists_Scheduler;

The type Print_Me is a concrete job. It prints a text on the screen.

File test_linked_lists_scheduler.adb:
with Ada.Text_IO;  use Ada.Text_IO;

package body Test_Linked_Lists_Scheduler is

   Queue_Closed : exception;

   protected Waiting_Queue is
      entry
 Get_For_Service (Work : out Item);
      procedure Shut_Down;
      procedure Submit (Work : Item);
   private
      Queue  : List;
      Closed : Boolean;
   end Waiting_Queue;

The protected object Waiting_Queue holds the list of jobs waiting for service. It has the entry point Get_For_Service called by a worker to get a new job to do. The exception Queue_Closed is used to notify a worker that it has to exit. The procedure Shut_Down closes the queue. The procedure Submit puts a new job into the queue.

File test_linked_lists_scheduler.adb (continuation):
   protected body Waiting_Queue is
      entry
Get_For_Service (Work : out Item)
         when Closed or else Queue /= null is
      begin
         if
Closed then
            raise
Queue_Closed;
         else
            Take (Queue, Work); -- The first in the list
         end if;
      end Get_For_Service;

      procedure Submit (Work : Item) is
      begin

         Append (Queue, Work); -- Add to the end
         if Closed then
            Erase (Queue);
         end if;
      end Submit;

      procedure Shut_Down is
      begin

         Closed := True;
         Erase (Queue);
      end Shut_Down;

   end Waiting_Queue;

The implementation of Waiting_Queue is straightforward. The procedure Get_For_Service uses Take to extract the first job from the queue. Its barrier contains Queue /= null, which is non-empty queue test. The barrier is always true after a call to Shut_Down. In this case Queue_Closed is propagated out of Get_For_Service. The procedure Submit places a new Job into the queue.

File test_linked_lists_scheduler.adb (continuation):
   task body Worker is
      This : Item;
   begin
      loop

         Waiting_Queue.Get_For_Service (This);
         -- Now we are holding This, so be careful with exceptions,
         -- the item must back to the queue in all cases
         begin
            This.Do_It;
               -- Item has been serviced, return it back
            Waiting_Queue.Submit (This);
         exception
            when
Queue_Closed =>
               exit;
            when others =>
               Waiting_Queue.Submit (This);
         end;
      end loop;
   end Worker;

The implementation of a worker task runs an infinite loop in which it takes a job from the queue using Get_For_Service and then calls Do_It for the job (note, Ada 2005 syntax). After that it submits the job back. When Queue_Closed is propagated out of Get_For_Service, the worker exits.

File test_linked_lists_scheduler.adb (continuation):
   procedure Submit (Work : Item) is
   begin

      Waiting_Queue.Submit (Work);
   end Submit;

   procedure Shut_Down is
   begin

      Waiting_Queue.Shut_Down;
   end Shut_Down;

The implementation of Submit and Shut_Down procedures call to the corresponding ones of the protected object.

File test_linked_lists_scheduler.adb (continuation):
   procedure Do_It (Work : in out Print_Me) is
   begin
  
   Put_Line (Work.Text);
   end
Do_It;

   function
Have_To_Print (Text : String) return Item is
   begin
      return
         new
Print_Me'
             (  Job
             with
                Length => Text'Length,
                Text   => Text
             );
   end Have_To_Print;

end Test_Linked_Lists_Scheduler;

The implementation of the Print_Me job. The procedure Do_It prints the text. The function Have_To_Print allocates a new job object.

File test_linked_lists_scheduler_test.adb:
with Test_Linked_Lists_Scheduler;  use Test_Linked_Lists_Scheduler;

procedure Test_Linked_Lists_Scheduler_Test is
   W1 : Worker;
   W2 : Worker;
   W3 : Worker;
   W4 : Worker;
   W5 : Worker;
begin
   Submit (Have_To_Print ("The"));
   Submit (Have_To_Print ("quick"));
   Submit (Have_To_Print ("brown"));
   Submit (Have_To_Print ("fox"));
   Submit (Have_To_Print ("jumps"));
   Submit (Have_To_Print ("over"));
   Submit (Have_To_Print ("the"));
   Submit (Have_To_Print ("lazy"));
   Submit (Have_To_Print ("dog"));
   delay 10.0;
   Shut_Down;
end Test_Linked_Lists_Scheduler_Test;

The test program creates five worker tasks and submits 9 jobs. After 10 seconds of processing it terminates.


[Back][TOC][Next]

9. Graphs

Directed graph is a binary relation G:E×E→[0,1] defined on a set of nodes E (also called vertices). Two nodes a and b are said connected by an edge (also by an arrow or arc) leading from a to b in the graph G when aGb. Here the node a is called parent, the node b is called child. A directed graph is acyclic when the transitive closure G* of the graph G is irreflexive (i.e. aG*a does not hold for any node a). The transitive closure of a graph is an infinite union of compositions of the relation G:

G* = G ∪ G∘G ∪ G∘G∘G ∪...

where composition and union of relations are defined as:

a,b   aR∘Sb = ∃c aRccSb    aR∪Sb = aRbaSb

The meaning of the transitive closure G* is that aG*b holds when there is a path of any length from a to b in G. In a directed acyclic graph no path leads back to any node. The tree is a case of the directed acyclic graph when additionally for any node there is no more than one parent. Thus any types of trees can be represented by a directed graph. The undirected graph is a directed graph when G is symmetric (commutative).

directed graph

A weighted graph has a weight associated with each edge. The binary relation G is generalized to a function mapping nodes to the weights G:E×E→W. The union of weighted graphs can be then defined using some operation +:W×W→W on the weights:

a,b aR∪Sb = aRb+aSb

The composition of weighted graphs is defined using + and a second operation *:W×W→W:

a,b aR∘Sb = Π
c∈E
aRc+cSb

The transitive closure G* in these terms may exist or not depending on the chosen operations + and *.

directed weighted graph

The above represents an example of a directed weighted graph used in syntax analysis (state automate describing a numeric literal). The nodes are states, the weights are sets of chains of characters (patterns). The operation + is concatenation, the operation * is alternation.

[Back][TOC][Next]

9.1. Directed graphs

The package Generic_Directed_Graph provides a generic implementation of directed graphs:

generic
   type
Node_Type (<>) is limited private;
  
Pool                  : in out Root_Storage_Pool'Class;
   Minimal_Parents_Size  : Positive := 16;
   Minimal_Children_Size : Positive := 16;
   Increment             : Natural  := 50;
   with function Equal (Left, Right : access Node_Type) return Boolean is <>;
   with function Less  (Left, Right : access Node_Type) return Boolean is <>;
package
Generic_Directed_Graph is ...

The formal parameters are:

The formal operations Equal and Less are required for the sets of children or parents of a given node, which has to be sorted. They are also used for enumeration of the children and parents. The node position in the operations like Get_Child is determined by this order. An implementation of Equal and Less can be based on the contents of the nodes. In other cases, when the order of nodes in is of no importance, the helper package Generic_Address_Order can be used to produce the operations Equal and Less for Node_Type. In this case the nodes will be ordered according to their memory addresses.

The graph nodes are referenced using the access type Node defined in the package:

type Node is access Node_Type;

The type is a pool specific access type bound to the storage pool defined in the package. The pool is a proxy pool, which ultimately takes storage from the pool specified by the formal parameter Pool. The proxy storage pool maintains the sets of parent and children nodes transparently to the node object. Thus there is no need to derive graph nodes from a dedicated parent type or interface related specifically to the graph implementation.

The package defines the types:

type Subgraph_Type is mod 2**3;

The values of the type Subgraph_Type characterize a node relatively to the given one The constants are defined:

The array of nodes:

type Nodes_Array is array (Positive range <>) of Node;

The following operations are defined on Node:

procedure Connect
          (  Parent  : Node;
             Child   : Node;
             Acyclic : Boolean := True
          );

This procedure creates a directed edge from Parent to Child. When the edge already exists this operation is void. In the case when Parent has a child different from Child, yet equivalent to it according to the provided comparison operation, or else Child has a parent equivalent, but different from Parent, then Argument_Error is propagated. Additionally when Acyclic is true, it is checked that the new edge would not create a cycle in the graph, that is when Child would become or already is an ancestor of Parent. Otherwise Constraint_Error is propagated. Note that checking potentially requires traversal of all nodes of the graph. Constraint_Error is also propagated when either Parent or Child is null.

procedure Delete
          (  Vertex   : in out Node;
             Subgraph : Subgraph_Type := Any
          );

This procedure deletes a subgraph connected to Vertex. The parameter Subgraph specifies which parts of the graph to be removed and freed: For example in order to delete Vertex and all its descendants Subgraph should be Descendant or Self. When the object referenced by Vertex is destroyed, Vertex is set to null. The operation is void when Vertex is null. Delete does not create new edges, therefore a connected graph can become disjoint. See Remove, which keeps graph connected.

procedure Disconnect (Parent : Node; Child : Node);

This procedure removes the edge from Parent to Child if the edge exist. Otherwise the operation is void. For example, In order to move a subtree from one parent node to another one use Disconnect followed by Connect. Constraint_Error is propagated when either Parent or Child is null.

function Find_Child (Parent : Node; Child : Positive) return Natural;

This function returns the position of Child in the list of children of the node Parent. All children of a node are enumerated from 1 according to the formal functions Equal and Less. See also Get_Child. The result is 0 when Child is not a child of Parent. Constraint_Error is propagated when Parent or Child is null.

function Find_Parent (Parent : Node; Child : Positive) return Natural;

This function returns the position of Parent in the list of parents of the node Child. All parents of a node are enumerated from 1 according to the formal functions Equal and Less. See also Get_Parent. The result is 0 when Parent is not a parent of Child. Constraint_Error is propagated when Parent or Child is null.

procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node);

This procedure deletes the node object. Program_Error is propagated when the node is in a graph. This includes the cases when the node is a parent / child of itself. See the function Is_Connected.

function Get_Children (Parent : Node) return Nodes_Array;
function
Get_Children (Parent : Node) return Node_Sets.Set;

This function returns the array containing the children nodes of Parent. Constraint_Error is propagated when Parent is null.

function Get_Children_Number (Parent : Node) return Natural;

This function returns the number of children of the node Parent. Constraint_Error is propagated when Parent is null.

function Get_Child (Parent : Node; Child : Positive) return Node;

This function returns a child of the node Parent by its position Child. Constraint_Error is propagated when Child > Get_Children_Number (Parent) or else Parent is null.

function Get_Parent (Child : Node; Parent : Positive) return Node;

This function returns a parent of the node Child by its position Parent. Constraint_Error is propagated when Parent > Get_Parents_Number (Child) or else Child is null.

function Get_Parents (Child : Node) return Nodes_Array;
function
Get_Parents (Child : Node) return Node_Sets.Set;

This function returns the array or set containing the parent nodes of Child. Constraint_Error is propagated when Child is null.

function Get_Parents_Number (Child : Node) return Natural;

This function returns the number of parents of the node Child. Constraint_Error is propagated when Child is null.

function Is_Ancestor (Parent : Node; Child : Node) return Boolean;

This function evaluates the transitive closure of G. The result is true when Parent G* Child, i.e. when there is a path in G from Parent to Child. Constraint_Error is propagated when either Parent or Child is null.

function Is_Connected (Vertex : Node) return Boolean;

This function returns true when the node Vertex is connected by an edge. Constraint_Error is propagated when Vertex is null.

function Is_Descendant (Child : Node; Parent : Node) return Boolean;

This function evaluates the transitive closure of G-1. The result is true when Child G-1* Parent, i.e. when there is a path in G-1 from Child to Parent. This is equivalent to Is_Ancestor (Parent, Child), but computed differently by tracking the edges backwards from Child to Parent. Constraint_Error is propagated when either Parent or Child is null.

function Is_Sibling (Left, Right : Node) return Boolean;

This function returns true if Left and Right share at least one parent. Constraint_Error is propagated when either Left or Right is null.

function Precedes (Left, Right : Node) return Boolean;

Comparison of nodes used in node sets, induced by the formal function Less. The value null is considered preceding all valid access values.

function Related (Parent : Node; Child : Node) return Boolean;

This function evaluates G. The result is true when Parent G Child i.e. when there is an edge from Parent to Child. Constraint_Error is propagated when either Parent or Child is null.

procedure Remove (Vertex : Node);

This procedure removes Vertex from the graph. Each pair of edges leading from a parent of Vertex to a child of Vertex, is replaced by an edge from the parent to the child, thus the graph remains connected. The effect of the operation is obtaining an equivalent graph, such that aG'b = aGb for all nodes except the removed. The object pointed by Vertex is not deleted. Constraint_Error is propagated when Vertex is null.

function Same (Left, Right : Node) return Boolean;

The nodes comparison function used in node sets, induced by the formal function Equal. The value null is considered preceding all valid access values.

The package instantiates the packages Generic_Unbounded_Array and Generic_Set with the type Node:

package Node_Arrays is
   new
Generic_Unbounded_Array (Positive, Node, Nodes_Array, null);
package
Node_Sets is
   new
Generic_Set (Node, null, "=" => Same, "<" => Precedes);

[Back][TOC][Next]

9.2. Directed weighted graphs

The package Generic_Directed_Weighted_Graph provides a generic implementation of directed weighted graphs:

generic
   type
Node_Type (<>) is limited private;
   type
Weight_Type (<>) is private; 
  
Pool                  : in out Root_Storage_Pool'Class;
   Minimal_Parents_Size  : Positive := 16;
   Minimal_Children_Size : Positive := 16;
   Increment             : Natural  := 50;
   with function Equal (Left, Right : access Node_Type  ) return Boolean is <>;
   with function Equal (Left, Right : access Weight_Type) return Boolean is <>;
   with function Less  (Left, Right : access Node_Type  ) return Boolean is <>;
   with function Less  (Left, Right : access Weight_Type) return Boolean is <>;
package
Generic_Directed_Weighted_Graph is ...

The formal parameters are:

The package is similar to Generic_Directed_Graph. The following entities are equivalent:

The operations Find_Child, Get_Child, Get_Children (returning an array) are different in that respect that they are using the order determined by the comparisons of access Weight_Type specified by the corresponding formal functions Equal and Less.

The following operations are different or new:

procedure Classify
          (  Parent : Node;
             Weight : Weight_Type;
             Lower  : out Natural;
             Upper  : out Natural
          );

This procedure classifies the children of Parent according to the value of Weight. The output Lower is the position of the child node with the greatest weight less or equal to the value of Weight. When there is no such child Lower is 0. The output Upper is the position of the child node with the least weight greater or equal to the value Weight. When there is no such child Upper is the number of children + 1. The behavior of Classify ensures that when there is a child node with the weight equal to the value Weight, then Lower = Upper = the position of the child. Otherwise Lower + 1 = Upper. When Lower and Upper are valid positions of nodes, then the interval of weights corresponding to these nodes contains Weight. Constraint_Error is  propagated when Parent is null.

procedure Connect
          (  Parent  : Node;
             Child   : Node;
             Weight  : Weight_Type;
             Acyclic : Boolean := True
          );

This procedure creates a directed edge from Parent to Child with the weight specified by the parameter Weight. When the edge already exists and according to the formal comparison operations the weights are equivalent, this operation replaces the old weight with the value of Weight. When there is an edge from Parent  to a child node different from Child, with the weight equivalent to Weight according to the formal comparison operations of the weights, Argument_Error is propagated. It is also propagated when there is an edge from a parent node to Child, such that the node is different from Parent, but considered equivalent according to the formal operations of node comparisons. Additionally when Acyclic is true, it is checked that the new edge would not create a cycle in the graph, that is when Child would become or already is an ancestor of Parent. Otherwise Constraint_Error is propagated. Note that checking potentially requires traversal of all nodes of the graph. Constraint_Error is also propagated when either Parent or Child is null.

function Get_Weight (Parent : Node; Child : Positive) return Weight_Type;
function
Get_Weight (Parent : Node; Child : Node    ) return Weight_Type;

These functions return the weight of the edge Parent - Child. The child can be specified either by its position or else directly as a node. Constraint_Error is propagated when there is no such edge or else Parent or Child is null. The position of the node is determined  by the comparisons of access Weight_Type specified by the corresponding formal functions Equal and Less.

9.2.1. Suffix tree example

The example represents a straightforward implementation of suffix trees. The example is located in the test_components subdirectory.

File test_suffix_tree.ads:
with Generic_Directed_Weighted_Graph;
with Generic_Address_Order;

package Test_Suffix_Tree is
   type
Node_Type is null record;    -- Nodes have no contents
   type Default is access Node_Type; -- Default access type
   --
   -- Node_Order -- Ordering of nodes by their addresses
   --

   package Node_Order is new Generic_Address_Order (Node_Type);
   use Node_Order;
   --
   -- Ordering of the edge weights
   --

   function Equal (Left, Right : access Character) return Boolean;
   function Less  (Left, Right : access Character) return Boolean;
   --
   -- Directed graph of Node_Type weighted by Character values
   --

   package Character_Weighted_Graphs is
      new
Generic_Directed_Weighted_Graph
          (  Node_Type   => Node_Type,
             Weight_Type => Character,
             Pool        => Default'Storage_Pool,
             Minimal_Parents_Size => 1
          );
   subtype Suffix_Tree is Character_Weighted_Graphs.Node;
   --
   -- Build -- Creates the suffix tree from a string
   --

   function Build (Text : String) return Suffix_Tree;
   --
   -- Print -- Outputs the tree
   --

   procedure Print (Tree : Suffix_Tree; Prefix : String := "");

end Test_Suffix_Tree;

The package defines Node_Type as an empty record, since suffix tree nodes would contain no data. The order of nodes is irrelevant, therefore Generic_Address_Order is instantiated to provide some order of nodes. The type of edge weight is Character. The order of children nodes is determined by the weights of incoming edges. The operations Equal and Less use character comparison to order children. The instance of Generic_Directed_Weighted_Graph specifies Minimal_Parents_Size as 1, because tree has no more than one parent per node. Then the package declares two operations Build to create a tree and Print to output it onto the standard output.

File test_suffix_tree.adb:
with Ada.Text_IO;  use Ada.Text_IO;

package body Test_Suffix_Tree is
   use
Character_Weighted_Graphs;

   function Equal (Left, Right : access Character) return Boolean is
   begin
      return
Left.all = Right.all;
   end Equal;

   function Less (Left, Right : access Character) return Boolean is
   begin

      return Left.all < Right.all;
   end Less;

The implementation of Equal and Less is obvious.

File test_suffix_tree.adb (continuation):
   function Build (Text : String) return Suffix_Tree is
      Root  : Node := new Node_Type;
      Focus : Node;
      Lower : Natural;
      Upper : Natural;
   begin
      for
Index in Text'Range loop
         Focus := Root;
         for Current in Index..Text'Last loop
            Classify (Focus, Text (Current), Lower, Upper);
            if Lower = Upper then
               Focus := Get_Child (Focus, Lower);
            else
               declare

                  Branch : Node := new Node_Type;
               begin
                  Connect (Focus, Branch, Text (Current));
                  Focus := Branch;
               end;
            end if;
         end loop;
      end loop;
      return Root;
   end Build;

The implementation of Build creates the root node. Then it scans the string for its suffixes. For each suffix the tree is matched from the top. The procedure Classify is used to match the current character of the suffix against the edges of the current tree node. When an edge for the character exists the edge is followed. When no edge exists a new node is created connected by an edge weighted by the character and then this edge is followed.

File test_suffix_tree.adb (continuation):
   procedure Print (Tree : Suffix_Tree; Prefix : String := "") is
   begin
      for
Index in 1..Get_Children_Number (Tree) loop
         if
Index > 1 then
            Put (Prefix);
         end if;
         Put (Get_Weight (Tree, Index));
         Print (Get_Child (Tree, Index), Prefix & ' ');
      end loop;
      if Get_Children_Number (Tree) = 0 then
         New_Line;
      end if;
   end Print;

end Test_Suffix_Tree;

The package Test_Suffix_Tree can be used as follows:

with Test_Suffix_Tree;  use Test_Suffix_Tree;
                        use Character_Weighted_Graphs;
procedure Test is
 
  Tree : Suffix_Tree := Build ("mississippi");
begin
   Print (Tree);
   Delete (Tree);
end Test;

The output should look like:

ippi
 ssippi
    ssippi
mississippi
pi
 pi
sippi
  ssippi
 sippi
   ssippi


[Back][TOC][Next]

10. Lock-free data structures

Lock-free data structures provide shared access to their content without locking. For multi-core and other architectures of shared memory locking might be expensive compared to some extra overhead required for implementation of a lock-free access. So lock-free structures might appear more efficient. Another potential advantage of lock-free access is deadlock prevention. A sufficiently more complex use and less predictable behavior (mostly in the cases where a corresponding locking structure would block) count to the disadvantages of lock-free structures. The choice between lock-free and locking structure depends on each concrete case.

Here it is necessary to clarify what is understood under the term lock-free access. Clearly no processor instruction can be executed in a lock-free manner. There is always some sort of synchronization involved which ultimately is resulted in a non instant execution time. Neither a bounded access time is meant here, because a lock-free access can be interrupted and preempted.

In the context of the programming language Ada we define as lock-free any operations that are not:

  1. potentially blocking as it is defined in the Ada Language Reference Manual 9.5.1;
  2. involving calls to protected subprograms (ibidem), including protected functions, procedures and entries.

From this definition follows that in particular accessing atomic objects is lock-free. For atomic objects see the Ada Language Reference Manual C.6.

[Back][TOC][Next]

10.1. FIFO

10.1.1. Lock-free FIFO of definite elements

The package Generic_FIFO provides a lock-free first in, first out queue, which can be used between one publisher and one subscriber.

fifo

The package is generic:

generic
   type
Element_Type is private;
package
Generic_FIFO is ...

The type of FIFO is:

type FIFO (Size : Positive) is
   new
Ada.Finalization.Limited_Controlled with private;

The discriminant Size determines the maximal size of the queue. A queue can hold no more than Size - 1 elements. The following primitive operations are defined in the package:

procedure Delete (Queue : in out FIFO; Count : Natural := 1);

This procedure removes Count elements from Queue. When the queue contains Count or less elements, it becomes empty. The elements are removed from the same queue end Get and Peek access. Therefore it shall be called from the same task.

procedure Get
          (  Queue   : in out FIFO;
             Element : out Element_Type;
             Empty   : out Boolean
          );

This function takes one element out of Queue. When Queue is empty the output parameter Empty is set to true and Element is not changed. Otherwise Element is the element taken and Empty is set to false.

function Get (Queue : FIFO) return Element_Type;

This is a variant of Get which raises Constraint_Error when Queue is empty.

function Is_Empty (Queue : FIFO) return Boolean;

This function returns true if Queue is empty.

function Is_Full (Queue : FIFO) return Boolean;

This function returns true if Queue is full.

function Is_Preserved (Queue : FIFO; Element : Element_Type)
   return Boolean;

This function returns true if Element has to be preserved in Queue by the procedure Purge. This is the default behavior. The function can be overridden in order to change the behavior of Purge.

procedure Peek
          (  Queue   : FIFO;
             Element : out Element_Type;
             Empty   : out Boolean
          );

This function returns the element of Queue, a Get operation would take. Unlikely to Get it does not remove the element from Queue. When Queue is empty the output parameter Empty is set to true and Element is not changed. Otherwise Element is the element at the Queue beginning and Empty is set to false.

function Peek (Queue : FIFO) return Element_Type;

This is a variant of Peek which raises Constraint_Error when Queue is empty.

procedure Purge
          (  Queue  : in out FIFO;
             Purged : out Natural
          );

This procedure removes all elements for which Is_Preserved returns false. The parameter Purged is set to the number of elements removed from the Queue. The default implementation of Is_Preserved returns true, so it needs to be overridden to make Purge removing any element. Observe also that there is a potential race condition in Purge when new elements are added concurrently. The newly added elements might be not removed. If it is essential to remove the race condition, the implementation of Is_Preserved must return false for newly added elements.

procedure Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
             Full    : out Boolean
          );

This procedure places Element into Queue. When Element is put, Full is set to false. Otherwise it is set to true.

procedure Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
          );

This is a variant of the procedure above which raises Constraint_Error when Queue is full.

10.1.2. Signaled FIFO of definite elements

The child package Generic_FIFO.Signaled_FIFO provides FIFO with almost lock-free behavior. The implementation locks only if the operation has to block. That is, upon reading from an empty queue or else writing into a full queue. Otherwise it is lock-free.

generic
package
Generic_FIFO.Generic_Signaled is ...

The type of Signaled_FIFO is:

type Signaled_FIFO is new FIFO with private;

The following operations are added or have an altered behavior:

procedure Cancel (Queue : in out Signaled_FIFO);

This procedure releases all blocked tasks. Get and Peek called for an empty queue, as well as Put called for a full queue are blocked. Their waiting is prematurely ended when Cancel is called. In this case End_Error is propagated out the corresponding calls. Note that differently to Get, Peek and Put, this procedure can be called from any task.

function Get (Queue : Signaled_FIFO) return Element_Type;
function
Get (Queue : Signaled_FIFO; Timeout : Duration)
   return Element_Type;

These functions block when Queue is empty. If a timeout is specified, upon its expiration, Contraint_Error is propagated as it would for the parent type. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

function Peek (Queue : Signaled_FIFO) return Element_Type;
function
Peek (Queue : Signaled_FIFO; Timeout : Duration)
   return Element_Type;

These functions block when Queue is empty. If a timeout is specified, upon its expiration, Contraint_Error is propagated. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

procedure Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
          );
procedure
Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
             Timeout : Duration
          );

These procedures block when Queue is full. If a timeout is specified, upon its expiration, Contraint_Error is propagated. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

10.1.3. Lock-free FIFO of indefinite elements

The package Generic_Indefinite_FIFO provides a lock-free first in, first out queue, which can be used between one publisher and one subscriber. It is similar to Generic_FIFO except that it can handle elements of indefinite types, such as unconstrained arrays or class-wide types. The package is generic:

generic
   type
Element_Type (<>) is private;
package
Generic_Indefinite_FIFO is ...

The type of FIFO is:

type FIFO (Size : Storage_Count) is
   new
Ada.Finalization.Limited_Controlled with private;

The discriminant Size determines the maximal size of the queue in storage elements. A queue can hold objects which total size in storage elements is no more than Size - 1. This is not the exact limit, which could be lower due to memory fragmentation. There can be no more than two fragments, except than small holes needed for alignment reasons. Note that because the element size is unknown in advance, it is impossible to determine whether the queue is full

The following primitive operations are defined in the package:

procedure Delete (Queue : in out FIFO; Count : Natural := 1);

This procedure removes Count elements from Queue. When the queue contains Count or less elements, it becomes empty. The elements are removed from the same queue end Get and Peek access. Therefore it shall be called from the same task.

function Get (Queue : FIFO) return Element_Type;

This function returns one element from Queue. The element is removed from the queue. Constraint_Error is propagated when the queue is empty.

function Free_Space (Queue : FIFO) return Storage_Count;

This function returns the maximal available space in Queue. Note that the result greater than the element size does not yet guarantee a consequent Put would not fail. The queue space can be fragmented up to two segments. Therefore only when the result is twice as required then Put will not fail.

function Is_Empty (Queue : FIFO) return Boolean;

This function returns true if Queue is empty.

function Peek (Queue : FIFO) return Element_Type;

This function is similar to Get except that it does not remove the element from Queue. Constraint_Error is propagated when the queue is empty.

procedure Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
          );

This procedure put Element into Queue. Constraint_Error when Queue does not have enough space for Element.

10.1.4. Signaled FIFO of indefinite elements

The child package Generic_Indefinite_FIFO.Signaled_FIFO provides FIFO with almost lock-free behavior. The implementation locks only if the operation has to block. That is, upon reading from an empty queue or else writing into a full queue. Otherwise it is lock-free.

generic
package
Generic_Indefinite_FIFO.Generic_Signaled is ...

The type of Signaled_FIFO is:

type Signaled_FIFO is new FIFO with private;

The following operations are added or have an altered behavior:

procedure Cancel (Queue : in out Signaled_FIFO);

This procedure releases all blocked tasks. Get and Peek called for an empty queue, as well as Put called for a full queue are blocked. Their waiting is prematurely ended when Cancel is called. In this case End_Error is propagated out the corresponding calls. Note that differently to Get, Peek and Put, this procedure can be called from any task.

function Get (Queue : Signaled_FIFO) return Element_Type;
function
Get (Queue : Signaled_FIFO; Timeout : Duration)
   return Element_Type;

These functions block when Queue is empty. If a timeout is specified, upon its expiration, Contraint_Error is propagated as it would for the parent type. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

function Peek (Queue : Signaled_FIFO) return Element_Type;
function
Peek (Queue : Signaled_FIFO; Timeout : Duration)
   return Element_Type;

These functions block when Queue is empty. If a timeout is specified, upon its expiration, Contraint_Error is propagated. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

procedure Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
          );
procedure
Put
          (  Queue   : in out FIFO;
             Element : Element_Type;
             Timeout : Duration
          );

These procedures blocks when Queue is full. If a timeout is specified, upon its expiration, Contraint_Error is propagated. End_Error is propagated when waiting was prematurely cancelled by a call to Cancel.

[Back][TOC][Next]

10.2. Blackboard

Blackboard is a data structure of broadcasted messages. Publishers put their messages (elements) onto the blackboard. The blackboard elements remain accessible there for the subscribers until newly put elements override them. The elements order in the blackboard is first in, first out. Accessing the blackboard for read is lock-free. Additionally the blackboard provides mechanisms for elements identification and enumeration. When an element is put into the blackboard it receives a unique reference. The reference can be used to access the element so long it is in the blackboard. After element expiration a reference can still be used to determine this condition. References can be advanced to the next element or else to the first not yet expired element in the blackboard.

blackboard

10.2.1. Single publisher blackboard

The package Generic_Blackboard provides a blackboard safe to use with one publisher writing into it, and any number of subscribers accessing it only for read. The package is generic:

generic
   type
Element_Type (<>) is private;
package
Generic_Blackboard is ...

The generic parameter is the type of the elements in the blackboard.  The elements are stored in the blackboard temporarily. Newly coming elements override the most elder ones. The elements can be indefinite, tagged and class-wide. However

Because the elements in the blackboard are destructed automatically in an implicit way, it is not allowed to use elements of controlled types as well as of any other types requiring non-null finalization.

The type of a blackboard is:

type Blackboard (Size : Storage_Count) is
   new
Ada.Finalization.Limited_Controlled with private;

The discriminant Size determines the size of the blackboard in storage elements. The time an element survives in the blackboard depends on the blackboard size, the size of the elements and on how frequently elements are put into it. The elements in the blackboard are accessed through references which know if the destination is still valid:

type Reference is private;

When the compiler does not support atomic access to 64-bit integers, an alternative version based on GCC's built-in functions is used. When compiling from sources using the project file, the scenario variable Atomic_Access controls the method to use:
  • Pragma-atomic (subdirectory atomic-access/ada)
  • GCC-built-ins (subdirectory atomic-access/gcc)

Precompiled distributions select an appropriate implementation automatically.

The following primitive operations are defined in the package:

function First (Storage : Blackboard) return Reference;

This function returns a reference to the first element available in Storage. Note that this function can return an invalid reference when used concurrently. It that case the caller should call it again, unless the result is greater than Storage according to >. Together with Next, this function can be used to scan the elements of a blackboard.

function Get (Storage : Blackboard; Pointer : Reference)
   return Element_Type;

This function returns an element by reference. Constraint_Error is propagated when Pointer is not a valid reference. Note that any reference can become invalid when the blackboard is being written.

function Is_Valid (Storage : Blackboard; Pointer : Reference)
   return
Boolean;

This function returns true if Pointer is a valid reference in Storage. It is equivalent to not Storage > Pointer and not Storage < Pointer.

procedure Next
          (  Storage : Blackboard;
             Pointer : in out Reference;
             Sequent : out Boolean
          );

This procedure advances the reference Pointer to the next element. When Pointer is valid and there is a next element then Sequent is set to true and Pointer will refer to that element. When Pointer refers to a lost element then it is set to the first available element and Sequent is set to false. When Pointer refers to a not yet available element, it is not changed and Sequent is set to true. The following code snippet illustrates how Next can be used to scan a blackboard:

Data : Blackboard;
   ...
task body Scanner is
   Element : Reference;
   Sequent : Boolean;
begin
   Element := First (Data); -- The first element
   loop
      if not
(Element > Data) then
         begin
           
... Get (Data, Element) ... -- Use element
         exception
            when
Constraint_Error =>
               ... -- The element is lost
         end
;
        
Next (Data, Element, Sequent);
         if not
Sequent then
           
... -- Some elements were lost
         end if
;
      else
         delay
0.010;  -- Wait for new elements to come
      end if
;
   end loop
;
end Scanner;

Note that lost elements can be detected by the scanner. This is the best what a scanner could have, because blackboard is a lock-free structure and it cannot block the publisher writing into it

procedure Next
          (  Storage : Blackboard;
             Pointer : in out Reference;
             Sequent : out Boolean
          );

This procedure advances the reference Pointer to the next element. When Pointer is valid and there is a next element then Sequent is set to true and Pointer will refer to that element. When Pointer refers to a lost element then it is set to the first available element and Sequent is set to false. When Pointer refers to a not yet available

procedure Put
          (  Storage : in out Blackboard;
             Element : Element_Type;
             Pointer : out Reference
          );
procedure
Put
          (  Storage : in out Blackboard;
             Element : Element_Type
          );

These procedures put Element into Storage and returns a reference to it, when the parameter Pointer is used. The operation overrides the most outdated items in the blackboard making references to them invalid. Storage_Error is propagated when Element is too large to fit into Storage even if it alone there. The procedure is the only one which shall be used from one task or else exclusively.

procedure Put
          (  Storage  : in out Blackboard;
             Element  : Element_Type;
             Preserve : Reference;
             Pointer  : out Reference
             Success  : out Boolean
          );
procedure
Put
          (  Storage  : in out Blackboard;
             Element  : Element_Type
             Preserve : Reference;
             Success  : out Boolean
          );

These are variants of Put, which prevent overriding of the items referenced by Preserve and later. The parameter Success is set to true when Element was successfully put into Storage. It is set to false when Element was not put, because there is no room in Storage without removing protected items.

function Upper (Storage : Blackboard) return Reference;

This function returns the least upper bound of Storage. That is the reference to the element which will be put next into.

function "<" (Storage : Blackboard; Pointer : Reference)
   return Boolean;
function ">" (Storage : Blackboard; Pointer : Reference)
   return Boolean;
function "<" (Pointer : Reference; Storage : Blackboard)
   return Boolean;
function ">" (Pointer : Reference; Storage : Blackboard)
   return Boolean;

These functions provide reference validity checks. Storage < Pointer, when Pointer refers to an element not yet written into the blackboard. The procedure Next returns such reference when it reaches the end of a blackboard. Storage > Pointer, when Pointer refers to a lost element, which is already overridden by newer elements. When neither Storage < Pointer nor Storage > Pointer, then Pointer is refers to an accessible (valid) element in Storage. In other words comparisons are made in the sense of intervals, when the blackboard is considered as a consequent range of contained elements. Because the blackboard elements are written in FIFO order, the following statement is true:

Let S1, S2 be the states of a blackboard S at the times t1t2. P1, P2 be the states of a reference P to the same blackboard element at the corresponding times, then

    S1>P1 => S2>P2
    S2<P2 => S1<P1

function "<"  (Left, Right : Reference) return Boolean;
function ">"  (Left, Right : Reference) return Boolean;
function "<=" (Left, Right : Reference) return Boolean;
function ">=" (Left, Right : Reference) return Boolean;

References are directly comparable even if not valid. Elements put later onto the blackboard have greater references.

First_Reference : constant Reference;

This value is of a reference to the first blackboard element.

10.2.2. Multiple publishers blackboard

The child package Generic_Blackboard.Generic_Task_Safe provides a blackboard, which is safe to use with any number of publishers:

generic
package
Generic_Blackboard.Generic_Task_Safe is ...

The package provides a derived blackboard type:

type Shared_Blackboard is new Blackboard with private;

This type overrides the procedure Put with an implementation that uses a protected subprogram in order to write the blackboard in a task safe way.


[Back][TOC][Next]

11. Locking synchronization primitives

The package Synchronization is a parent package of the child packages providing various locking synchronization primitives. The package defines:

Ownership_Error : exception;

[Back][TOC][Next]

11.1. Notes on programming with protected objects

Here it is appropriate to discuss some techniques used in Ada for task synchronization. There exist two major mechanisms of synchronization in Ada:

Rendezvous is an synchronous call to an entry of a task. As such it cannot be reused unless the task types have multiple instances. It is also considered heavy-weight because it often requires context switching. However, rendezvous and protected objects should not be considered competing. There exist problems more natural to solve with rendezvous than with protected objects, and the inverse.

A protected object has a state and three types of operations to handle its state:

The difference between protected procedures and entries is in the queue. When a protected procedure is called that never blocks the caller task. When an entry is called that potentially blocks.

Non-blocking does not imply any specific time constraint. In fact a non-blocking call to a protected object may result in some delay. It is also possible that the task doing it would in effect loose the processor. Non-blocking only means that the waiting time does not depend on either the program logic or its inputs. So it is considered "instant" from the program point of view. Blocking means that the program logic can become aware of the delay caused by the call. For example, I/O is considered blocking. The program shall be prepared to deal with blocking. This is one reason why entries and procedures are distinct in protected objects.

When an entry call blocks the caller task spends its time in the queue of the entry. Each entry also has a barrier, a condition which opens or closes the entry. When an entry is open, a task calling to the entry can be unblocked in order to execute the entry body. When the entry is closed, the task is blocked and stays in the entry queue. The barrier depends on the protected object state. Though it is possible to refer to non-local variables from the barrier, that would be useless because the barriers are re-evaluated only when the protected object state is "officially" changed. And this happens only when a protected procedure or an entry body is executed.

So the actual parameters and global variables cannot be used in the barriers. That is quite limiting. Fortunately, there exists a technique to circumvent this constraint. The technique is based on the requeue statement (see Ada Language Reference Manual 9.5.4), which is one the most powerful constructs of the Ada concurrency model. A task queued to a protected object entry can be re-queued to another entry under the condition that the parameter profile is same or else that the new entry does not have any parameters. Requeue is used in the "lounge" pattern discussed below.

Let us consider creating a shared counter. A counter can be incremented. It can be awaited for reaching some definite value. The interface of such a counter might look as follows:

protected type Counter is
   entry
Wait (Goal : Natural); -- Wait for Goal >= Value
   procedure Count;             -- Increment counter
private
   Value : Natural := 0;        -- The current counter state
end Counter;

The procedure Count increments the counter value by 1. The entry Wait is used in order to wait for a state when Goal is greater than or equal to the counter value. This condition cannot be specified as the barrier of Wait. The solution of the problem is to add a private family of entry points Lounge:

protected type Counter is
   entry
Wait (Goal : Natural);   -- Wait for Goal >= Value
   procedure Count;               -- Increment counter
private
   entry
Lounge (Boolean) (Goal : Natural); -- Callers are waiting here
   Value   : Natural := 0;                  -- The current counter state
   Current : Boolean := False;              -- The current update state
end Counter;

The implementation of Wait has the barrier true (no waiting). It checks if the condition is met and otherwise re-queues to the entry Lounge, where the caller task will actually wait for the condition to meet.

entry Wait (Goal : Natural) when True is
begin
   if
Goal > Value then -- Enter actual waiting if not met
      requeue Lounge (not Current) with abort;
   end if
;
end Wait;

The barrier of Lounge is informally "object's state has changed." This also cannot be spelt using the object's state alone. But it can be done using entry families. So the entry Lounge is split into two. In the declaration of it has (Boolean) following the entry name, which means, there exists Lounge (True) and Lounge (False). The object itself is in two states reflected by the variable Current. When Current is true, Lounge (True) is open and Lounge (False) is closed. When Current is false, they change places. The procedure Count increments the counter and then toggles Current. This causes tasks queued to a Lounge to execute the body and releases those of them the counter state reached Goal. Others are requeued back to the opposite Lounge entry:

entry Lounge (for Toggle in Boolean) (Goal : Natural)
   when Toggle = Current is
begin
   if
Goal < Value then   -- Continue waiting if not met
      requeue Lounge (not Current) with abort;
   end if
;
end Lounge;

The procedure Count increments Value and switches lounges:

procedure Count is
begin
  
Value   := Value + 1;   -- Increment counter
   Current := not Current; -- Pulse state change
end Count;

Here a careful reader could observe that this solution has a race condition, when Count toggles Current, there is no guarantee that all tasks from the corresponding Lounge's queue will execute the Lounge's body before next increment. In order to ensure that, a final step has to be done:

protected type Counter is
   entry
Wait (Goal : Natural); -- Wait for Goal >= Value
   entry Count;                 -- Increment counter
private
   entry
Lounge (Boolean) (Goal : Natural); -- Callers are waiting here
   Value   : Natural := 0;                  -- The current counter state
   Current : Boolean := False;              -- The current update state
end Counter;

Here Count becomes an entry. This allows us to lock it when the queue of a Lounge from the previous notification step is not yet empty.

entry Count when Lounge (Current)'Count = 0 is
begin
  
Value   := Value + 1;   -- Increment counter
   Current := not Current; -- Pulse state change
end Count;

Though Count is now an entry it does not really block.

The "lounge" pattern is considerably universal. In fact, the implementations of the most of the synchronization primitives described below are based on this pattern.

[Back][TOC][Next]

11.2. Events

An event is a synchronization object with a state, that can be changed and awaited for. As a synchronization primitive event is very low-level, and thus, is exposed to various problems from race condition to deadlocking. For this reason they should be used with a great care.

11.2.1. Simple event

The package Synchronization.Events provides an implementation of a simple event. An event can be signaled, reset, and awaited for a definite state. Note that if the events need to be used in a combination the package Synchronization.Generic_Events_Array should be used instead. The event is signaled and reset manually, which can be a source of race condition when signaling is close followed by resetting. Such events represent a special case pulse events. See the package Synchronization.Pulse_Events which provides a race condition safe implementation of.

protected type Event is ...

This is the type of the protected object implementing an event. The following subprograms and entries are provided:

function Is_Signaled return Boolean;

This function returns true if the event is signaled.

procedure Reset;

This procedure sets the event into the non-signaled state. It releases all tasks queued to the entry Wait_For_Reset.

procedure Signal;

This procedure signals the event. It releases all tasks queued to the entry Wait.

entry Wait;

This entry blocks until the event is signaled.

entry Wait_For_Reset;

This entry blocks until the event is signaled.

11.2.2. Pulse event

The package Synchronization.Pulse_Events provides an implementation of pulse events. A pulse event is signaled for a short, actually indivisible, period of time. It is reset automatically immediately after the last task awaiting the event is released. The implementation provided by this package is free of race conditions. That is, even if a task, released by the event, seized the processor before releasing other tasks, and then entered another wait for the same event, that would not release this task again. It will be blocked until a next pulsation of the event. The implementation also ensures that all tasks entering waiting before event pulsation are released before any consequent pulsation. The following diagram illustrates the constraints satisfied by the implementation in order to prevent race conditions:

pulse event

As the diagram shows both pulsing and waiting are postponed until the end of releasing already blocked tasks. Any task entering waiting stay blocked while other tasks are released.

protected type Pulse_Event is ...

This is the type of the protected object implementing a pulse event. The following subprograms and entries are provided:

entry Pulse;

This entry release all tasks waiting for the event. Note that though this is an entry, it does not block for any considerable time. When accepted, it releases all tasks queued to the entry Wait before any next Pulse takes effect.

entry Wait;

This entry waits for an event pulsation (see Pulse).

11.2.3. Events pulsing a value

The package Synchronization.Generic_Pulse_Events is a generic variant of Synchronization.Pulse_Events which additionally distributes a value when an event is pulsed. The package is generic:

generic
   type
Event_Value is private;
package
Synchronization.Generic_Pulse_Events is ...

The formal generic parameter is the type of the values distributed when the event is pulsed.

protected type Pulse_Event is ...

This is the type of the protected object implementing a pulse event. The following subprograms and entries are provided:

entry Pulse (Value : Event_Value);

This entry release all tasks waiting for the event and propagates Value to each of them. Note that though this is an entry, it does not block for any considerable time. When accepted, it releases all tasks queued to the entry Wait passing Value to all of them. Any consequent Pulse is blocked until end of releasing the tasks.

entry Wait (Value : out Event_Value);

This entry waits for event pulsing by Pulse. The parameter Value is the value specified in the call to Pulse.

11.2.4. Arrays of events

The package Synchronization.Generic_Events_Array provides arrays of events. The objective of the design is to allow waiting for any combination of the events. The events from the array can be signaled, reset and awaited for. The implementation represented here is free of race conditions, when the state of the events is being changed. In this case it guarantees that all tasks awaiting for the state are released before any consequent state change. Another common class of race conditions is eliminated by providing atomic signal-then-wait operations. For instance a set of tasks may synchronize themselves at dedicated points by signaling an event and then awaiting for all events signaled. If tasks later reset their events, that would constitute a race condition, because a task might reset its event before other tasks queued for all events set. The following figure illustrates the case:

events array deadlock

In this example the deadlock of the task B is caused by a premature resetting the event A. An atomic signaling and waiting breaks the deadlock.

The package is generic

generic
   type
Event_Type is (<>);
package
Synchronization.Generic_Events_Array is ...

The formal parameter is the index type of the events array. The package defines the following supplementary types:

type Events_State is array (Event_Type) of Boolean;

Objects of this type describe the state of an events array. For each event Event_State contains true if the event is signaled. The following set-theoretic operations are defined additionally to the standard operations of Boolean arrays in order to ease composition of arrays:

function "or" (Left, Right : Event_Type) return Events_State;
function "or" (Left : Events_State; Right : Event_Type)   return Events_State;
function "or" (Left : Event_Type;   Right : Events_State) return Events_State;

These functions compose a set when one parameter specifies an event.

function "not" (Left : Event_Type) return Events_State;

This function creates a complement set of a singleton event.

type Abstract_Condition is abstract
   new
Ada.Finalization.Controlled with null record;

This type represents an abstract condition to wait for. The entries of the events array awaits for instances of the types derived from this base type. The derived type shall override the abstract primitive operation Satisfied. User-defined conditions can be created by deriving from this type.

function Satisfied
         (  Condition : Abstract_Condition;
            State     : Events_State
         )  return Boolean is abstract;

This function is used to check if the condition is satisfied. The parameter State is the current state of the events array. Note that the function is called in the course of a protected action. That means, that it shall neither block, nor invoke any other protected actions. Further if it accesses shared non-local data, the user shall warranty that these data are either atomic or else are never accessed outside the protected actions of Events_Array.

The package provides some frequently used conditions:

Always_Signaled : constant Abstract_Condition'Class;
All_Signaled    : constant Abstract_Condition'Class;
Any_Signaled    : constant Abstract_Condition'Class;
No_Signaled     : constant Abstract_Condition'Class;

The conditions:

Further conditions are specified using the type Event_Signaled derived from Abstract_Condition.

type Event_Signaled (Event : Event_Type) is
   new
Abstract_Condition with null record;

The type represents a condition that the event corresponding to the value of the discriminant Event is signaled. Instances of this type can be created using the following function.

function Signaled (Event : Event_Type) return Event_Signaled;

This function returns a condition satisfied when Event is signaled.

function Reset (Event : Event_Type) return Event_Reset;

This function returns a condition satisfied when Event is not signaled.

protected type Events_Array is ...

Protected objects of this type represent arrays of events. Initially all events in the array are non-signaled. The following operations and entry points are defined for Events_Array:

function Get_State return Events_State;

This function returns the state of the array. The result is an array which for each event contains true if the event is signaled.

function Is_Signaled (Event : Event_Type) return Events_State;

This function returns true if Event is signaled.

entry Reset
      (  Events    : Events_State;
         Condition : Abstract_Condition'Class := Always_Signaled
      );
entry Reset
      (  Event     : Event_Type;
         Condition : Abstract_Condition'Class := Always_Signaled
      );

These entries reset an event or a number of events to the non-signaled state. When the first parameter specifies an event, then the event is set to the non-signaled state. When the parameter is an array, then each event for which the array contains true is reset to the non-signaled state. The parameter Condition is the condition to wait for immediately after resetting the events. The default value is Always_Signaled, i.e. Reset returns after changing the events without waiting. Entering waiting, if any, is indivisible from resetting the events.

entry Signal
      (  Events    : Events_State;
         Condition : Abstract_Condition'Class := Always_Signaled
      );
entry Signal
      (  Event     : Event_Type;
         Condition : Abstract_Condition'Class := Always_Signaled
      );

These entries signal an event or a number of events. When the first parameter is an event, then the event is signaled. When the parameter is an array, then each event for which the array contains true is signaled. The parameter Condition is the condition to wait for immediately after signaled the events. The default value is Always_Signaled, i.e. Signal returns after changing the events without waiting. Entering waiting, if any, is indivisible from signaling the events.

entry Set
      (  State     : Events_State;
         Condition : Abstract_Condition'Class := Always_Signaled
      );

This entry sets all events according to the value of State. The parameter Condition specifies the condition to wait for, immediately after setting the events. The default value is Always_Signaled, i.e. Set returns after changing the events without waiting. Entering waiting, if any, is indivisible from setting the events.

entry Wait (Condition : Abstract_Condition'Class);

This entries waits for Condition. See also Signal, Reset and Set entries which also are capable of waiting for a certain condition.

11.2.5. Synchronization at a checkpoint. Sample

The following example illustrates use of the package for checkpoint synchronization problem: The problem arise when several tasks perform some jobs and need to be synchronized when all jobs are completed. A job completion is signaled by an event. A task completing its job signals the event, waits for other events signaled and then resets the event. This procedure is exposed to race conditions and deadlocks.

File test_synchronization_events_array.ads:
with Synchronization.Generic_Events_Array;

package Test_Synchronization_Events_Array is
   type
Worker_ID is (A, B, C);
   package Events_Arrays is
      new 
Synchronization.Generic_Events_Array (Worker_ID);
end Test_Synchronization_Events_Array;

This package instantiates Synchronization.Generic_Events_Array, which is necessary to do at the library level in Ada 95. In Ada 2005 it can be instantiated in nested scopes.

File test_synchronization_events.adb (part of) :
   ...
with Ada.Numerics.Float_Random;  use Ada.Numerics.Float_Random;
with Ada.Text_IO;                use Ada.Text_IO;

with Test_Synchronization_Events_Array;
use  Test_Synchronization_Events_Array;
use  Events_Arrays;
   ...
Worker_State : Events_Array;

task type Worker (ID : Worker_ID);
task body Worker is
   Dice : Generator;
begin
   Reset (Dice);
   for Index in 1..10 loop
      Put_Line
      (  Worker_ID'Image (ID)
      &  " doing things"
      &  Integer'Image (Index)
      );
      delay Duration (Random (Dice) * 0.100);
      Worker_State.Signal (ID, All_Signaled);
      Worker_State.Reset (ID);
   end loop;
   Put_Line (Worker_ID'Image (ID) & " finished");
end Worker;

T1 : Worker (A);
T2 : Worker (B);
T3 : Worker (C);

Here three tasks perform some piece of work. The work is simulated by waiting for a random period of time. At the end of each cycle a worker sets its event in the array of the events Worker_State. Then it waits for other workers. This action is performed atomically by:

Worker_State.Signal (ID, All_Signaled);

Here ID is the worker/event identifier and All_Signaled is a condition satisfied when all events are set. After this the worker resets its event

Worker_State.Reset (ID);

and starts a new iteration of the cycle.

[Back][TOC][Next]

11.3. Mutexes

Mutex stands for Mutual Exclusion. It is a synchronization object used to prevent concurrent access to a resource. A more general but rarely used in practice concept is semaphore introduced by Edsger Dijkstra. Technically mutex is a semaphore with the count k=1. The count 1 means that only one task can own the mutex at a time. Mutexes are exposed to deadlocks when a task attempts to seize more than one mutex. It is enough to have two tasks and two mutexes in order to be able to construct a deadlock. Yet another problem is resource starvation caused by a premature termination of a task owning the mutex, for example, upon exception propagation.

11.3.1. Reentrant mutex

The package Synchronization.Mutexes provides an implementation of mutexes, free of one particular problem, when a mutex is repetitively seized by the same task. The implementation avoids deadlock by allowing a task to seize the mutex more than once.

protected type Mutex is ...

Protected objects of this type represent mutexes. The following operations and entry points are defined for Mutex:

function Get_Owner return Task_ID;

This function returns the identification of the task owning the mutex. See the standard package Ada.Task_Identification for further information.

procedure Grab;

This procedure seizes the mutex if it is not owned by another task. Is_Mine can be used afterwards in order to verify if the mutex was indeed seized. When the mutex was seized it shall be released by a call to Release. For example:

   Resource : Mutex;    -- A resource
  
...
begin
   ...
   Resource.Grab;       -- Try to seize it without blocking
   if Resource.Is_Mine then
      ...               -- Use the resource safely
      Resource.Release; -- Note, it has to be released
   end if;

function Is_Mine return Boolean;

This function returns true if the mutex is owned by the caller task.

function Is_Owned return Boolean;

This function return true if the mutex is owned by a task.

procedure Release;

This procedure releases the mutex previously seized by Grab or Seize. Note that each call to Seize and each call to Grab that seized the mutex shall be matched by a call to Release. Ownership_Error is propagated when the mutex is not owned by the caller task.

entry Seize;

This entry is used to seize the mutex. It blocks until the mutex becomes free. It does not block if the mutex is already owned by the caller task. Each call to Seize shall be matched by a call to Release.

The package also defines:

type Holder (Resource : access Mutex) is
   new
Ada.Finalization.Limited_Controlled with private;

This is a helper type used to ensure that each Seize is matched by a Release even if an exception is propagated. It is used as follows:

   Resource : aliased Mutex; -- A resource
  
...
begin
   ...
   declare
      Lock : Holder (Resource'Access); -- Seize the resource
   begin
      ...  -- Enjoy exclusive access
   end  -- Release the resource

It is strongly recommended to use a Holder object in order to access a mutex even if that might cause some overhead. The reason is that asynchronous transfer of control (Language Reference Manual 9.7.4)) from a task owning a mutex might leave the mutex seized. A Holder object warranties mutex release. In general one should avoid asynchronous transfer of control.

11.3.2. Arrays of mutexes

The package Synchronization.Generic_Mutexes_Array provides an implementation of arrays of mutexes. Arrays of mutexes are deadlock free. The deadlock is prevented by numerous measures:

The package is generic:

generic
   type
Mutex_Type is (<>);
package
Synchronization.Generic_Mutexes_Array is ...

The formal parameter is the index type of the mutexes array. The package defines the following supplementary types:

type Mutexes_Set is array (Mutex_Type) of Boolean;

This is a set of mutexes. For each mutex event Mutexes_Set contains true if the mutex is in the set. The following set-theoretic operations are defined additionally to the standard operations of Boolean arrays in order to ease composition of arrays:

function "or" (Left, Right : Mutex_Type) return Mutexes_Set;
function "or" (Left : Mutexes_Set; Right : Mutex_Type)   return Mutexes_Set;
function "or" (Left : Mutex_Type;  Right : Mutexes_Set) return Mutexes_Set;

These functions compose a set when one parameter specifies an event.

function "not" (Left : Mutex_Type) return Mutexes_Set;

This function creates a complement set of a singleton event.

protected type Mutexes_Array is ...

Protected objects of this type represent arrays of mutexes. The following operations and entry points are defined for Mutexes_Array:

function Get_Owner (Mutex : Mutex_Type) return Task_ID;

This function returns the identification of the task owning Mutex. See the standard package Ada.Task_Identification for further information.

procedure Grab (Mutex : Mutex_Type);
procedure Grab (Mutex : Mutex_Type; Success : out Boolean);

This procedures seize Mutex if it is not already owned by another task. Is_Mine can be used after Grab in order to verify if the mutex was indeed seized. When the mutex was seized is shall be released later by a call to Release or Release_All with the same mutex specified. For example:

   Resource : Mutexes_Array; -- Resources
  
...
begin
   ...
   Resource.Grab (Mutex);       -- Try to seize it without blocking
   if Resource.Is_Mine (Mutex) then
      ...                       -- Use the resource safely
      Resource.Release (Mutex); -- Note, it has to be released
   end if;

The variant with the output parameter Success sets the parameter to true if the mutex was seized or to false otherwise. When Mutex is to be seized and has the position less than one of a mutex already owned by the caller task, Ownership_Error is propagated.

procedure Grab_All (Mutexes : Mutexes_Set; Success : out Boolean);

This procedures seizes all Mutexes. If at least one mutex from Mutexes is not already owned by another task the procedure does nothing and Success is set to false. When mutexes are seized Success is set to true. Each mutex seized by Grab_All has to be released by a matching call to Release or Release_All. When Mutexes contains a mutex to be seized such that its position less than one of a mutex already owned by the caller task, yet not appearing in Mutexes, then Ownership_Error is propagated.  In this case the operation has no side effect on the mutexes array.

function Is_Mine (Mutex   : Mutex_Type)  return Boolean;
function Is_Mine (Mutexes : Mutexes_Set) return Boolean;

This function returns true if Mutex is owned by the caller. The variant with a set returns true if all mutexes from the set are owned by the caller.

function Is_Owned (Mutex : Mutex_Type) return Boolean;

This function returns true if Mutex is owned by a task.

procedure Release (Mutex : Mutex_Type);

This procedure releases Mutex previously seized by Grab, Grab_All, Seize or Seize_All. For each mutex the number of seizures shall match the number of releasing. Ownership_Error is propagated when Mutex is not owned by the caller.

procedure Release_All (Mutexes : Mutexes_Set);

This procedure releases all mutexes from Mutexes previously seized by Grab, Grab_All, Seize or Seize_All. For each mutex the number of seizures shall match the number of releasing. Ownership_Error is propagated when at least one mutex is not owned by the caller. The procedure might release some of the mutexes before propagating the exception.

entry Seize (Mutex : Mutex_Type);

This entry is used to seize Mutex. It blocks until the mutex becomes free. It does not block if the mutex is already owned by the caller. Each call to Seize shall be matched by a call to Release or Release_All with the same mutex specified. When Mutex has the position less than one of a mutex already owned by the caller task, Ownership_Error is propagated.

entry Seize_All (Mutexes : Mutexes_Set);

This entry is used to seize all mutexes from Mutex. It blocks until the mutexes become available. It does not block if all mutexes are already owned by the caller. For each mutex specified in a call to Seize_All there shall be a matching call  to Release or Release_All. When Mutexes contains a mutex with the position less than one of a mutex already owned by the caller task, yet not appearing in Mutexes, then Ownership_Error is propagated. In this case the operation has no side effect on the mutexes array.

The package also defines two helper types:

type Set_Holder
     (  Resource : access Mutexes_Array;
        Seize    : access Mutexes_Set
     )  is new Ada.Finalization.Limited_Controlled with private;

This is a helper type used to ensure that each Seize_All is matched by a Release_All even if an exception is propagated. It is used as follows:

   Resources : aliased Mutexes_Array; -- Resources
  
...
begin
   ...
   declare
      Mutexes : aliased Mutexes_Set := ...; -- The resources we need here
      Lock    : Set_Holder (Resource'Access, Mutexes'Access); -- Seize them
   begin
      ...  -- Enjoy exclusive access
   end  -- Release the resources

type Singleton_Holder
     (  Resource : access Mutexes_Array;
        Seize    : Mutex_Type
     )  is new Ada.Finalization.Limited_Controlled with private;

This is a helper type used to ensure that each Seize is matched by a Release even if an exception is propagated. It is used as follows:

   Resources : aliased Mutexes_Array; -- Resources
  
...
begin
   ...
   declare
      Lock : Singleton_Holder (Resource'Access, Mutex); -- Seize Mutex
   begin
      ...  -- Enjoy exclusive access
   end  -- Release the resources

It is strongly recommended to use a Holder object in order to access a mutex even if that might cause some overhead. The reason is that asynchronous transfer of control (Language Reference Manual 9.7.4)) from a task owning a mutex might leave the mutex seized. A Holder object warranties mutex release. In general one should avoid asynchronous transfer of control.

11.3.3. Dining philosophers sample

The following example illustrates use of mutexes array. It represents a solution of the Dining Philosophers problem. The problem is exposed when Pi processes are competing for Ri resources, i=1..N, accessing more than one resource at a time. Philosophers are tasks. Each philosopher spends some random time thinking. Then he enters the dining room and takes his seat at the round table. In order to start to eat he seizes two forks, one on the left and another on the right of him. A philosopher waits for forks to become free if other philosophers use them. He puts both forks down and leaves the room when finished. The cycle repeats so long the philosopher lives. A deadlock occurs when, all philosophers seize a fork on their left. When the cutlery is implemented as an array of mutexes, where each fork is a mutex, no deadlock is possible, which solves the problem:

File test_dining_philosophers_forks.ads:

with Synchronization.Generic_Mutexes_Array;

package Test_Dining_Philosophers_Forks is
   type 
Philosopher is (Aristotle, Kant, Spinoza, Marx, Russel);
   package Forks is
      new
Synchronization.Generic_Mutexes_Array (Philosopher);
end Test_Dining_Philosophers_Forks;

This package instantiates Synchronization.Generic_Mutexes_Array, which is necessary to do at the library level in Ada 95. In Ada 2005 it can be instantiated in nested scopes. The type Philosopher identifies the philosophers as well as the the fork on the right of the corresponding philosopher's seat.

File test_dining_philosophers.adb:
with Ada.Exceptions;             use Ada.Exceptions;
with Ada.Numerics.Float_Random;  use Ada.Numerics.Float_Random;
with Ada.Text_IO;                use Ada.Text_IO;

with Test_Dining_Philosophers_Forks;
use  Test_Dining_Philosophers_Forks;

procedure Test_Dining_Philosophers is
   use
Test_Dining_Philosophers_Forks.Forks;

   Forks : aliased Mutexes_Array; -- Forks for hungry philosophers
   --
   -- Left_Of -- The fork left to the given one
   --
   function Left_Of (Fork : Philosopher) return Philosopher is
   begin
      if
Fork = Philosopher'First then
         return
Philosopher'Last;
      else
         return
Philosopher'Pred (Fork);
      end if;
   end Left_Of;
   --
   -- Person -- A task running some philosopher
   --
   -- ID - The philosopher ID
   --

   task type Person (ID : Philosopher);
   task body Person is
      Cutlery : aliased Mutexes_Set := ID or Left_Of (ID);
      Dice    : Generator;
   begin
      Reset (Dice);
      for Life_Cycle in 1..50 loop
         -- In his life a philosopher eats 50 times
         Put_Line (Philosopher'Image (ID) & " is thinking");
         delay Duration (Random (Dice) * 0.100);
         Put_Line (Philosopher'Image (ID) & " is hungry");
         declare
            Lock : Set_Holder (Forks'Access, Cutlery'Access);
         begin
            Put_Line (Philosopher'Image (ID) & " is eating");
            delay Duration (Random (Dice) * 0.100);
         end;
      end loop;
      Put_Line (Philosopher'Image (ID) & " is leaving");
   exception
      when
Error: others =>
         Put_Line
         (  Philosopher'Image (ID)
         &  " caused "
         &  Exception_Information (Error)
         );
   end Person;

   T1 : Person (Aristotle); -- Start philosophers
   T2 : Person (Kant);
   T3 : Person (Spinoza);
   T4 : Person (Marx);
   T5 : Person (Russel);
begin
   null
; -- Nothing to do in the main task, just sit and behold
end Test_Dining_Philosophers;

In this implementation a philosopher seizes his forks using Seize_All. Because this is an indivisible operation it cannot deadlock.


[Back][TOC][Next]

12. Parsers

Parsers can be used for syntax analysis of infix expressions, i.e. ones containing infix (dyadic), prefix and postfix operators, brackets, function calls, array indices etc. The approach presented does not require any grammar put down to generate scanner and analyzer. Nor any code generation steps are required. An object-oriented approach is used instead. The lexical procedures are dispatching, so that implementations may be provided through overriding them. Parsers can be used both for immediate one-pass code interpretation and for parsing tree building. Parser automatically detects the expression end allowing its easy integration. Operator precedence is expressed in a native way by setting priorities controlling association with the operands. Associations with the left and right side operands are controlled independently. Commutative operators and their inverses can be optimized when necessary. Especial attention is paid to error handling allowing generating very precise error messages and source code references. Samples from a small console calculator to a complete parsing tree generator for Ada 95 expressions illustrate examples of use.

The parsing method used is an extended variant of an algorithm of infix to postfix notation conversion. I do not know who was its author. Already in 1975 T. Pratt in Programming Languages, design and implementation mentioned it as well known. The algorithm makes possible parsing and interpreting infix expressions in one pass without returns. The following figure drafts out the idea and its implementation.

parser

Quick reference:

[Back][TOC][Next]

12.1. Example first, a small calculator

In this paragraph I present an implementation of a small primitive floating point calculator. The calculator supports operations +, -, *, /, **, brackets () and unary operators +, -, abs.

File calculator.ads:
with Parsers.String_Source;  use Parsers.String_Source;
with Parsers.Generic_Lexer.Blanks;
with Parsers.Generic_Token.Segmented_Lexer;
with Tables.Names;

package Calculator is
--
-- Calculate -- A primitive floating-point calculator
--
--    Formula - To be evaluated
--
-- Returns :
--
--    The result of Formula
--
-- Exceptions :
--
--    Syntax_Error  - Any syntax error
--    Numeric_Error - Any numeric error
--

   function Calculate (Formula : String) return Float;

private
--
-- Operations -- All the operations supported
--

   type Operations is
        (  Add, Sub, Mul, Div, Pow,    -- Infix operators
           Abs_Value, Plus, Minus,     -- Prefix operators
           Left_Bracket, Right_Bracket -- Brackets
        );
--
-- "and" -- Checks operation associations, always True (Ok)
--

   function "and" (Left, Right : Operations) return Boolean;
--
-- Is_Commutative -- No commutative operations, always False
--

   function Is_Commutative (Left, Right : Operations) return Boolean;
--
-- Is_Inverse -- No commutative operations, always False
--

   function Is_Inverse (Operation : Operations) return Boolean;
--
-- Group_Inverse -- No commutative operations, never called
--

   function Group_Inverse (Operation : Operations) return Operations;
--
-- Priorities -- The levels of association
--

   type Priorities is mod 10;
--
-- Tokens -- The lexical tokens
--

   package Tokens is
      new
Parsers.Generic_Token
          (  Operation_Type => Operations,
             Argument_Type  => Float,
             Priority_Type  => Priorities,
             Sources        => Code
          );
   use Tokens;
--
-- Check_Spelling -- Of a name, no checks
--

   procedure Check_Spelling (Name : String);
--
-- Check_Matched -- Check if no broken keyword matched
--

   function Check_Matched (Source : String; Pointer : Integer)
      return Boolean;
--
-- Token_Tables -- Case-insensitive tables of tokens
--

   package Token_Tables is new Tokens.Vocabulary.Names;
--
-- The tables of prefix, infix and postfix operations
--

   Prefixes  : aliased Token_Tables.Dictionary;
   Infixes   : aliased Token_Tables.Dictionary;
   Postfixes : aliased Token_Tables.Dictionary;
--
-- Lexers -- Table driven lexers
--

   package Lexers is new Tokens.Segmented_Lexer;
--
-- Blank_Skipping_Lexers -- Ones that skip blanks
--

   package Blank_Skipping_Lexers is
      new
Lexers.Token_Lexer.Implementation.Blanks (Lexers.Lexer);
--
-- Expression -- The lexer using our tables
--

   type Expression is
      new
Blank_Skipping_Lexers.Lexer
          (  Prefixes  => Prefixes'Access,
             Infixes   => Infixes'Access,
             Postfixes => Postfixes'Access
          )  with null record;
--
-- Call -- Evaluates an operator
--

   function Call
            (  Context   : access Expression;
               Operation : Tokens.Operation_Token;
               List      : Tokens.Arguments.Frame
            )  return Tokens.Argument_Token;
--
-- Enclose -- Evaluates an expression in brackets
--

   function Enclose
            (  Context : access Expression;
               Left    : Tokens.Operation_Token;
               Right   : Tokens.Operation_Token;
               List    : Tokens.Arguments.Frame
            )  return Tokens.Argument_Token;
--
-- Get_Operand -- Recognizes an operand (float number)
--

   procedure Get_Operand
             (  Context  : in out Expression;
                Code     : in out Source;
                Argument : out Tokens.Argument_Token;
                Got_It   : out Boolean
             );
end Calculator;

The package Calculator defines the function Calculate that takes a string argument and returns the result of the expression in the string. In the private part of the package, first the set of supported operations is defined, that is the enumeration type Operations. Then the following functions are defined on Operations to be used in generic instantiations:

Next the package defines the type Priority used for operation association levels. That can be any type with "<" order defined. The types Operations and Priority are used to instantiate the package Parsers.Generic_Token. The instance Tokens provides base types describing expression lexical tokens. That is the table type used to keep the legal names of the operations defined by the type Operations. The tables obtained are case sensitive. It is not exactly what is needed, because the expression should be case-insensitive. For this reason, the child table package Tables.Names is instantiated. To do this first, there should be defined two additional subroutines:

Tables.Names is instantiated as:

package Token_Tables is new Tokens.Vocabulary.Names;

Next three tables from obtained Token_Tables are declared. They are:

The final step is to create table-driven lexers using the tables we have. For this the package Parsers.Generic_Token.Segmented_Lexer is instantiated under the name Lexers. The instance Lexers has the type Lexer which can be used to parse expressions. This type is abstract because it has some abstract operations to implement. The first operation is Get_Blank used to skip blanks in the expression. The package Parsers.Generic_Lexer.Blanks provides an implementation that skips spaces, tabs etc. To use it Parsers.Generic_Lexer.Blanks is instantiated as Blank_Skipping_Lexers. The obtained type Lexer is then extended to set the type discriminants to the corresponding tables. The resulting type Expression is still abstract, but has only three things to define:

The implementation of the package is straightforward:

File calculator.adb:
with Ada.Characters.Handling;  use Ada.Characters.Handling;
with Ada.Exceptions;           use Ada.Exceptions;
with Ada.IO_Exceptions;        use Ada.IO_Exceptions;
with Strings_Edit;             use Strings_Edit;
with Strings_Edit.Floats;      use Strings_Edit.Floats;

with Ada.Numerics.Elementary_Functions;
use  Ada.Numerics.Elementary_Functions;

package body Calculator is

   function "and" (Left, Right : Operations) return Boolean is
   begin
      return
True;
   end "and";

   function Is_Commutative (Left, Right : Operations) return Boolean is
   begin
      return
False;
   end Is_Commutative;

   function Is_Inverse (Operation : Operations) return Boolean is
   begin
      return
False;
   end Is_Inverse;

   function Group_Inverse (Operation : Operations) return Operations is
   begin
      return
Minus;
   end Group_Inverse;

   procedure Check_Spelling (Name : String) is
   begin
      null
;
   end Check_Spelling;

   function Check_Matched (Source : String; Pointer : Integer)
      return Boolean is
   begin
      return

      (  not Is_Alphanumeric (Source (Pointer))
      or else
         not
Is_Alphanumeric (Source (Pointer - 1))
      );
   end Check_Matched;

The function Check_Matched receives the string being parsed and the index of the first character following the matched name (lexeme). It checks that no broken names be matched.

File calculator.adb (continuation):
   function Call
            (  Context   : access Expression;
               Operation : Tokens.Operation_Token;
               List      : Tokens.Arguments.Frame
            )  return Tokens.Argument_Token is
      Result : Float;
   begin
      case
Operation.Operation is
         when
Abs_Value =>
            Result := abs List (List'First).Value;
         when Add =>
            Result := List (List'First).Value + List (List'Last).Value;
         when Sub =>
            Result := List (List'First).Value - List (List'Last).Value;
         when Mul =>
            Result := List (List'First).Value * List (List'Last).Value;
         when Div =>
            Result := List (List'First).Value / List (List'Last).Value;
         when Pow =>
            Result :=
               exp (log (List (List'First).Value) * List (List'Last).Value);
         when Plus =>
            Result := List (List'First).Value;
         when Minus =>
            Result := -List (List'First).Value;
         when others =>
            raise Program_Error;
      end case;
      if Result'Valid then
         return (Result, Operation.Location & Link (List));
      else
         Raise_Exception
         (  Numeric_Error'Identity,
            (  "Numeric error in "
            &  Operations'Image (Operation.Operation)
            &  " at " & Image (Operation.Location)
         )  );
      end if;
   exception
      when
Program_Error =>
         raise;
      when others =>
         Raise_Exception
         (  Constraint_Error'Identity,
            (  "Numeric error in "
            &  Operations'Image (Operation.Operation)
            &  " at " & Image (Operation.Location)
         )  );
   end Call;

Call implements operators. The parameter Operation identifies what for operator. The parameter List contains the operands. Each operand has value (the Value field) and location in the source (the Location field). When evaluated operator also returns a value and location. The new location is evaluated from the locations of the operands (function Link) and the operator.

File calculator.adb (continuation):
   function Enclose
            (  Context : access Expression;
               Left    : Tokens.Operation_Token;
               Right   : Tokens.Operation_Token;
               List    : Tokens.Arguments.Frame
            )  return Tokens.Argument_Token is
   begin
      return

      (  List (List'First).Value,
         Left.Location & Right.Location
      );
   end Enclose;

Enclose implements brackets. Order brackets () just return the operand.

File calculator.adb (continuation):
   procedure Get_Operand
             (  Context  : in out Expression;
                Code     : in out Source;
                Argument : out Tokens.Argument_Token;
                Got_It   : out Boolean
             )  is
      Line    : String renames Get_Line (Code);
      Pointer : Integer := Get_Pointer (Code);
      Value   : Float;
   begin
      Get (Line, Pointer, Value);
      Set_Pointer (Code, Pointer);
      Argument := (Value, Link (Code));
      Got_It   := True;
   exception
      when End_Error =>
         Got_It := False;
      when Constraint_Error =>
         Set_Pointer (Code, Pointer);
         Raise_Exception
         (  Numeric_Error'Identity,
            "Too large number at " & Image (Link (Code))
         );
      when Data_Error =>
         Set_Pointer (Code, Pointer);
         Raise_Exception
         (  Parsers.Syntax_Error'Identity,
            "Wrong number at " & Image (Link (Code))
         );
   end Get_Operand;

The procedure Get_Operand gets the operand in the source. It uses Get_Line to access the current source line. Get_Pointer returns where it should start. The procedure Get from Strings_Edit.Floats is used to get a floating-point number. The Set_Pointer advances the source cursor to the position next to the number. The function Link is used to get the location of the number matched.

File calculator.adb (continuation):
   Reckoner : Expression;

   function Calculate (Formula : String) return Float is
      Copy   : aliased String := Formula;
      Code   : Source (Copy'Access);
      Result : Tokens.Argument_Token;
   begin
      Lexers.Parse (Reckoner, Code, Result);
      if Get_Pointer (Code) <= Copy'Last then
         Raise_Exception
         (  Parsers.Syntax_Error'Identity,
            (  "Unrecognized '"
            &  Copy (Get_Pointer (Code)..Copy'Last)
            &  "'"
         )  );
      end if;
      return Result.Value;
   end Calculate;

The procedure Calculate implements the calculator. It just calls Parse to interpret Formula and the checks that the whole string was matched.

File calculator.adb (continuation):
begin
   Add_Operator (Prefixes, "abs", Abs_Value, 87);
   Add_Operator (Prefixes, "+",   Plus,      8, 7);
   Add_Operator (Prefixes, "-",   Minus,     8, 7);
   Add_Bracket  (Prefixes, "(",   Left_Bracket);

   Add_Operator (Infixes, "+",  Add, 1, 2);
   Add_Operator (Infixes, "-",  Sub, 1, 3);
   Add_Operator (Infixes, "*",  Mul, 3, 4);
   Add_Operator (Infixes, "/",  Div, 3, 4);
   Add_Operator (Infixes, "**", Pow, 9, 5);

   Add_Bracket  (Postfixes, ")", Right_Bracket);
end Calculator;

Finally upon package elaboration the tables have to be filled in. Add_Operator is used to add an operator. The operator priorities are chosen to satisfy usual association rules. Add_Bracket is used to add brackets.

A program using the calculator may look as follows:

File console_calculator.adb:
with Ada.Exceptions;       use Ada.Exceptions;
with Ada.Text_IO;          use Ada.Text_IO;
with Strings_Edit.Floats;  use Strings_Edit.Floats;
with Calculator;           use Calculator;
with Parsers;

procedure Console_Calculator is
   Text : String (1..120);
   Last : Integer;
begin
   Put_Line ("Enter an expression to calculate and hit <enter>");
   Put_Line ("The operations supported are +, -, /, *, **, abs, ()");
   Put_Line ("   (to exit enter an empty string)");
   loop
      Put (">");
      Get_Line (Text, Last);
      exit when Last < Text'First;
      begin
         Put_Line ("=" & Image (Calculate (Text (1..Last))));
      exception
         when Error : Numeric_Error | Parsers.Syntax_Error =>
            Put_Line (Exception_Message (Error));
      end;
   end loop;
exception
   when Error : others =>
      Put ("Error :");
      Put_Line (Exception_Information (Error));
end Console_Calculator;

[Back][TOC][Next]

12.2. Basic considerations

An expression is a sequence of symbols involving operations applied to operands. In programming languages expression is a formula used to compute a value. In most general way any expression has the following syntax:

<expression>   ::=   <prefix>   <operand>   <postfix>   [   <infix>   <expression>   ]

Here <prefix> denotes any list of prefix operations, <postfix> does any list of postfix operations, <infix> is always exactly one infix operation.

For example in the following C++ expression:

! f ( 3 + x++ )

Operands here are f, 3 and x. Prefix operation is ! (logical not). Postfix operations are ++ (post-increment) and right bracket ). Infix operations are the operator + and the left bracket (.

The above syntax defines three kinds of operations depending of the context they may appear. We will use different colors to highlight the operation context.

12.2.1. Types of lexical tokens

The operations are further subdivided into operators, delimiters (like brackets), commas and ligatures, and reserved keywords used as modifiers.

Operators:

Brackets, commas, ligatures:

Foo (Left=>X, Right=>Y);

Argument sublists are quite common in mathematical notation. For example a hypergeometric function:

F (x1, x2, x3; y1, y2, y3 | z)

Here ; and | are semicolons separating sublists of the argument list. If ; has higher priority than | the above means:

()
                               
      (|       |)
                             
    (; ;|    
                               
  F    x1   x2   x3   y1   y2   y3    z  

Argument lists and sublists are always bound by two operations, the left and the right one. There are three kinds of semicolons:

(A, B with C, D with E)

  ()      
                 
        with)
                   
                with)
                   
  A     B     C     D     E  

Modifiers:

The modifiers can be used to stop expression parsing at reserved keywords. Thus in Ada the same then when does not follow and, manifests the expression end in an if-statement.

12.2.2. Priorities and association

Association of the operators with the operands is usually controlled by the precedence level (the operator priority) and special rules for the case when the priorities are same. Here I propose a simpler and more general model. All operators have two priorities to control association with the operands on either side. So the left priority controls left-side association. Both unary and binary operators have the priorities. Binary infix operators normally have left and right priorities near to each other. To have left to right operand association the left priority should be slightly lower than the right one. The following example illustrates the process of operand association for A+B*C+D+E:

A + B * C + D + E =           +  
A 1+2 B 3*4 C 1+2 D 1+2 E =                    
A 1+2 B*4 C 1+2 D 1+2 E =       +      
A 1+2 B*C 1+2 D 1+2 E =                    
A+(B*C) 1+2 D 1+2 E = +        
(A+(B*C))+D 1+2 E =                    
((A+(B*C))+D)+E =     *        
((A+(B*C))+D)+E                    
    A     B     C     D     E  

Normally, the left priority of a prefix operator is higher than the right one and both are higher than the priorities of the infix operators so:

A - ++ -- B + C =     +  
A 1-2 10++9 10--9 B 1+2 C =            
A 1-2++9--B 1+2 C = -    
A 1-2++(--B) 1+2 C =            
A-(++(--B)) 1+2 C =     ++    
(A-(++(--B)))+C =     --    
(A-(++(--B)))+C =            
    A     B     C  

There might be exceptions from this rule as in the case of the exponentiation operator, where it is useful to have the left priority of ** higher than the right priority of the unary minus and the right priority of ** lower than left priority of the unary minus so, that -A**-B become:

- A ** - B = -
8-7 A 9**5 8-7 B = **
8-7 A**5-B =        
8-7 A**(-B)=     -
-(A**(-B))=        
-(A**(-B))   A     B  

The priorities of the postfix operators should be selected so that the left priority be very high, but lower than the right priorities of the prefix operators. The right priority should be slightly lower than the left one, but higher than the right priorities of the infix operators. Under these conditions:

A - ++ B ++ -- - C =     -  
A 1-2 10++9 B 7++8 7--8 1-2 C =            
A 1-2++B 7++8 7--8 1-2 C = -    
A 1-2 (++B)++7--8 1-2 C =            
A 1-2 ((++B)++)--1-2 C =     --    
A-((++B)++)--) 1-2 C =     ++    
(A-((++B)++)--))-C =     ++    
(A-((++B)++)--))-C            
    A     B     C  

The order of evaluation of the unary operations can be changed by setting appropriate priorities. In extreme cases it could involve infix operators as well:

A * ? B @ * C = @
A 3*4 1?2 B 2@1 3*4 C = *
A 3*41?2 B 2@1 3*4 C =            
?2 A*B 2@1 3*4 C =   ?      
?(A*B) 2@1 3*4 C = *    
(?(A*B)) 2@13*4 C =            
(?(A*B))*C 2@ =   A     B     C  
((?(A*B))*C)@ =      
((?(A*B))*C)@      

Association of a left index or function call bracket with the operand on the left is controlled by the left priority of the bracket. This priority is usually high because otherwise:

A ** B (C, D + E) = ()
A 9**5 B 4( C, D 1+2 E) =                    
A**B 4( C, D 1+2 E) = **     +
(A**B)( C, D+E) =                    
()(A**B, C, D+E)   A     B     C     D     E  

Here "()" denotes indexing or function call. Normally most of infix operators have lower priorities, with exception of component extraction which usually has a higher priority. Left index brackets have no right priority.

The aggregate, order left brackets, commas and ligatures have no association priorities. The following table summarizes the rules of choosing the operation priorities:

Operation Left Right Comment
Unary prefix operators High High, but slightly lower than the left one Right to left evaluation order. Normally unary operators have higher priorities than binary operators. However, in Ada we find that:

-A*B =

-
*
       
  A     B  
Unary postfix operators High Higher than the left one Usually both priorities are lower than ones of the prefix operators, so that prefix ones would be evaluated first, and the postfix ones next and left to right
Normal infix operators Moderate Slightly higher than the left one Left to right evaluation order. Operators like component extraction  A.B should have both priorities very high.
Assignment operator High Low This ensures that

A + B := C + D =

+
               
    :=
               
        +
               
  A     B     C     D  
Left index brackets Very high   Array indices and function usually have higher priority than most of infix operations, but not all of them::

A+B(C) =

A.B(C) =

+ ()
                       
    () .    
                       
  A     B     C     A     B     C  

Another case of association is represented by sublist semicolons. The semicolons also have an association priority with the arguments in the list. Although semicolon association priorities do not interact with the operators' ones:

(A + B : C, D | E : F, G | H)

()
                               
(| || |)
                               
(: :| |: :|    
+                        
                               
  A     B     C     D     E     F     G     H  

In this example the colon separator has higher priority than one of bar separator.

12.2.3. Association checks

Sometimes operations cannot be arbitrarily associated with each other. There are three cases where operation compatibility can be checked:

and B or C

is illegal. Here the infix operators "and" and "or" are incompatible. Order brackets should be used to make it legal. For instance:

and (B or C)

Unary operators also can be checked. In Ada both

+ - and   A**+2

are illegal (see Ada Language Reference Manual 4.4). When association checks are used for unary operators it is important to define association incompatibility relation transitive. I.e. if an operator x cannot be associated with operator y, but can be with z, then y cannot be associated with z. Otherwise some association error may remain undetected.

( A + B ]

The right square bracket is incompatible with the left round bracket.

12.2.4. Commutative operators

A commutative operation is one which result does not depend on the argument order. For example, numeric addition is commutative because a+b = b+a. When the result does not depend on the operands order, an expression can be optimized by choosing a preferable order among many possible. The preferable order, could be one evaluating the constants and invariants first. For example: 1+a+2 = (1+2)+a = 3+a. Optimization may also take advantage of an inverse operation of a commutative group: 1+a-4 = 1+a+(-4) = (1+(-4))+a = -3+a. Here addition is the operation of a commutative group. Subtraction is the inverse operation. Unary minus is defined as 0-x, where 0 is the group's zero element. To support optimizations of this kind the commutative operations and their inverses can be parsed so that multiple appearances of binary operators will be replaced by an equivalent multiple-operand operation. For example:

A + B - C + D + E

can result in:

+
                   
        -        
                   
  A     B     C     D     E  

Similarly:

A - B - C + D + E

can be parsed as:

-
                   
            - -
                   
  A     B     C     D     E  

Note that the original order can be always restored when the inverse unary operation is prevented from being specified explicitly. For this one can have two different unary minus operations one for explicit use and another used implicitly as the group inverse. So that later if a semantic analysis of the operands involved showed that they in fact were not commutative, then the corresponding optimizations could be omitted and the original order applied.

The following table summarizes the most frequently used commutative groups:

Operators Group's operation Its inverse Inverse unary operation
+, - addition subtraction Unary minus: 0-x
*, / multiplication division 1/x

The operations that are commutative, but usually have no inverse are: logical and bitwise and, or, xor; numerical min, max. Alternatives separator | in Ada is also commutative.

Commutative optimization can be also useful for non-commutative operations. Often it makes sense to make the component selector . commutative to simplify parsing tree.

[Back][TOC][Next]

12.3. The base package

The package Parsers is the parent package of all others. It defines:

type Token_Class is
   
 (  Operator,
        Bracket,
        Comma,
        Ligature,
        Index,
        Sublist_Close,
        Sublist_Separator,
        Sublist_Open,
        Postmodifier,
        Premodifier
     );

This type enumerates the classes of operations. It also defines the subtypes of the sublist separators (semicolons) and modifiers:

subtype Semicolon_Class is Token_Class
   range Sublist_Close..Sublist_Open;
subtype Modifier_Class is Token_Class
   range Postmodifier..Premodifier;

Further the package defines the exceptions:

Syntax_Error : exception;

The exception Syntax_Error is used by lexers. Usually it has information attached containing the error description and location.

Association_Error        : exception;
Missing_Right_Bracket    : exception;
Unexpected_Comma         : exception;
Unexpected_Operation     : exception;
Unexpected_Right_Bracket : exception;
Wrong_Comma_Type         : exception;
Wrong_Right_Bracket_Type : exception;

These exceptions are used when dealing with operation stacks. They are low-level ones, and normally never propagate out of a lexer unhandled.

[Back][TOC][Next]

12.4. Sources

The parser can scan different kinds of sources from plain strings to text files. The generic package Parsers.Generic_Source specifies the abstract interface of a source:

generic
   type
Source_Type (<>) is limited private;
   type Line_Ptr_Type is access constant String;
   type Location_Type is private;
   with function Get_Line (Code : Source_Type)
      return String is <>;
   with procedure Get_Line
                  (  Code    : Source_Type;
                     Line    : out Line_Ptr_Type;
                     Pointer : out Integer;
                     Last    : out Integer
                  )  is <>;
   with function Get_Pointer (Code : Source_Type)
      return Integer is <>;
   with function Get_Backup_Pointer (Code : Source_Type)
      return Integer is <>;
   with function Image (Link : Location_Type)
      return String is <>;
   with function Link (Code : Source_Type)
      return Location_Type is <>;
   with procedure Next_Line (Code : in out Source_Type) is <>;
   with procedure Reset_Pointer (Code : in out Source_Type) is <>;
   with procedure Set_Pointer
                  (  Code    : in out Source_Type;
                     Pointer : Integer
                  )  is <>;
   with function "&" (Left, Right : Location_Type)
      return Location_Type is <>;
package Parsers.Generic_Source is
end
Parsers.Generic_Source;

The package does not provide any operations of its own. It only defines the interface of a source. Here

type Source_Type (<>) is limited private;

is the type of a source. An implementation should maintain two source cursors (pointers). As the parser consumes the source text it advances the cursors. The source slice between two cursors specifies the last token recognized by the parser. It may return back to the token beginning. However if the source contains several lines or records, then cursors always point to same line, so a return may never require the previous line:

source parsing

type Line_Ptr_Type is private;

This pointer type is used to reference source line body in the procedure Get_Line.

type Location_Type is private;

Objects of this type are used to identify a contiguous slice of the source. This can be any part of the source, if multiple lines are supported, then Location_Type should allow to specify several source lines.

function End_Of (Code : Source_Type) return Boolean;

This function returns true at the source end.

function Get_Line (Code : Source_Type) return String;

This function gets the current source code line. It remains valid until the first call to Next_Line. End_Error is propagated when end source was reached either because the source is empty or because of a call to Next_Line before.

procedure Get_Line
          (  Code    : Source_Type;
             Line    : out Line_Ptr_Type;
             Pointer : out Integer;
             Last    : out Integer
          );

This procedure is combines Get_Line and Get_Pointer. It returns a pointer to the buffer containing the current source code line (the parameter Line), the current cursor position (the parameter Pointer) in that buffer and the position of the last character in the buffer (the parameter Last). It might be more efficient than the function Get_Line if the compiler optimization is not great and it might happen that renaming of a slice returned from Get_Line could result in copying its content. The pointer returned may refer to a string longer that the current line. Usually the implementation of a source would hold an internal string buffer. Line might point to it, so that Line (Pointer..Last) would be the rest of the current line, yet to parse. The implementation shall ensure equivalence of the value returned in the Pointer parameter to the one returned by the function Get_Pointer and accepted by Set_Pointer. Usually it is achieved when the function Get_Line returns a slice of the buffer returned by the procedure Get_Line. Note that in Ada string slicing does not shift the lower bound of the result to 1. Thus it is safe to use plain slicing there.  Like the function, the procedure Get_Line raises End_Error at the source end or else when the source is empty.

function Get_Pointer (Code : Source_Type) return Integer;

This function gets the current cursor. The result is an index in the current line which would be returned by Get_Line. It is in the range Line'First..Line'Last+1 provided that Line is the value returned by Get_Line. The character pointed by Get_Pointer is the first one to parse. The characters before are the recognized ones. At the source end, when Get_Line would raise End_Error, 1 is the result.

function Get_Backup_Pointer (Code : Source_Type)
   return Integer;

This function returns the saved cursor. It is one to which Restore_Pointer would return. At the source end, when Get_Line would raise End_Error, 1 is the result. The slice of the current line starting from the result of Get_Backup_Pointer and ending in the character before one pointed by Get_Pointer is usually the last recognized token.

procedure Next_Line (Code : in out Source_Type);

This procedure advances to the next source line. After a successful completion Get_Line can be used to access the newly read source line. Both cursors are set to Get_Line'First. So when the line is not empty Get_Pointer will return the index of the first character in the new source line. Data_Error is propagated on I/O errors. End_Error is propagated when the source end is reached.

procedure Reset_Pointer (Code : in out Source_Type);

This procedure moves the second cursor back to the first cursor, so that Get_Pointer would return the value of Get_Backup_Pointer. The depth of the "unget" need not to be deeper than 1. Consequent calls to Reset_Pointer may have no effect. It is also not required to implement return to the previous line.

procedure Set_Pointer
          (  Code    : in out Source_Type;
             Pointer : Integer
          );

This procedure is used to move the cursors forward. The parameter Pointer is the new position of the second cursor, it should be in the range between the position returned by Get_Pointer and the position following the last character of the current line, i.e. Get_Line (Code)'Last + 1. At the source end when Get_Line would raise End_Error, the only valid value to set is 1. Otherwise Layout_Error is propagated. The first cursor is moved to the old position of the second one. The following small example illustrates an implementation of a routine to skip spaces in the source line:

procedure Skip (Code : in out Source_Type) is
   Line    : String renames Get_Line (Code);
   Pointer : Integer := Get_Pointer (Code);
begin
   while Pointer <= Line'Last and then Line (Pointer) = ' ' loop
      Pointer := Pointer + 1;
   end loop;
   Set_Pointer (Code, Pointer);
end Skip;

The procedure Skip could be implemented using the procedure Get_Line as follows:

procedure Skip (Code : in out Source_Type) is
   Line    : Line_Ptr_Type;
   Pointer : Integer;
   Last    : Integer;
begin
   Get_Line (Code, Line, Pointer, Last);
   while Pointer <= Last and then Line (Pointer) = ' ' loop
      Pointer := Pointer + 1;
   end loop;
   Set_Pointer (Code, Pointer);
end Skip;

function Link (Code : Source_Type) return Location_Type;

This function gets the source code location between two cursors. The second cursor is one returned by Get_Pointer. The first cursor is the previous value of the second one returned by Get_Backup_Pointer. The slice in between is usually the last recognized lexical token. It includes the character pointed by the first cursor, and does not one pointed by the second one. Empty slices are allowed, so Link should never fail even at the end of a source. Should Link (Code) called immediately after a call to Skip above, it would return a location identifying the blank slice matched by Skip in the source code line.

function Image (Link : Location_Type) return String;

This function returns a text description of a location. The result is a string;

function "&" (Left, Right : Location_Type)
   return Location_Type;

This function is used to combine two, usually adjacent a source code locations. The result is a consecutive code fragment containing positions from both Left and Right locations. For example if Left and Right are locations of "(" and ")" then the result is everything in the brackets including the brackets.

Various generic child packages provide parsing facilities to match a thing in a source and move the cursor beyond it:

12.4.1. Source cursors I/O

The child package Parsers.Generic_Source.Text_IO can be used for debugging. It provides:

procedure Put_Line
          (  File        : File_Type;
             Code        : Source_Type;
             Expand_Tabs : Boolean := False
          );
procedure Put_Line
          (  Code        : Source_Type;
             Expand_Tabs : Boolean := False
          );

These procedures output the current source code line following current source cursors. The output might look like:

123.0 + ( Value - 1)
          ^^^^^|

The parameter File is the text file to write. It is the standard output if missing. Code is the source code. The parameter Expand_Tabs when true forms the second output line in accordance with the tabulations expanded in the first line. The tabulations of the first line are not explicitly expanded, but output as-is.

The package Parsers.Multiline_Source.Location_Text_IO is an instance of Parsers.Generic_Source.Text_IO for the multi-line source provided in the package Parsers.Multiline_Source.

12.4.2. Procedures to skip blanks

There are three child procedures of Parsers.Generic_Source which can be used to skip the following blanks and comments:

generic
procedure Parsers.Generic_Source.Get_Blank
          (  Code   : in out Source_Type;
             Got_It : out Boolean
          );

This procedure skips spaces, tabulations (HT), line feeds (LF), carriage returns (CR), vertical tabulations (VT), form feeds (FF) and requests new source lines when necessary. Upon completion Got_It is set to true if the source end is not yet reached. Otherwise it is false.

generic
procedure Parsers.Generic_Source.Get_Ada_Blank
          (  Code   : in out Source_Type;
             Got_It : out Boolean
          );

This procedure skips Ada 95 comments, spaces, HT, LF, CR, VT, FF and requests new source lines when necessary. Upon completion Got_It is set to true if the source end is not yet reached. Otherwise it is false. Beware that according to Ada 95 RM 2.2 comment ends either at the physical line end or in either of format effectors: LF, CR, VT, FF. This may lead to surprises when format effectors appear in the middle of what the operating system counts for a single line.

generic
procedure Parsers.Generic_Source.Get_Ada_2005_Blank
          (  Code   : in out Source_Type;
             Got_It : out Boolean
          );

This procedure skips Ada 2005 comments and blanks. It is similar to Get_Ada_Blank except that UTF-8 encoded space separators are also considered blank.

generic
procedure Parsers.Generic_Source.Get_Cpp_Blank
          (  Code     : in out Source_Type;
             Got_It   : out Boolean;
             Error    : out Boolean;
             Error_At : out Location_Type
          );

This procedure skips C++ comments, spaces, HT, LF, CR, VT, FF and requests new source lines when necessary. A C++ comment either starts with // (double forward slash) and continues to the end of the current line or it does with /* (forward slash, asterisk) and continues to the first appearance of closing */. In the latter case nested /*..*/ comments are not recognized. Upon completion Got_It is set to true if the source end is not yet reached. Otherwise it is false. Error is set to true when no closing */ is found before the source end. In this case Error_At contains the location of /* in the source. Otherwise, Error is false and Error_At is not defined.

12.4.3. Procedure to skip text

There are two child procedures of Parsers.Generic_Source which can be used to skip a text in the source:

generic
procedure Parsers.Generic_Source.Get_Text
          (  Code   : in out Source_Type;
             Text   : String;
             Got_It : out Boolean;
             Map    : Character_Mapping := Identity 
          );
generic

procedure Parsers.Generic_Source.Get_UTF8_Text
          (  Code   : in out Source_Type;
             Text   : String;
             Got_It : out Boolean;
             Map    : Unicode_Mapping := Identity 
          );

The procedure Get_Text is used for dealing with Latin-1 encoded sources. The procedure Get_UTF8_Text is used with UTF-8 sources. Upon completion Got_It is set to true if Text was recognized and skipped. Otherwise it is false. It can be used for creating simple recursively descending parsers. The parameter Map specifies the character equivalence. A character in the source and in Text are equivalent when they are equivalent in Map. The default value considers all characters distinct. To have case-insensitive match one can use Ada.Strings.Maps.Constants.Lower_Case_Map with Get_Text, and.Strings_Edit.UTF8.Maps.Constants.Lower_Case_Map with Get_UTF8_Text. Syntax_Error is propagated from Get_UTF8_Text when source is not properly encoded UTF-8.

12.4.4. Matching keywords

When writing recursive descent parsers it is common to match the source against a list of keywords. The child procedure Get_Token of Parsers.Generic_Source can be used for this purpose. It has a generic formal parameter Tokens which is an instance of the package Tables:

generic
   with package
Tokens is new Tables (<>);
procedure
Parsers.Generic_Source.Get_Token
          (  Code   : in out Source_Type;
             Folder : Tokens.Table'Class;
             Token  : out Tokens.Tag;
             Got_It : out Boolean
          );

The procedure matches the source Code against the table Folder. If a token from Folder is matched, then it is skipped in Code, the value associated with it is stored in Token and Got_It is set to true. Otherwise Got_It is set to false, and Token is not changed. Note that Folder can be a descendant of the table type defined in Tables. This means that one can also use case-insensitive tables from the package Tables.Names.

When keywords to match are plain case-insensitive words, the generic child package Keywords can be used instead of Get_Token. An enumeration type is the generic parameter of the package. The literals of the type are the keywords to match:

generic
   type
Keyword is (<>);
package Parsers.Generic_Source.Keywords is
   ...

The package provides the procedure:

procedure Get
          (  Code   : in out Source_Type;
             Token  : out Keyword;
             Got_It : out Boolean
          );

This procedure matches a keyword in Code. Matching is case-insensitive. When matched the keyword value is set into Token and Got_It is set to true. The source cursor is then advanced behind the text matched. The longest possible token is always matched. When no token matches the source Got_It is set to false. The following code sample illustrates usage of the package:

with Parsers.Multiline_Source; -- Muiltiline sources
...
   type Color_Type is (Red, Blue, White, Green);
   package Colors is
      new
Parsers.Multiline_Source.Code.Keywords (Color_Type);
   ...
   Color  : Color_Type;
   Got_It : Boolean;
begin
   ...
   loop -- Parsing loop
      ...
      Colors.Get (Code, Color, Got_It);
      if not Got_It then
         ... -- This is probably a syntax error
      else
         case
Color is
            when
Red  => -- "red" was matched
               ...
            when Blue => -- "blue" was matched
      ...

This package has a limited use, because many words are reserved in Ada, and thus cannot be enumeration literals.

12.4.5. Parsing XPM files

This is a useful example of designing parsers unrelated to infix expressions, based solely on sources. The source code is located in the subdirectory xpm. It provides a set of types to deal with XPM image format. The package is generic:

generic
package
Parsers.Generic_Source.XPM is
   ...

It can be instantiated for any type sources, but usually it makes sense for multi-line sources only. The is an instance of the package for this case: Parsers.Multiline_Source.XPM.

The generic package provides three subprograms for parsing XPM files. An XPM file is basically a C program containing data structures of an image. The source of it is usually parsed this way:

declare
   Header : Descriptor         := Get (Source);
   Map    : Color_Tables.Table := Get (Source, Header);
   Image  : Pixel_Buffer       := Get (Source, Header, Map);
begin
   ... --
The image can be used here

The package defines the following data types and subroutines:

type Descriptor
     (  Has_Hotspot : Boolean;
        Length      : Positive
     )  is
record
   Name       : String (1..Length);
   Width      : Positive;
   Height     : Positive;
   Pixel_Size : Positive;
   Map_Size   : Positive;
   Extended   : Boolean;
   case
Has_Hotspot is
      when
True =>
         X_Hotspot : Natural;
         Y_Hotspot : Natural;
      when
False =>
         null
;
   end case
;
end record
;

The descriptor holds the information about an XPM image:

function Get (Code : access Source_Type) return Descriptor;

This function matches XPM descriptor in Code and returns the value of. Syntax_Error is propagated on syntax errors. Other exceptions are related to the source access.

type RGB_Color is range 0..2**24;
Transparent : constant RGB_Color := RGB_Color'Last;
package Color_Tables is new Tables (RGB_Color);

The color values are encoded as RGB, big-endian. For example, Red is 16#FF0000#. The value 2**24 is used for the transparent color. The type Color_Table.Table is a mapping from String to RGB_Color used to represent color maps. It is an instance of Tables.

function Get
         (  Code   : access Source_Type;
            Header : Descriptor
         )  return Color_Tables.Table;

This function matches XPM color map in Code and returns the value of. Header is a descriptor obtained by a call to Get immediately before. Syntax_Error is propagated on syntax errors. Other exceptions are related to the source access.

type Pixel_Buffer is
   array
(Positive range <>, Positive range <>)
      of RGB_Color;

This type is used to represent the image pixels as row x column.

function Get
         (  Code   : access Source_Type;
            Header : Descriptor;
            Map    : Color_Tables.Table
         )  return Pixel_Buffer;

This function matches XPM image in Code and returns the value of. Header is a descriptor obtained by a call to Get and Map is a color map obtained by a call to Get. Syntax_Error is propagated on syntax errors. Other exceptions are related to the source access.

12.4.6. String sources

The package Parsers.String_Source provides an implementation of code source based on standard strings. The package is non-generic. It instantiates Parsers.Generic_Source under the name Code. So the package Parsers.String_Source.Code can be used everywhere an instance of Parsers.Generic_Source is required. Additionally the package defines:

type Location is record
   From   : Integer;
   Length : Natural;
end record;

This is the type used for string source locations.

type Source (Text : access String) is limited record
   Pointer : Integer := Text'First;
   Last    : Integer := Text'First;
end record;

This is the type of a string source. The discriminant Text points to the string being parsed.

12.4.7. Multi-line sources

The package Parsers.Multiline_Source provides an implementation of code sources consisting of several lines. The package is non-generic. It instantiates Parsers.Generic_Source under the name Code. So the package Parsers.Multiline_Source.Code can be used everywhere an instance of Parsers.Generic_Source is required. The package defines an abstract base type Source which should be concretized by overriding its abstract operations. The package defines:

type Line_Number is new Natural;

The source line numbers.

type Position is record
   Line   : Line_Number;
   Column : Integer;
end record;

The source position.

function "<" (Left, Right : Position) return Boolean;

The source positions are comparable using both "=" and "<" .

type Location is record
   First : Position;
   Next  : Position;
end record;

The source locations are specified by the first character position and the position of the first character next to location.

type Source is
   abstract new
Ada.Finalization.Limited_Controlled with
record

   Buffer  : String_Ptr;
   Line    : Line_Number := 0;
   Length  : Natural;
   Pointer : Integer;
   Last    : Integer;
end record;

Here the fields are:

The field Buffer points to a string, which is used to keep the current source line. The constructor allocates the buffer of some reasonable size. When a new line is requested the buffer can be replaced by a larger one if necessary.

procedure Finalize (Code : in out Source);

The destructor deallocates the buffer.

procedure Initialize (Code : in out Source);

The constructor creates the buffer.

procedure Get_Line (Code : in out Source) is abstract;

This is an abstract procedure to be overridden. An implementation should read a complete next line into Code.Buffer.all. It may reallocate the buffer if necessary. After a successful completion Code.Buffer should point to a buffer containing the line and Code.Length should be the line length. The rest of the buffer is ignored. End_Error is propagated if no more lines available. Other exceptions can be used on I/O error.

function Get_Location
         (  Message : String;
            Prefix  : String := "at "
         )  return Location;

This function searches for a location image in an error message string. The image is searched backwards for an appearance of Prefix. If an image does not follow Prefix search continues. The result is the location decoded according to the format used by Image. If no image found the result is ((0,0), (0,0).

procedure Skip (Code : in out Source'Class; Link : Location);

This procedure advances the source Code to the location Link, so that the result of Link (Code) would equal to the value of the parameter Link. Layout_Error is propagated when the source is beyond the first position of Link. It is also propagated when some parts of Link do not belong to the source Code.

The following sample code illustrates use of Skip and Get_Location for error output:. The procedure takes error occurrence and the source file name. Then it opens the file, moves to the error location obtained and prints the location together with the error message.

with Ada.Text_IO;               use Ada.Text_IO;
with
Ada.Exceptions;            use Ada.Exceptions;
with
Parsers.Multiline_Source;  use Parsers.Multiline_Source;

with
Parsers.Multiline_Source.Location_Text_IO;
use 
Parsers.Multiline_Source.Location_Text_IO;

procedure
Show_Error (Error : Erroc_Occurrence; File_Name : String) is
   File : aliased File_Type;
begin
   Open (File, In_File, File_Name);
   declare
      Code : Parsers.Multiline_Source.Text_IO.Source (File'Access);
   begin
      Skip (Code, Get_Location (Exception_Message (Error)));
      Put_Line (Code);
   exception
      when others
=>
         null;
   end;
   Close (File);
   Put_Line ("Error : " & Exception_Message (Error));
exception
   when others
=>
      Close (File);
      Put_Line ("Error : " & Exception_Message (Error));
end Show_Error;

12.4.8. Text file sources

The package Parsers.Multiline_Source.Text_IO provides sources based on text files. It declares the type Source:

type Source (File : access File_Type) is
   new Multiline_Source.Source with private;

The discriminant File points to the file to read. The type File_Type is defined in Ada.Text_IO. See also Parsers.Multiline_Source.Latin1_Text_IO and Parsers.Multiline_Source.Wide_Text_IO packages used for handling Latin-1 and wide (UCS-2) encoded files as with recoding into UTF-8.

12.4.9. Standard input source

The package Parsers.Multiline_Source.Standard_Input provides sources based on the standard input file. It declares the type Source:

type Source is new Multiline_Source.Source with private;

12.4.10. Latin-1 and wide text file sources

The package Parsers.Multiline_Source.Latin1_Text_IO provides sources based on latin-1 text files. It declares the type Source:

type Source (File : access File_Type) is
   new Multiline_Source.Source with private;

The discriminant File points to the file to read. The type File_Type is defined in Ada.Text_IO. The package is used to read text files encoded in Latin-1, when the parser is designed for UTF-8. Otherwise, Latin-1 files can also be read using Parsers.Multiline_Source.Text_IO. The implementation recodes the input into UTF-8, so that the parser need not to care about the actual encoding. Note that the source position is translated correspondingly, i.e. Pointer would refer to the source line octet offset rather than to the corresponding character position.

The package Parsers.Multiline_Source.Wide_Text_IO provides sources based on wide text files. It declares the type Source:

type Source (File : access File_Type) is
   new Multiline_Source.Source with private;

The discriminant File points to the file to read. The type File_Type is defined in Ada.Wide_Text_IO. The package is used to read text files encoded in a way that requires wide text I/O. Usually it is UCS-2 files. The implementation recodes the input into UTF-8, so that the parser need not to care about the actual encoding. Note that the source position is translated correspondingly, i.e. Pointer would refer to the source line octet offset rather than to the corresponding character position.

12.4.11. Stream sources

The package Parsers.Multiline_Source.Stream_IO provides sources based on streams. The stream is read using the Character'Read stream attribute. The read characters are classified into the data and delimiter characters. The delimiter categories are defined by the type:

type Delimiter is (Line_End, Line_Trailer, Text_End);

Here the categories of the delimiters are:

Additionally, the End_Error exception, when propagated by Character'Read, acts as if a Text_End character were read. The package Delimiter_Map

package D