AdaPower Logged in as Guest
Ada Tools and Resources

Ada 95 Reference Manual
Ada Source Code Treasury
Bindings and Packages
Ada FAQ


Join >
Home >
Articles >
Getting Started >
Ada FAQ >
Source Treasury >
Books & Tutorials >
Packages for Reuse >
Latest Additions >
Ada Projects >
Press Releases >
Ada Audio / Video >
Home Pages >
Links >
Contact >
About >
Login >
Back
Iterator and Factory Method Patterns Combined (Matthew Heaney)

Introduction

This article describes what an active iterator is, and how to use a factory method to create one.

There are also examples of using System.Address_To_Access_Conversions to get around the limitation of not having in out parameter modes for functions.

Iterators: Active vs Passive

Ordered data structures allow you to access a single item, for example the top of a stack, or the front of a queue, or the head of a list. An iterator effectively extends the behavior of the abstraction, by allowing you to visit all the items in a data structure.

There are two kinds of iterators: passive and active. A passive iterator controls the actual movement within the data structure, and all a client has to do is supply a procedure to receive each item in turn.

There was an example of a passive iterator in my posts about the visitor pattern:


   generic
      with procedure Process
        (Item : access Root_Equipment'Class);
   procedure For_Every_Item
     (Composite : access Composite_Equipment'Class);

You can use this to visit each piece of equipment in the composite object. The composite itself uses it to implement its destructor:

   procedure Do_Free
     (Composite : access Composite_Equipment) is

      procedure Free_Item
        (Item : access Root_Equipment'Class) is
      begin
         Do_Free (Item);
      end;

      procedure Free_Items is
        new For_Every_Item (Free_Item);

   begin

      Free_Items (Composite);

   end Do_Free;

An active iterator moves the resposibility for movement onto the client. Unlike a passive iterator, which is essentially just a generic subprogram, an active iterator is an actual type, with primitive operations for retrieving the current item and for moving to the next item in the sequence.

You often see active iterators implemented as a limited private type, with an access discriminant:

   type Stack_Iterator
     (Stack : access Stack_Type) is limited private;

   function Done
     (Iterator : Stack_Iterator) return Boolean;

   function Get_Item
     (Iterator : Stack_Iterator)
     return Item_Type;

   procedure Advance
     (Iterator : in out Stack_Iterator);

You would typically use this in a loop, to process each item:

   Stack : aliased Stack_Type;
...
   declare
      Iter : Stack_Iterator (Stack'Access);
   begin
      while not Done (Iter) loop
         ... process Get_Item (Iter) ...
         Advance (Iter);
      end loop;
   end;

Factory Methods

However, there is a potential problem with the formulation above. There are times when you'd like to be able to invoke a constructor for the iterator during its declaration, as in:

  declare
     Iter : Iterator_Type := Initialize (Stack);
  begin

but this is not possible, because the type is limited.

Here's an example of a time when you'd need to do this. Each specific type in a data structure hierarchy needs its own iterator, because the iterator needs to have access to the representation of the type. But suppose you want to iterate over a stack (say) whose type is class-wide, something like:

  procedure Print (Stack : in Root_Stack'Class) is 

     Iter :  ...;  <-- ???
  begin

How to you get an iterator for the specific type, if you have only a class-wide object?

The answer is that you ask the stack to give you an iterator that will allow you to iterate over that stack. Here's where the factory method comes in.

A "factory method" is just a fancy name for a dispatching constructor that returns a class-wide object. A factory method for iterators would look something like:

  function Initialize
    (Stack : Root_Stack)
    return Root_Iterator'Class;
Note carefully the types in this declaration. Initialize is a primitive operation of stack, and therefore takes the specific stack type as a parameter, but its return type is a class-wide iterator.

We can implement the Print operation above using a factory method constructor for iterators:

  procedure Print (Stack : in Root_Stack'Class) is 

     Iter : Root_Iterator'Class := Initialize (Stack);
  begin

We then call iterator operations (Get_Item, Advance) that dispatch according to the tag of the iterator:

     while not Done (Iter) loop
       Put_Line (Get_Item (Iter));
       Advance (Iter);
     end loop;

  end Print;

This is also an example of double dispatching: dispatch an interator constructor according to the tag of Stack, and then dispatch iterator operations according to the tag of the iterator returned by the constructor.

The declaration of a class-wide object requires that the object be given an initial value, because a class-wide type is indefinate. (In our case, the initial value is supplied by the factory method constructor.) This means we need assignment for the type, and therefore the iterator must be declared as non-limited.

Discussion of Examples

I've chosen a stack as the data structure to illustrate iterators and factory methods, because it presents an interesting problem: How do you copy one stack into another, without the copy being in reverse order?

In a naive implementation, we would iterate over the source stack from top to bottom, and push each item onto the target stack. But this is wrong, because the target would be backwards (the top of the target stack contains the bottom of the source stack).

There are two ways to solve this problem:

1) Iterate over the source stack in bottom-to-top order, and push each item in turn onto the target.

2) Iterate over the source stack in top-to-bottom order, but populate the target stack backwards (push the item on bottom of the stack).

There are implementation issues associated with each of these solutions:

1) The iterator for the source stack has to be able to traverse that stack in bottom-to-top order. This will require that the source stack be implemented using a doubly-linked list. If you only needed top-to-bottom traversal, then a singly-linked list implementation would suffice.

The benefit of this approach is that, if you do have a bottom-to-top iterator, then you only have to implement the Copy operation once, because it uses the standard Push operation of the target.

2) In order to populate the target stack backwards, you have to have access to the representation of the stack, because you're doing a very special kind of push. This will require that the populate operation (here, Copy) be a primitive operation of the target stack.

For a stack hierarchy, this requires that each different stack type implement its own version of Copy (because each target type has a different representation). If your source stack doesn't have a bottom-to-top iterator, this is your only choice.

For this example, I've implemented Copy using the first approach (see the body of Stacks):

   procedure Copy
     (From : in     Root_Stack'Class;
      To   : in out Root_Stack) is

      Iter : Root_Iterator'Class :=
        Start_At_Bottom (From);
   begin
      ...
Like we saw earlier in the Print operation, this operation starts off by declaring an class-wide iterator object, initialized by calling a factory method, Start_At_Bottom.

Since this stack is implemented using a doubly-linked list, it permits iteration in both top-to-bottom and bottom-to-top order. That means the client needs to state where she wants to start, either at the top of the stack or the bottom.

There are therefore two constructors for this iterator class:

   function Start_At_Top
     (Stack : Root_Stack)
      return Root_Iterator'Class is abstract;

   function Start_At_Bottom
     (Stack : Root_Stack)
      return Root_Iterator'Class is abstract;

(For subtle reasons, I decided not to implement one constructor that takes an enumeration value indicating which end to start at.)

There are also two modifiers to move the iterator, either towards the bottom (Advance) or towards the top (Backup):

   procedure Advance
     (Iter : in out Root_Iterator) is abstract;

   procedure Backup
     (Iter : in out Root_Iterator) is abstract;

The remainder of the Copy operation follows the same pattern as we've seen before: call Get_Item to return the current item designated by the iterator, do something with the item (here, push it on the target stack), and then move the iterator (Backup) in order to designate the next item:

  begin
      ...

      for I in 1 .. Get_Length (From) loop
         Push (Get_Item (Iter), On => Root_Stack'Class (To));
         Backup (Iter);
      end loop;

   end Copy;

The next example of iterator and factory method combined is in the implementation of equality. Stacks are equal if they have the same values in the same order, so we should be able to compare stacks just by using iterators to compare items. Furthermore, we should only need to write this operation once, so that we can compare any stack type to any other stack type in the same class.

Equality starts out by using a constructor to create iterators for both arguments:

   function "="
     (L : Root_Stack;
      R : Root_Stack'Class)
      return Boolean is

      L_Iter : Root_Iterator'Class :=
        Start_At_Top (Root_Stack'Class (L));

      R_Iter : Root_Iterator'Class :=
        Start_At_Top (R);
...

It doesn't really make any difference where we start, so here I decided to just start at the top of the stacks, and advance towards the bottom. The rest of the body of equality looks like this:

   begin

      if L_Len /= R_Len then
         return False;
      end if;

      for I in 1 .. L_Len loop

         if Get_Item (L_Iter) /= Get_Item (R_Iter) then
            return False;
         end if;

         Advance (L_Iter);
         Advance (R_Iter);

      end loop;

      return True;

   end "=";

We use the iterators to compare the items of each stack in turn. As soon as we get a mismatch, we know that stacks aren't equal, and so we just return. Otherwise, we advance the iterators (move towards the bottom), and then compare the next pair of items. This continues until either a mismatch occurs, or we've compared all the items.

In Out Parameters For Functions

Although Ada doesn't officially have in out parameters for functions, you can still give a function behavior that amounts to the same thing.

One useful thing to be able to do is to modify the item on top of the stack, without actually copying a new item to the top. This doesn't mean replacing the item on the top with another item that has a different value -- it means modifying the actual item, in place.

What we do is to return a reference to the top item. Ada doesn't have reference types like you have in C++, so we use access types instead, which give you the same thing with only a small amount of additional syntactic overhead.

The operation Set_Top is _function_ that allows the client to modify the item on top of the stack, by returning a pointer to the item on top:

   type Item_Access is
      access all Item_Type;

   function Set_Top
     (Stack : Root_Stack)
     return Item_Access is abstract;

You use it as follows:

   Set_Top (Stack).all := ;

or, if the Item_Type is a record:

   Set_Top (Stack). := ;

or, passing it to a modifier:

   Do_Something (To_The_Object => Set_Top (Stack).all);

For example, suppose a stack of integers has the following value (top to bottom):

3 2 1

If I say

  Set_Top (Stack).all := 4;

then the stack now looks like

4 2 1

If we combine the ability to modify an item in place with iterators, it becomes even more powerful, because we can then change any item in the stack, not just the top item. The iterator modifier looks like:

   function Set_Item
     (Iter : Root_Iterator)
     return Item_Access is abstract;

which allows us to change the current item designated by the iterator.

Let's say we want to change our stack above, by adding 1 to every value in the stack. Here's the code:

   declare
      Iter : Root_Iterator'Class := Start_At_Top (S);
   begin
      while not Done (Iter) loop
         Set_Item (Iter).all := Get_Item (Iter) + 1;
         Advance (Iter);
      end loop;

      Print (S);
   end;

So our stack went from the value

4 2 1

to the value

5 3 2

The package System.Address_To_Access_Conversions provides the magic that makes this behavior possible.

The Stack argument of function Set_Top provides only a "constant view" of that object, because its mode is in. However, by using Address_To_Access_Conversions, we can get a "variable view," which will allow us to modify the item. Here's how:

   function Set_Top
     (Stack : Bounded_Stack)
      return Item_Access is

      SA : constant Object_Pointer :=
        To_Pointer (Stack'Address);
...

Address_To_Access_Conversions provides an operation, To_Pointer, which converts an address into an access-to-variable type, Object_Pointer. Now that we have an access-to-variable view of the stack, we can then return a pointer to the top item:

      return SA.Items (Top)'Access;

   end Set_Top;

Taking the address of tagged type is more-or-less well-defined, per RM95 13.3 (16), because a tagged type passed as a subprogram argument provides an "aliased view" of that object. Don't try to use this technique if your type isn't a by-reference type.

The implementation of iterator operation Set_Item is similar, except that you're converting an access-to-constant pointer to an access-to-variable pointer:

   function Set_Item
     (Iter : Stack_Iterator)
      return Item_Access is

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

(These examples of Address_To_Access_Conversions are only needed for the bounded version of the stack; see the file stacks-bounded_g.adb.)

Happy iterating, Matt

P.S. Ada95 Tip O' The Day: Remember, tagged types passed as subprogram arguments are implicitly aliased; that's why you can do this:

  type T is tagged private;

  type Iterator (O : access T) is limited private;


  procedure Op (O : in out T) is

     Iter : Iterator (O'Access);
  begin
     ...

You can't officially do this for non-tagged types, although as we've seen, if you have a pass-by-reference type, you can then safely use System.Address_To_Access_Conversions. (In addition to all tagged types, a limited type whose full view is limited is also passed by reference.)

The sources below are in a format suitable for use with gnatchop.

I recommend you enable assertion checks when building this code. If you're using gnat, use this command:

gnatmake -gnata test_unbounded
gnatmake -gnata test_bounded
gnatmake -gnata test_stacks

I prefer to test for error conditions (such as trying to pop an empty stack) by using pragma Assert. That way, I can turn off assertion checks when I'm satisfied everything's working.


--STX
with Stacks.Bounded_G;

package Integer_Stacks.Bounded is
  new Integer_Stacks.Bounded_G (Size => 5);

with Stacks.Stack_IO_G;

package Integer_Stacks.Stack_IO is
  new Integer_Stacks.Stack_IO_G (Integer'Image);
with Stacks.Unbounded_G;

package Integer_Stacks.Unbounded is
  new Integer_Stacks.Unbounded_G;

with Stacks;

package Integer_Stacks is
  new Stacks (Integer);

with System.Address_To_Access_Conversions;

package body Stacks.Bounded_G is

   package Access_Conversions is
     new System.Address_To_Access_Conversions (Bounded_Stack);

   use Access_Conversions;


   procedure Clear
     (Stack : in out Bounded_Stack) is
   begin
      Stack.Top := 0;
   end Clear;


   procedure Push
     (Item : in     Item_Type;
      On   : in out Bounded_Stack) is

      Top : Natural renames On.Top;

   begin

      pragma Assert (Top < Size);

      Top := Top + 1;

      On.Items (Top) := Item;

   end Push;


   procedure Pop
     (Stack : in out Bounded_Stack) is

      Top : Natural renames Stack.Top;
   begin
      pragma Assert (Top /= 0);
      Top := Top - 1;
   end;


   function Get_Top
     (Stack : Bounded_Stack)
      return Item_Type is

      Top : Natural renames Stack.Top;
   begin
      pragma Assert (Top /= 0);
      return Stack.Items (Top);
   end;


   function Set_Top
     (Stack : Bounded_Stack)
      return Item_Access is

      Top : Natural renames Stack.Top;

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


   function Get_Length
     (Stack : Bounded_Stack)
      return Natural is
   begin
      return Stack.Top;
   end;


   function Is_Full
     (Stack : Bounded_Stack)
      return Boolean is
   begin
      return Stack.Top = Size;
   end;


   function Start_At_Top
     (Stack : Bounded_Stack)
      return Root_Iterator'Class is

      Iter : constant Stack_Iterator :=
        (Stack => Stack'Unchecked_Access,
         Index => Stack.Top);
   begin
      return Iter;
   end;


   function Start_At_Bottom
     (Stack : Bounded_Stack)
      return Root_Iterator'Class is

      Iter : Stack_Iterator :=
        (Stack => Stack'Unchecked_Access,
         Index => 1);
   begin
      return Iter;
   end;


   function Done
     (Iter : Stack_Iterator)
      return Boolean is
   begin
      return
        Iter.Index = 0 or
        Iter.Index > Iter.Stack.Top;
   end;


   function Get_Item
     (Iter : Stack_Iterator)
      return Item_Type is
   begin
      pragma Assert (Iter.Index in 1 .. Iter.Stack.Top);
      return Iter.Stack.Items (Iter.Index);
   end;


   function Set_Item
     (Iter : Stack_Iterator)
      return Item_Access is

      SA : constant Object_Pointer :=
        To_Pointer (Iter.Stack.all'Address);
   begin
      pragma Assert (Iter.Index in 1 .. Iter.Stack.Top);
      return SA.Items (Iter.Index)'Access;
   end;


   procedure Advance
     (Iter : in out Stack_Iterator) is
   begin
      pragma Assert (Iter.Index > 0);
      Iter.Index := Iter.Index - 1;
   end;


   procedure Backup
     (Iter : in out Stack_Iterator) is
   begin
      pragma Assert (Iter.Index <= Iter.Stack.Top);
      Iter.Index := Iter.Index + 1;
   end;


end Stacks.Bounded_G;

generic

   Size : Positive;

package Stacks.Bounded_G is

   pragma Preelaborate;


   type Bounded_Stack is
     new Root_Stack with private;


   procedure Clear
     (Stack : in out Bounded_Stack);

   procedure Push
     (Item : in     Item_Type;
      On   : in out Bounded_Stack);

   procedure Pop
     (Stack : in out Bounded_Stack);


   function Get_Top
     (Stack : Bounded_Stack)
      return Item_Type;

   function Set_Top
     (Stack : Bounded_Stack)
     return Item_Access;

   function Get_Length
     (Stack : Bounded_Stack)
      return Natural;

   function Is_Full
     (Stack : Bounded_Stack)
     return Boolean;


   function Start_At_Top
     (Stack : Bounded_Stack)
      return Root_Iterator'Class;

   function Start_At_Bottom
     (Stack : Bounded_Stack)
      return Root_Iterator'Class;

private

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

   type Bounded_Stack is
     new Root_Stack with record
        Items : Item_Array;
        Top   : Natural := 0;
     end record;


   type Stack_Access is
      access constant Bounded_Stack;

   type Stack_Iterator is
     new Root_Iterator with record
        Stack : Stack_Access;
        Index : Natural;
     end record;


   function Done
     (Iter : Stack_Iterator)
     return Boolean;

   function Get_Item
     (Iter : Stack_Iterator)
      return Item_Type;

   function Set_Item
     (Iter : Stack_Iterator)
      return Item_Access;

   procedure Advance
     (Iter : in out Stack_Iterator);

   procedure Backup
     (Iter : in out Stack_Iterator);


end Stacks.Bounded_G;

with Ada.Text_IO;  use Ada.Text_IO;

package body Stacks.Stack_IO_G is

   procedure Print (Stack : in Root_Stack'Class) is

      Iter : Root_Iterator'Class :=
        Start_At_Top (Stack);

   begin

      if Is_Empty (Stack) then

         Put_Line ("");

         return;

      end if;


      for I in 1 .. Get_Length (Stack) loop

         Put (Image (Get_Item (Iter)));

         Advance (Iter);

      end loop;

      New_Line;

   end Print;


end Stacks.Stack_IO_G;

generic

   with function Image
     (Item : Item_Type) return String;

package Stacks.Stack_IO_G is

   procedure Print (Stack : in Root_Stack'Class);

end Stacks.Stack_IO_G;

with Ada.Unchecked_Deallocation;

package body Stacks.Unbounded_G is

   procedure Finalize
     (Control : in out Stack_Control) is
   begin
      Clear (Control.Stack.all);
   end Finalize;


   procedure Free is
     new Ada.Unchecked_Deallocation (Node, Node_Access);

   procedure Clear
     (Stack : in out Unbounded_Stack) is

      Top  : Node_Access renames Stack.Top;
      Node : Node_Access;
   begin
      for I in 1 .. Get_Length (Stack) loop
         Node := Top;
         Top := Top.Next;

         Free (Node);
      end loop;

      pragma Assert (Stack.Top = null);

      Stack.Bottom := null;
      Stack.Length := 0;
   end Clear;


   procedure Push
     (Item : in     Item_Type;
      On   : in out Unbounded_Stack) is

      Stack : Unbounded_Stack renames On;

      New_Node : constant Node_Access :=
        new Node;

   begin

      New_Node.Item := Item;

      if Stack.Length = 0 then

         Stack.Top := New_Node;

         Stack.Bottom := New_Node;

         Stack.Length := 1;

      else

         New_Node.Next := Stack.Top;
         Stack.Top.Prev := New_Node;

         Stack.Top := New_Node;

         Stack.Length := Stack.Length + 1;

      end if;

   end Push;


   procedure Pop
     (Stack : in out Unbounded_Stack) is

      Node : Node_Access := Stack.Top;

   begin

      pragma Assert (Stack.Length /= 0);

      if Stack.Length = 1 then

         Stack.Top := null;

         Stack.Bottom := null;

         Stack.Length := 0;

      else

         Stack.Top := Stack.Top.Next;
         Stack.Top.Prev := null;

         Stack.Length := Stack.Length - 1;

      end if;

      Free (Node);

   end Pop;



   function Get_Top
     (Stack : Unbounded_Stack)
      return Item_Type is
   begin
      pragma Assert (Stack.Length /= 0);
      return Stack.Top.Item;
   end;


   function Set_Top
     (Stack : Unbounded_Stack)
      return Item_Access is
   begin
      pragma Assert (Stack.Length /= 0);
      return Stack.Top.Item'Access;
   end;



   function Get_Length
     (Stack : Unbounded_Stack)
      return Natural is
   begin
      return Stack.Length;
   end;


   function Start_At_Top
     (Stack : Unbounded_Stack)
      return Root_Iterator'Class is

      Iter : constant Stack_Iterator :=
        (Node => Stack.Top);
   begin
      return Iter;
   end;


   function Start_At_Bottom
     (Stack : Unbounded_Stack)
      return Root_Iterator'Class is

      Iter : Stack_Iterator :=
        (Node => Stack.Bottom);
   begin
      return Iter;
   end;


   function Done
     (Iter : Stack_Iterator)
      return Boolean is
   begin
      return Iter.Node = null;
   end;


   function Get_Item
     (Iter : Stack_Iterator)
      return Item_Type is
   begin
      return Iter.Node.Item;
   end;


   function Set_Item
     (Iter : Stack_Iterator)
      return Item_Access is
   begin
      return Iter.Node.Item'Access;
   end;


   procedure Advance
     (Iter : in out Stack_Iterator) is
   begin
      Iter.Node := Iter.Node.Next;
   end;


   procedure Backup
     (Iter : in out Stack_Iterator) is
   begin
      Iter.Node := Iter.Node.Prev;
   end;


end Stacks.Unbounded_G;

with Ada.Finalization;

generic
package Stacks.Unbounded_G is

   pragma Preelaborate;


   type Unbounded_Stack is
     new Root_Stack with private;


   procedure Clear
     (Stack : in out Unbounded_Stack);

   procedure Push
     (Item : in     Item_Type;
      On   : in out Unbounded_Stack);

   procedure Pop
     (Stack : in out Unbounded_Stack);


   function Get_Top
     (Stack : Unbounded_Stack)
      return Item_Type;

   function Set_Top
     (Stack : Unbounded_Stack)
     return Item_Access;

   function Get_Length
     (Stack : Unbounded_Stack)
      return Natural;


   function Start_At_Top
     (Stack : Unbounded_Stack)
      return Root_Iterator'Class;

   function Start_At_Bottom
     (Stack : Unbounded_Stack)
      return Root_Iterator'Class;

private

   type Node;
   type Node_Access is access Node;

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

   type Stack_Control (Stack : access Unbounded_Stack) is
     new Ada.Finalization.Limited_Controlled with null record;

   procedure Finalize
     (Control : in out Stack_Control);


   type Unbounded_Stack is
     new Root_Stack with record
        Top     : Node_Access;
        Bottom  : Node_Access;
        Length  : Natural := 0;
        Control : Stack_Control (Unbounded_Stack'Access);
     end record;


   type Stack_Iterator is
     new Root_Iterator with record
        Node  : Node_Access;
     end record;


   function Done
     (Iter : Stack_Iterator)
     return Boolean;

   function Get_Item
     (Iter : Stack_Iterator)
      return Item_Type;

   function Set_Item
     (Iter : Stack_Iterator)
      return Item_Access;

   procedure Advance
     (Iter : in out Stack_Iterator);

   procedure Backup
     (Iter : in out Stack_Iterator);


end Stacks.Unbounded_G;

with System; use type System.Address;

package body Stacks is


   procedure Copy
     (From : in     Root_Stack'Class;
      To   : in out Root_Stack) is

      Iter : Root_Iterator'Class :=
        Start_At_Bottom (From);

   begin

      if From'Address = To'Address then
         return;
      end if;

      Clear (Root_Stack'Class (To));

      for I in 1 .. Get_Length (From) loop
         Push (Get_Item (Iter), On => Root_Stack'Class (To));
         Backup (Iter);
      end loop;

   end Copy;


   function "="
     (L : Root_Stack;
      R : Root_Stack'Class)
      return Boolean is

      L_Iter : Root_Iterator'Class :=
        Start_At_Top (Root_Stack'Class (L));

      R_Iter : Root_Iterator'Class :=
        Start_At_Top (R);


      L_Len : constant Natural :=
        Get_Length (Root_Stack'Class (L));

      R_Len : constant Natural :=
        Get_Length (R);

   begin

      if L_Len /= R_Len then
         return False;
      end if;

      for I in 1 .. L_Len loop
         if Get_Item (L_Iter) /= Get_Item (R_Iter) then
            return False;
         end if;

         Advance (L_Iter);
         Advance (R_Iter);
      end loop;

      return True;

   end "=";


   function Is_Empty
     (Stack : Root_Stack) return Boolean is
   begin
      return Get_Length (Root_Stack'Class (Stack)) = 0;
   end;

end Stacks;

generic

   type Item_Type is private;

   with function "="
     (L, R : Item_Type)
     return Boolean is <>;

package Stacks is

   pragma Preelaborate;


   type Root_Stack is
     abstract tagged limited null record;


   procedure Copy
     (From : in     Root_Stack'Class;
      To   : in out Root_Stack);

   procedure Clear
     (Stack : in out Root_Stack) is abstract;

   procedure Push
     (Item : in     Item_Type;
      On   : in out Root_Stack) is abstract;

   procedure Pop
     (Stack : in out Root_Stack) is abstract;


   function "="
     (L : Root_Stack;
      R : Root_Stack'Class)
      return Boolean;

   function Get_Top
     (Stack : Root_Stack)
      return Item_Type is abstract;

   type Item_Access is
      access all Item_Type;

   function Set_Top
     (Stack : Root_Stack)
     return Item_Access is abstract;

   function Get_Length
     (Stack : Root_Stack)
      return Natural is abstract;

   function Is_Empty
     (Stack : Root_Stack)
      return Boolean;


   type Root_Iterator is
     abstract tagged null record;

   function Start_At_Top
     (Stack : Root_Stack)
      return Root_Iterator'Class is abstract;

   function Start_At_Bottom
     (Stack : Root_Stack)
      return Root_Iterator'Class is abstract;

   function Done
     (Iter : Root_Iterator)
     return Boolean is abstract;

   function Get_Item
     (Iter : Root_Iterator)
      return Item_Type is abstract;

   function Set_Item
     (Iter : Root_Iterator)
     return Item_Access is abstract;

   procedure Advance
     (Iter : in out Root_Iterator) is abstract;

   procedure Backup
     (Iter : in out Root_Iterator) is abstract;

end Stacks;

with Integer_Stacks.Bounded;  use Integer_Stacks.Bounded;
with Integer_Stacks.Stack_IO; use Integer_Stacks.Stack_IO;

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Bounded is

   S  : Bounded_Stack;
   S2 : Bounded_Stack;

   use Integer_Stacks;

begin

   Print (S);

   Push (1, S);
   Print (S);

   Pop (S);
   Print (S);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (S = S2));

   Push (1, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Push (2, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Push (3, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Put ("S:");  Print (S);

   Copy (From => S, To => S2);

   Put ("S2:"); Print (S2);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (S = S2));

   Set_Top (S).all := 4;

   Put ("S:"); Print (S);

   declare
      Iter : Root_Iterator'Class := Start_At_Top (S);
   begin
      while not Done (Iter) loop
         Set_Item (Iter).all := Get_Item (Iter) + 1;
         Advance (Iter);
      end loop;

      Put ("S:"); Print (S);
   end;

end Test_Bounded;
with Integer_Stacks.Bounded;   use Integer_Stacks.Bounded;
with Integer_Stacks.Unbounded; use Integer_Stacks.Unbounded;
with Integer_Stacks.Stack_IO;  use Integer_Stacks.Stack_IO;

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Stacks is

   B : Bounded_Stack;
   U : Unbounded_Stack;

begin

   Print (B);

   Push (1, B);
   Print (B);

   Pop (B);
   Print (B);

   Put_Line ("Compare empty B to empty U");

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (B = U));

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (U = B));

   New_Line;
   Put_Line ("Compare non-empty B to empty U");

   Push (1, B);
   Push (2, B);
   Push (3, B);

   Put ("B:"); Print (B);
   Put ("U:"); Print (U);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (B = U));

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (U = B));


   New_Line;
   Put_Line ("Copy B to U");

   Copy (From => B, To => U);

   Put ("U:"); Print (U);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (B = U));

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (U = B));

   New_Line;
   Put_Line ("Copy U to itself");

   Copy (From => U, To => U);
   Put ("U:"); Print (U);


   New_Line;
   Put_Line ("Copy U to B");

   Push (5, U);
   Push (6, U);

   Put ("U:"); Print (U);
   Put ("B:"); Print (B);

   Copy (From => U, To => B);

   Put ("B:"); Print (B);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (B = U));

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (U = B));


   New_Line;
   Put_Line ("Clear U, then copy to B");

   Clear (U);
   Put ("U:"); Print (U);
   Put ("B:"); Print (B);

   Copy (From => U, To => B);

   Put ("B:"); Print (B);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (B = U));

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (U = B));

end Test_Stacks;
with Integer_Stacks.Unbounded;  use Integer_Stacks.Unbounded;
with Integer_Stacks.Stack_IO;   use Integer_Stacks.Stack_IO;

with Ada.Text_IO;  use Ada.Text_IO;

procedure Test_Unbounded is

   S  : Unbounded_Stack;
   S2 : Unbounded_Stack;

   use Integer_Stacks;

begin

   Print (S);

   Push (1, S);
   Print (S);

   Pop (S);
   Print (S);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (S = S2));

   Push (1, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Push (2, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Push (3, S);
   Put ("Len:" & Integer'Image (Get_Length (S)));
   Put ("  Top:" & Integer'Image (Get_Top (S)));
   New_Line;

   Put ("S:");  Print (S);

   Copy (From => S, To => S2);

   Put ("S2:"); Print (S2);

   Put_Line
     ("Stacks are equal: " &
      Boolean'Image (S = S2));

   Set_Top (S).all := 4;

   Put ("S:"); Print (S);

   declare
      Iter : Root_Iterator'Class := Start_At_Top (S);
   begin
      while not Done (Iter) loop
         Set_Item (Iter).all := Get_Item (Iter) + 1;
         Advance (Iter);
      end loop;

      Put ("S:"); Print (S);
   end;

end Test_Unbounded;


(c) 1998-2004 All Rights Reserved David Botton