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
Homogeneous, Reference-Counted Lists (Matthew Heaney)

Introduction

Here's an example of the canonical form of linked list, in which all the
items have the same type, and each node is automatically returned to
storage via a reference-counting scheme.

If you could get through the brain teaser that was my last post
(heterogeneous lists), then this one will be a breeze.

I also briefly explore list iteration issues, including a discussion of
how to visit list items in reverse order.


Discussion

The fact that the items are homogeneous allows us to implement the list
using traditional techniques: as an abstract data type exported by a
generic package, which imports the item type as a generic formal
parameter.

Here's the elided spec:


generic
   type Item_Type is private;
package Lists is

   type List_Type is private;

   Null_List : constant List_Type;

   function Cons (Item : Item_Type;
                  List : List_Type) return List_Type;

   function Get_Head (List : List_Type) return Item_Type;

   function Get_Tail (List : List_Type) return List_Type;
...
end Lists;


Cons is the operation by which all lists are ultimately constructed.
Since this is a homogeneous list, we can declare Cons right there in the
Lists package.

Selector Get_Head and constructor Get_Tail are operations that undo the
effect of Cons.  Get_Head is returns the item at the head of the list,
and Get_Tail is returns the list that follows the head.

A aside about operation names: the concatenation operator might be a
better choice than "Cons", since it would allow us to write expressions
like:

  List := 6 & List;

instead of

  List := Cons (6, List);

I chose Cons partly because it's short, but mostly because lately I've
been writing tools for navigation of Ada source using Emacs Lisp.  I've
got lists on the brain these days.

The names "get"_head and "get"_tail were chosen to work around certain
name-space issues in Ada.  In a declaration, the object and the type
share a name-space, which requires that they have different names.

If the operation were named just

  function Head (List : List_Type) return Item_Type;

then the declaration

  declare
     Head : constant Item_Type := Head (List);
  begin

would be illegal.  Ditto for this:

  declare
     Tail : constant List_Type := Tail (List);
  begin

As a writer of a reusable module, I want to put as few constraints on
its use as possible.  As a writer of a list abstraction, I don't want to
restrict a client's ability to use Head and Tail as names of objects.
Which means I have to come up with a different name for those
operations.

In the software community we generally refer to modifiers and selectors
as "set and get operations."  Since the operations for retrieving the
head or tail of a list have the sense of a query, the names Get_Head and
Get_Tail seemed like the natural choice.

OK, back to our discussion.  Another useful operation is to change the
value of the item at the head of the list:

   procedure Set_Head (List : in List_Type;
                       Item : in Item_Type);

Set_Head and Get_Head are therefore symmetrical operations.

The operation

   procedure Set_Tail (List : in List_Type;
                       Tail : in List_Type);

is analogous to Set_Head.


That covers the interesting public operations.  Let's move on now to the
implementation issues.

We're going to use reference-counting to keep track of how many
references there are to each node.  When the count goes to zero, that
means there are no more references to that node, and we can safely
return the node to storage.  This eliminates memory leaks.

A node in the list looks like this:

   type Node_Type;
   type Node_Access is access all Node_Type;

   type Node_Type is
      record
         Item  : Item_Type;
         Count : Natural;
         Next  : Node_Access;
      end record;

The component Count is the reference count, and Next is the pointer
which links one node in the list to the next node.  Note that here
Node_Type is just a simple record type.  It doesn't need to be tagged,
because all nodes in a homogeneous list are identical.

List_Type is implemented as a private derivation of Controlled,
extending that type with a pointer to a node:

   type List_Type is
     new Ada.Finalization.Controlled with record
        Head : Node_Access;
     end record;

Note that the tagged-ness of List_Type isn't stated in the public view
of the type:

  type List_Type is private;

because it's being used here strictly as an implementation technique.

Automatic incrementing and decrementing of reference counts is effected
by overriding Controlled operations Adjust and Finalize.

A controlled object gets adjusted during an assignment, immediately
after making a bit-wise copy from the value on the right hand side to
the object on the left hand side.

When we assign one list object to another, we have to increment the
reference count, because there is now one more object referring to that
node:

   procedure Adjust (List : in out List_Type) is
   begin
      if List.Head /= null then
         List.Head.Count := List.Head.Count + 1;
      end if;
   end Adjust;

A controlled object gets finalized immediately prior to the bit-wise
copy, and when the scope in which the object is declared ends.  When a
list object is finalized, it means there is one less list object
pointing to that node, so you have to decrement the reference count:

   procedure Finalize (Node : Node_Access) is
   begin

      if Node = null then
         return;
      end if;

      Node.Count := Node.Count - 1;

      if Node.Count = 0 then

         Finalize (Node.Next);

         

      end if;

   end Finalize;


As I mentioned in my previous post, finalization of one node can cause a
chain reaction of node finalizations to occur.  When the reference count
for a node drops to zero, you have to return the node to storage.  That
means there's one less reference to the next node, so that next node
needs to have its reference count decremented.  But if its count goes to
zero, then you have to finalize its next node, and so on.

The recursion terminates when you decrement a node whose reference count
is greater than one, or you fall off the end of the list (because the
reference counts of all the nodes in the list were one).

In this example, the storage pool is implemented as a simple list of
unused nodes.  "Return the node to storage" just means inserting it at
the head of the free list:

      Node.Next := Free_List;
      Free_List := Node;

Other schemes are possible, such as using Unchecked_Deallocation to
return the memory to heap.

While Finalize puts nodes on the Free_List, Cons takes nodes off.  If
the Free_List is empty, Cons will allocate a fresh node from the heap;
otherwise, it will just remove a node from the Free_List:

     if Free_List = null then

        Head := ;

     else

        Head := Free_List;
        Free_List := Free_List.Next;

        ;

     end if;
     ...
   end Cons;


The implementation of other List_Type operations is straightforward.
Most of the operations were described in my last post (on heterogeneous
lists) anyway, so I won't repeat that information here.

An aside on exception handling: I haven't bothered to do any manual
error checking, mostly because it would duplicate the checks that are
already being performed automatically by Ada.  For example, if you try to
get the head of a null list:

   function Get_Head (List : List_Type) return Item_Type is
   begin
      return List.Head.Item;
   end;

then Ada will raise Constraint_Error, because you're trying to
dereference a null pointer.  How much more checking do you really need
to do?

My personal philosophy is to let the language do as much work for me as
possible.  The only time I explicitly check for a precondition violation
is if there's no convenient way to let the language do the check, and
only then if the violation would corrupt the state of the abstraction.

However, this behavior should of course be documented.  The interesting
pre- and post-conditions of each operation should be stated explicitly,
as well as the exception behavior.  Something like:

  function Get_Head (List : List_Type) return Item_Type;
  --
  -- Preconditions:
  --   List /= Null_List
  --
  -- Exceptions:
  --   Constraint_Error, when the precondition isn't satisfied


My other reason for not explicitly performing a check (or internally
handling the predefined exception, and then propagating another) is for
reasons of efficiency.  A client who obeys the pre-conditions shouldn't
have to pay any run-time penalty for others' bad behavior.

This has practical consequences, because any potential client of a
reusable component who perceives that the component isn't as efficient
as it could be isn't going to use it.  He'll just write his own, more
efficient version from scratch.

So give the people what they want.

A compromise position is to use pragma Assert to check preconditions,
something like:

   function Get_Head (List : List_Type) return Item_Type is
   begin
      pragma Assert (List.Head /= null,
                     "trying to get head of empty list");
      return List.Head.Item;
   end;

The benefit of this approach is that there should be a compiler switch
you can use to turn the assertion checks on or off (the switch for gnat
is called "-gnata").  You can enable the checks during initial
development, then later disable them when you're satisfied everyone's
being good.

The other benefit of using pragma Assert is that if the assertion check
does fail, then (depending on how good your compiler is) you'll get an
error message with very specific debugging information, such as name of
the module in which the error occurred, and on what line.


Iteration

There are two techniques for iteration, "active" vs "passive", which I
discussed in one of my previous posts.  A list is interesting because it
is its own active iterator; no separate iterator type is necessary for
list traversal.

You'd typically structure active iteration over a list as follows:

  declare
    Index : List_Type := List;
  begin
    while Index /= Null_List loop
       ... Get_Head (Index) ...
       Index := Get_Tail (Index);
    end loop;
  end;


This is fine, although somewhat error prone, because you can forget to
advance the index (a mistake I often make), or worse, forget to declare
an index and just use the list:

  while List /= Null_List loop
     ... Get_Head (List) ...
     List := Get_Tail (List);
  end loop;

This destroys the list (gulp!), which may not be the, um, desired
behavior.  This of course has never happened to anyone you know.  Ahem.

An alternate approach is to use a passive iterator, which is more or
less bullet-proof, because it hides all the index manipulation.  It may
also be more efficient.  Here's why.

Because the list object is controlled, adjustment and finalization occur
every time an assignment occurs.  This can happen like crazy if lots of
temporaries are created.  In the example above, all this activity
happens every pass through the loop.

A passive iterator may be more efficient because it traverses the list
using the underlying access objects instead of list objects, thus
avoiding the overhead associated with controlled assignment.

The implementation of a passive iterator for forward iteration looks
just like the active iteration we showed above:

   procedure Iterate_Forward (List : in List_Type) is

      Done : Boolean := False;
      Node : Node_Access := List.Head;
   begin
      while Node /= null loop
         Process (Node.Item, Done);
         exit when Done;
         Node := Node.Next;
      end loop;
   end Iterate_Forward;

The only difference is that we have to check a Done flag, to see if the
client wants to terminate the iteration.  (You need this to implement
efficient search schemes and the like.)

There's also a passive iterator for backwards traversal.  Huh?  Over a
singly-linked list?

Recursion is your friend.  What we do is use a little helper routine to
recursively traverse all the nodes in the list.  When we fall off the
end, the recursion terminates, and we process the item at each node
(from foot to head) as we unwind the stack:

   procedure Iterate_Backward (List : in List_Type) is

      Done : Boolean := False;

      procedure Visit (Node : in Node_Access) is
      begin
         if Node /= null then
            Visit (Node.Next);

            if not Done then
               Process (Node.Item, Done);
            end if;
         end if;
      end Visit;

   begin

      Visit (List.Head);

   end Iterate_Backward;


Obviously, this isn't the most efficient mechanism for traversing a
linked list in foot-to-head order, and if you're serious about backwards
iteration, then you should probably be using a doubly-linked list.  But
it'll do in a pinch, eh?

Matt


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


--STX
with Ada.Finalization;

generic
   type Item_Type is private;
   with function Get_Image (Item : Item_Type) return String is <>;
package Lists is

   type List_Type is private;

   Null_List : constant List_Type;

   function Get_Head (List : List_Type) return Item_Type;

   procedure Set_Head (List : in List_Type;
                       Item : in Item_Type);

   function Get_Tail (List : List_Type) return List_Type;

   procedure Set_Tail (List : in List_Type;
                       Tail : in List_Type);

   function Cons (Item : Item_Type;
                  List : List_Type) return List_Type;

   type Item_Array is
      array (Positive range <>) of Item_Type;

   function To_List (Item : Item_Type) return List_Type;

   function To_List (Items : Item_Array) return List_Type;

   function Get_Image (List : List_Type) return String;

   generic
      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);
   procedure Iterate_Forward (List : in List_Type);

   generic
      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);
   procedure Iterate_Backward (List : in List_Type);


private

   type Node_Type;
   type Node_Access is access all Node_Type;

   type Node_Type is
      record
         Item  : Item_Type;
         Count : Natural;
         Next  : Node_Access;
      end record;

   type List_Type is
     new Ada.Finalization.Controlled with record
        Head : Node_Access;
     end record;

   procedure Adjust (List : in out List_Type);

   procedure Finalize (List : in out List_Type);

   use Ada.Finalization;

   Null_List : constant List_Type :=
     (Controlled with Head => null);

end Lists;


package body Lists is

   Free_List : Node_Access;

   procedure Finalize (Node : Node_Access);


   function Get_Head (List : List_Type) return Item_Type is
   begin
      return List.Head.Item;
   end;

   procedure Set_Head (List : in List_Type;
                       Item : in Item_Type) is
   begin
      List.Head.Item := Item;
   end;


   function Get_Tail (List : List_Type) return List_Type is

      Tail : constant Node_Access := List.Head.Next;
   begin
      if Tail /= null then
         Tail.Count := Tail.Count + 1;
      end if;

      return List_Type'(Controlled with Head => Tail);
   end Get_Tail;



   procedure Set_Tail (List : in List_Type;
                       Tail : in List_Type) is
   begin

      Finalize (List.Head.Next);
      List.Head.Next := Tail.Head;

      if Tail.Head /= null then
         Tail.Head.Count := Tail.Head.Count + 1;
      end if;

   end Set_Tail;



   function Cons (Item : Item_Type;
                  List : List_Type) return List_Type is

      Head : Node_Access;

   begin

      if Free_List = null then

         Head := new Node_Type'(Count => 1,
                                Next  => List.Head,
                                Item  => Item);

      else

         Head := Free_List;
         Free_List := Free_List.Next;

         Head.all := Node_Type'(Count => 1,
                                Next  => List.Head,
                                Item  => Item);

      end if;

      if List.Head /= null then
         List.Head.Count := List.Head.Count + 1;
      end if;

      return List_Type'(Controlled with Head);

   end Cons;


   function To_List (Item : Item_Type) return List_Type is
   begin
      return Cons (Item, Null_List);
   end;


   function To_List (Items : Item_Array) return List_Type is

      List : List_Type;

   begin

      for I in reverse Items'Range loop
         List := Cons (Items (I), List);
      end loop;

      return List;

   end To_List;



   function Get_Image (List : List_Type) return String is

      function Count_Image (Count : Natural) return String is
         Image : constant String := Integer'Image (Count);
      begin
         return "(" & Image (2 .. Image'Last) & ")";
      end;

      function Get_Image (Node : Node_Access) return String is
      begin
         if Node = null then
            return "";
         else
            return
              " " &
              Get_Image (Node.Item) &
              Count_Image (Node.Count) &
              Get_Image (Node.Next);
         end if;
      end Get_Image;

   begin

      if List.Head = null then
         return "()";
      else
         return
           "(" &
           Get_Image (List.Head.Item) &
           Count_Image (List.Head.Count) &
           Get_Image (List.Head.Next) &
           ")";
      end if;

   end Get_Image;


   procedure Iterate_Forward (List : in List_Type) is

      Done : Boolean := False;
      Node : Node_Access := List.Head;
   begin
      while Node /= null loop
         Process (Node.Item, Done);
         exit when Done;
         Node := Node.Next;
      end loop;
   end Iterate_Forward;


   procedure Iterate_Backward (List : in List_Type) is

      Done : Boolean := False;

      procedure Visit (Node : in Node_Access) is
      begin
         if Node /= null then
            Visit (Node.Next);

            if not Done then
               Process (Node.Item, Done);
            end if;
         end if;
      end Visit;

   begin

      Visit (List.Head);

   end Iterate_Backward;



   procedure Adjust (List : in out List_Type) is
   begin
      if List.Head /= null then
         List.Head.Count := List.Head.Count + 1;
      end if;
   end Adjust;



   procedure Finalize (List : in out List_Type) is
   begin
      Finalize (List.Head);
   end;



   procedure Finalize (Node : Node_Access) is
   begin

      if Node = null then
         return;
      end if;

      pragma Assert (Node.Count > 0,
                     "finalizing node with ref count = 0");

      Node.Count := Node.Count - 1;

      if Node.Count = 0 then

         Finalize (Node.Next);

         Node.Next := Free_List;
         Free_List := Node;

      end if;

   end Finalize;


end Lists;


with Lists;

package Integer_Lists is
  new Lists (Integer, Get_Image => Integer'Image);


with Integer_Lists; use Integer_Lists;

with Ada.Text_IO;         use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;

procedure Test_Lists is

   List : List_Type;

   L1, L2 : List_Type;

begin

   Put_Line (Get_Image (List));
   New_Line;

   List := Cons (6, List);
   Put_Line (Get_Image (List));
   New_Line;

--    declare
--       Temp : constant List_Type :=
--         Cons (57, Cons (58, Null_List));
--    begin
--       Put_Line (Get_Image (Temp));
--       List := Cons (Temp, List);
--       Put ("head: "); Put_Line (Get_Image (List_Type'(Get_Item (List))));
--       Put ("tail: "); Put_Line (Get_Image (Get_Tail (List)));
--       Put_Line (Get_Image (List));
--       New_Line;
--    end;

   List := Cons (2, List);
   Put_Line (Get_Image (List));
   L1 := List;
   Put_Line (Get_Image (List));
   L2 := List;
   Put_Line (Get_Image (List));
   L1 := Null_List;
   Put_Line (Get_Image (List));
   L1 := Get_Tail (List);
   Put_Line (Get_Image (List));
   L2 := Null_List;
   Put_Line (Get_Image (List));
   L2 := L1;
   Put_Line (Get_Image (List));
   New_Line;


--    declare
--       Temp : constant List_Type :=
--         Cons (99, Cons (98, Cons (97, Null_List)));
--    begin
--       Put_Line (Get_Image (Temp));
--       List := Cons (Temp, List);
--       Put_Line (Get_Image (List));
--    end;

   Put_Line (Get_Image (List));
   New_Line;

   L1 := Null_List;
   Put_Line (Get_Image (List));
   New_Line;

   L2 := Null_List;
   Put_Line (Get_Image (List));
   New_Line;

   while List /= Null_List loop

      List := Get_Tail (List);
      Put_Line (Get_Image (List));
      New_Line;

   end loop;

   List := To_List (Items => (1, 2, 3, 4, 5, 6, 7, 8, 9));
   Put_Line (Get_Image (List));
   New_Line;

   declare
      Index : List_Type := List;
   begin
      while Index /= Null_List loop
         Put (Integer'Image (Get_Head (Index)));
--       Put ("  ");  Put_Line (Get_Image (List));
         Index := Get_Tail (Index);
      end loop;
      New_Line;
   end;

   declare
      procedure Put_Item
        (Item : in out Integer;
         Done : in out Boolean) is
      begin
         Put (Integer'Image (Item));
      end;

      procedure Put_Items is
        new Iterate_Forward (Put_Item);
   begin
      Put_Items (List);
      New_Line;
   end;

   declare
      procedure Put_Item
        (Item : in out Integer;
         Done : in out Boolean) is
      begin
         Put (Integer'Image (Item));
      end;

      procedure Put_Items is
        new Iterate_Backward (Put_Item);
   begin
      Put_Items (List);
      New_Line;
   end;

   New_Line (2);

   L1 := To_List ((10, 20, 30, 40, 50));

   Put_Line (Get_Image (List));
   Put_Line (Get_Image (L1));
   New_Line;
   Set_Tail (List, L1);
   Put_Line (Get_Image (List));
   Put_Line (Get_Image (L1));
   New_Line;
   Set_Tail (List, Null_List);
   Put_Line (Get_Image (List));
   Put_Line (Get_Image (L1));
   New_Line (2);

end Test_Lists;


(c) 1998-2004 All Rights Reserved David Botton