Data Structures Containing Limited Items

In this article I show how to implement a stack whose items are limited.

Most data structures you see are implemented this way:

generic
  type Item_Type is private;
package Stacks is

  type Stack_Type is limited private;

  procedure Push (Item : in     Item_Type;
                  On   : in out Stack_Type);
...
end Stacks;

The generic formal type Item_Type is non-limited, so it comes with
assignment.  This allows you to implement operation Push (for a bounded
stack) like this:

  procedure Push (Item : in     Item_Type;
                  On   : in out Stack_Type) is
  begin
     On.Top := On.Top + 1;
     On.Items (On.Top) := Item;
  end;

But suppose you need a stack of, say, files?  Type File_Type, in
Text_IO, is limited:

  type File_Type is limited private;

so you wouldn't be able to instantiate the stack package above.  But
even if you could, it's not clear how you'd implement Push, which
requires assignment.

This isn't an issue just for stacks.  In my previous posts on
reference-counted lists, Cons and Set_Head did the same thing, using
assignment to copy the item to the node at the head of the list.

Here is the solution: allocate an empty slot at the top of the stack,
which creates an uninitialized object, to which a client later refers
indirectly, via an access object.

Whew!  All that means is that Push will look like this:

   procedure Push (Stack : in out Stack_Type);

which may seem a bit strange, since Push doesn't take an Item
parameter.  All Push does here is allocate the top object, but doesn't
actually give it a value.

In a traditional implementation, stack objects are hidden from the
client, who can only set and get top values.  In this alternative
implementation, we let the client manipulate the actual object:

   type Item_Access is access all Item_Type;

   function Set_Top (Stack : Stack_Type) return Item_Access;

Operation Set_Top returns an access object which designates the object
at top of the stack.  The client can then refer to the object by
dereferencing the pointer:

   Push (Stack);

   declare
      File : File_Type renames Set_Top (Stack).all;
   begin
      Create (File, Out_File, "myfile.dat");
      ...
   end;

We can combine these two separate operations into one, so that Push
returns the reference itself:

   function Push
     (Stack : in Stack_Type) return Item_Access;

Rewriting the example above:

  declare
    File : File_Type renames Push (Stack).all;
  begin
    Create (File, Out_File, "myfile.dat");
    ...
  end;

The File_Manager (see the code) is a high-level abstraction for
manipulating a collection of instances of type File_Type, which is
implemented using our special stack.

The test driver pushes four files on the stack, then lists their names
and contents:

$ test_file_manager
Name is '/home/matt/patterns/collections-of-limited-items/eddie.txt'
Name is '/home/matt/patterns/collections-of-limited-items/french.txt'
Name is '/home/matt/patterns/collections-of-limited-items/emacs.txt'
Name is '/home/matt/patterns/collections-of-limited-items/wave.txt'
van halen rules!
je vous aime
emacs: everything but the kitchen sink
killer wave, dude


Implementation Issues

The bounded stack in this example is implemented in the traditional way,
as an array of items, and an index for the top:

   type Item_Array is
      array (Positive range 1 .. Max_Depth) of aliased Item_Type;

   type Stack_Type is
      limited record
         Items : Item_Array;
         Top   : Natural := 0;
      end record;

The only wrinkle here is that Item_Array is an array of "aliased" items.
This is so, because we need to return access objects that designate
individual array elements.

All Push has to do to "allocate a new top item" is increment the top
index:

   procedure Push (Stack : in out Stack_Type) is
   begin
      Stack.Top := Stack.Top + 1;
   end;

Set_Top is named so because we want to contrast it to Get_Top, which has
its traditional implementation, returning the value of the item at the
top of the stack:

   function Get_Top
     (Stack : Stack_Type) return Item_Type is
   begin
      return Stack.Items (Stack.Top);
   end;

Get_Top does not change the state of the stack.  Neither does Set_Top
really, because that operation just returns a pointer to the top object,
but we wish to emphasize that state changes are involved (because the
client is going to be change the value of the top object).

In an ideal language, all subprograms would allow you to have in out
parameters, even value-returning subprograms.  We would really like to
declare Set_Top this way:

  function Set_Top (Stack : in out Stack_Type) return Item_Access;

However, we can't do this in Ada, because some people have the strange
belief that if you spell a value-returning subprogram f-u-n-c-t-i-o-n,
that that spelling somehow gives the subprogram special status, a status
that disallows in out parameter modes.  Weird.

We can work around this egregious limitation by making Stack an access
parameter:

  function Set_Top (Stack : access Stack_Type) return Item_Access;

This is actually safer than the technique I'm about to show you, but
there are a couple of issues with it.

One issue is that it adds even more syntactic overhead to an operation
that already has a fair amount of syntactic overhead.  You have to
declare the stack object as aliased, and then take the 'Access of that
stack:

  Stack : aliased Stack_Type;
...
  Set_Top (Stack'Access).all := ...;

or

  Close (Set_Top (Stack'Access).all);

It's bad enough that we have to apply the .all selector to the result of
a function, but having to take the 'Access of the input parameter too is
like adding insult to injury.

The other issue is that these data structures are written to support
static polymorphism.  Suppose we had an unbounded stack, implemented as
a linked list of nodes allocated on the heap.  We could legally
implement Set_Top as

  type Node_Type is
     limited record
        Item : aliased Item_Type;
        Next : Node_Access;
     end record;

  function Set_Top (Stack : in Stack_Type) return Item_Access is
  begin
     return Stack.Top.Item'Access;
  end;

because the node is on the heap, and there's no need to worry about
accessibility levels.  So the bounded version of Set_Top would have an
access parameter, but the unbounded version would have an in parameter.

But this is no good, because we want to have a consistent interface for
all stacks, so that if we want to change to an unbounded form (say),
then the only code we have to modify is the instantiation.  This is how
Direct_IO and Sequential_IO are designed.

So we want Set_Top to take an in parameter for two reasons: so we can
avoid syntactic overhead, and to have an interface consistent with other
stacks.

The language requires that you have an "aliased view" when you take the
'Access of an object, so this wouldn't work:

   function Set_Top
     (Stack : Stack_Type) return Item_Access is
   begin
      return Stack.Items (Stack.Top)'Access;
   end;

because the Stack parameter isn't an access parameter, and isn't
tagged.

We work around that problem by using our friend
System.Address_To_Access_Conversions, which provides a portable way of
converting between addresses and access objects.

Instantiating that package on Stack_Type provides the operations we need
to get an aliased view of the stack, which we can then use to legally
take the 'Access of a stack item:

   function Set_Top
     (Stack : Stack_Type) return Item_Access is

      SA : constant Object_Pointer :=
        To_Pointer (Stack'Address);
   begin
      return SA.Items (SA.Top)'Access;
   end;

Note that taking the 'Address of a subprogram parameter only makes sense
if the parameter is passed by reference.  The language mandates that
limited types and tagged types are passed by reference, so all we need
to do is implement the full view of Stack_Type as a limited record:

   type Stack_Type is
      limited record
         Items : Item_Array;
         Top   : Natural := 0;
      end record;

If you're implementing a non-limited private type, then just privately
implement the type as tagged, and this will guarantee that objects of
that type get passed by reference.

The stack example also exports an active iterator with a Set_Item
operation (analogous to Set_Top) which allows us to modify any item in
the stack, not just the top one.

I realize that this is a bit of a back-door technique, and that it isn't
as safe as the access parameter alternative.  However, I take the
attitude that programmers basically know what they are doing, and that
type safety will be built into the next higher level of abstraction.

Matt

The code below is in a format suitable for use with gnatchop.


--STX
with System.Address_To_Access_Conversions;

generic

   type Item_Type is limited private;

   Max_Depth : in Positive;

package Stacks is

   type Stack_Type is limited private;


   type Item_Access is access all Item_Type;

   for Item_Access'Storage_Size use 0;

   function Push
     (Stack : in Stack_Type) return Item_Access;

   procedure Push (Stack : in out Stack_Type);

   procedure Pop (Stack : in out Stack_Type);


   function Get_Top
     (Stack : Stack_Type) return Item_Type;

   function Set_Top
     (Stack : Stack_Type) return Item_Access;


   function Get_Depth
     (Stack : Stack_Type) return Natural;


   generic
      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);
   procedure For_Every_Item (Stack : in out Stack_Type);


   type Stack_Iterator is private;

   function Initialize
     (Stack : Stack_Type) return Stack_Iterator;

   function Is_Done
     (Iterator : Stack_Iterator) return Boolean;

   function Get_Item
     (Iterator : Stack_Iterator) return Item_Type;

   function Set_Item
     (Iterator : Stack_Iterator) return Item_Access;

   procedure Advance
     (Iterator : in out Stack_Iterator);

private

   type Item_Array is
      array (Positive range 1 .. Max_Depth) of aliased Item_Type;

   type Stack_Type is
      limited record
         Items : Item_Array;
         Top   : Natural := 0;
      end record;


   package Address_To_Access_Conversions is
     new System.Address_To_Access_Conversions (Stack_Type);

   type Stack_Iterator is
      record
         Stack : Address_To_Access_Conversions.Object_Pointer;
         Index : Natural;
      end record;

end Stacks;


package body Stacks is

   use Address_To_Access_Conversions;


   function Push
     (Stack : in Stack_Type) return Item_Access is

      SA : constant Object_Pointer :=
        To_Pointer (Stack'Address);
   begin
      SA.Top := SA.Top + 1;
      return SA.Items (SA.Top)'Access;
   end;


   procedure Push (Stack : in out Stack_Type) is
   begin
      Stack.Top := Stack.Top + 1;
   end;

   procedure Pop (Stack : in out Stack_Type) is
   begin
      Stack.Top := Stack.Top - 1;
   end;


   function Get_Top
     (Stack : Stack_Type) return Item_Type is
   begin
      return Stack.Items (Stack.Top);
   end;


   function Set_Top
     (Stack : Stack_Type) return Item_Access is

      SA : constant Object_Pointer :=
        To_Pointer (Stack'Address);
   begin
      return SA.Items (SA.Top)'Access;
   end;


   function Get_Depth
     (Stack : Stack_Type) return Natural is
   begin
      return Stack.Top;
   end;


   procedure For_Every_Item (Stack : in out Stack_Type) is
      Done : Boolean := False;
   begin
      for I in reverse Integer range 1 .. Stack.Top loop
         Process (Stack.Items (I), Done);
         exit when Done;
      end loop;
   end For_Every_Item;


   function Initialize
     (Stack : Stack_Type) return Stack_Iterator is
   begin
      return (To_Pointer (Stack'Address), Stack.Top);
   end;


   function Is_Done
     (Iterator : Stack_Iterator) return Boolean is
   begin
      return Iterator.Index = 0;
   end;


   function Get_Item
     (Iterator : Stack_Iterator) return Item_Type is
   begin
      return Iterator.Stack.Items (Iterator.Index);
   end;


   function Set_Item
     (Iterator : Stack_Iterator) return Item_Access is
   begin
      return Iterator.Stack.Items (Iterator.Index)'Access;
   end;


   procedure Advance
     (Iterator : in out Stack_Iterator) is
   begin
      Iterator.Index := Iterator.Index - 1;
   end;


end Stacks;


with Stacks;
with Ada.Text_IO; use Ada.Text_IO;

procedure Test_Stacks is

   package File_Stacks is new Stacks (File_Type, 10);
   use File_Stacks;

   Stack : Stack_Type;

   procedure Display_File
     (File : in out File_Type;
      Quit : in out Boolean) is

      Line : String (1 .. 80);
      Last : Natural;

   begin

      Put ("Contents of file ");
      Put (Name (File));
      New_Line;

      Reset (File, In_File);

      while not End_Of_File (File) loop
         Get_Line (File, Line, Last);
         Put_Line (Line (1 .. Last));
      end loop;

      New_Line (2);

   end Display_File;

   procedure Display_Files is
     new For_Every_Item (Display_File);

begin

   Push (Stack);

   declare
      File : File_Type renames Set_Top (Stack).all;
   begin
      Create (File, Out_File, "first_file.txt");
      Put_Line (File, "this is the first file pushed on the stack");
   end;

   Push (Stack);

   declare
      File : File_Type renames Set_Top (Stack).all;
   begin
      Create (File, Out_File, "second_file.txt");
      Put_Line (File, "this is the second file pushed on the stack");
   end;

   Display_Files (Stack);

end Test_Stacks;



with Ada.Text_IO;  use Ada.Text_IO;

package File_Manager is

   procedure Create_File (Name : in String);


   function Get_File return File_Type;


   type File_Access is access all File_Type;

   function Set_File return File_Access;


   procedure List_Files;

   generic
      with procedure Process
        (File : in out File_Type;
         Done : in out Boolean);
   procedure Visit_Files;

   procedure Close_Files;

end File_Manager;


with Stacks;

package body File_Manager is

   package File_Stacks is
     new Stacks (File_Type, Max_Depth => 10);

   use File_Stacks;

   Stack : Stack_Type;


   procedure Create_File (Name : String) is

      File : File_Type renames Push (Stack).all;
   begin
      Create (File, Mode => Out_File, Name => Name);
   end;


   function Get_File return File_Type is
   begin
      return Get_Top (Stack);
   end;


   function Set_File return File_Access is
   begin
      return File_Access (Set_Top (Stack));
   end;


   procedure List_Files is

      procedure Put_Name
        (File : in out File_Type;
         Done : in out Boolean) is

      begin
         Put_Line ("Name is '" & Name (File) & "'");
      end;

      procedure Put_Names is
        new For_Every_Item (Put_Name);

   begin

      Put_Names (Stack);

   end List_Files;


   procedure Visit_Files is

      Iter : Stack_Iterator :=
        Initialize (Stack);

      Done : Boolean := False;

   begin

      while not Is_Done (Iter) loop

         Process (Set_Item (Iter).all, Done);

         exit when Done;

         Advance (Iter);

      end loop;

   end Visit_Files;



   procedure Close_Files is
   begin

      while Get_Depth (Stack) > 0 loop

         Close (Set_Top (Stack).all);

         Pop (Stack);

      end loop;

   end Close_Files;


end File_Manager;


with File_Manager;  use File_Manager;
with Ada.Text_IO;   use Ada.Text_IO;

procedure Test_File_Manager is
begin

   Create_File ("wave.txt");
   Put_Line (Get_File, "killer wave, dude");

   Create_File ("emacs.txt");
   Put_Line (Get_File, "emacs: everything but the kitchen sink");

   Create_File ("french.txt");
   Put_Line (Get_File, "je vous aime");

   Create_File ("eddie.txt");
   Put_Line (Get_File, "van halen rules!");

   List_Files;


   declare

      procedure Put_File
        (File : in out File_Type;
         Done : in out Boolean) is

         Line : String (1 .. 80);
         Last : Natural;
      begin
         Reset (File, Mode => In_File);
         Get_Line (File, Line, Last);
         Put_Line (Line (1 .. Last));
      end;

      procedure Put_Files is
        new Visit_Files (Put_File);

   begin

      Put_Files;

   end;


   Close_Files;

end Test_File_Manager;