Heterogeneous, Reference-Counted Lists


A few days ago someone posted to comp.lang.ada asking how to implement a
heterogeneous list of integers, floats, strings, and other lists.

I responded with a simple program implemented using a discriminated
record.  That works, but that implementation is very sensitive to
maintenance changes: add another type, and everyone has to get
recompiled, even if they don't happen to care about the new type.

The linked list shown here uses reference counting for each node.  When
there are no more links to a node, the node is automatically returned to
a storage pool.  Thus, there are no memory leaks.  Cool!

I'm not sure if you're supposed to call this a "pattern" or not, but the
idiom seems interesting enough to warrant pattern status.  So there you
go.

Let me step you through the code.  Package Lists looks like this:

package Lists is

   type List_Type is private;

   Null_List : constant List_Type;

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

It's just your garden-variety linked list ADT, except for one thing:
it's not a generic package.  That's because this is a heterogenous list,
and a constructor for each different kind of type is exported by another
package, Lists.Items, which is generic:

generic
   type Item_Type is private;
package Lists.Items is

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

A client that wants a list of floats and integers would thus instantiate
Lists.Items twice, and then call the constructors for the types:

  List := Cons (6, List);
  List := Cons (3.2, List);
  List := Cons (17, List);
  List := Cons (5.7, List);

which would yield the list (5.7, 17, 3.2, 6).

If he had a sudden desire to put strings in his list too, all he needs
to do make another instantiation (a slight lie: see the code) and
vwah-lah:

  List := Cons ("craziness", List);
  List := Cons ("bad", List);

and so now the list looks like:

  ("bad", "craziness", 5.7, 17, 3.2, 6)

Pretty cool, huh?  But wait!  It slices, and it dices!

This Ronco product can also put lists in the list, by instantiating
List.Items again, on List_Type.  If you create another list:

declare
  Another_List : List_Type;
begin
  Another_List := Cons ("vegas", Another_List);
  Another_List := Cons ("las", Another_List);
  Another_List := Cons ("loathing", Another_List);
  Another_List := Cons ("fear", Another_List);

then you can cons it to your existing list:

   List := Cons (Another_List, List);

So now your list looks like this:

  (("fear","loathing","las","vegas"),"bad","craziness",5.7,17,3.2,6)

which is a list, whose head is a list.

Note that this is a truly heterogeneous list.  The types of the items
that can be placed on the list do not have to be part of a common type
hierarchy.

Alternate formulations, say, for homogeneous lists, or lists of
indefinite items, are possible too.  I'll do those up for my next post.

By now you're probably wondering how you know what you've got in the
list.  For you're viewing pleasure, here are a couple of other functions:

   function Is_Item
     (List : List_Type) return Boolean;

   function Get_Item
     (List : List_Type) return Item_Type;

Is_Item is a selector that allows you to query whether the item at the
head of the list is of a certain type.  So, you might do this:

  if Float_Items.Is_Item (List) then
    

  elsif Integer_Items.Is_Item (List) then
    
  ...

Here's a case where renames would come in handy:

  function Is_Float (List : List_Type) return Boolean renames
     Float_Items.Is_Item;

  function Is_Integer (List : List_Type) return Boolean renames
     Integer_Items.Is_Item;

so that you're case statement above looks like:

  if Is_Float (List) then
...
  elsif Is_Integer (List) then
...


Once you determine that the head item is a float, or integer, or
whatever, then you call the selector Get_Item to access it:

  if Is_Float (Item) then

    declare
       F : constant Float := Get_Item (List);
    begin
     ...


  elsif Is_Integer (Item) then

    declare
       I : constant Integer := Get_Item (List);
    begin
      ...

  elsif Is_String (Item) then

     Put_Line (Get_Item (List));

  ...

Selector Get_Item is thus the equivalent to car in lisp.  Get_Tail is
the equivalent to cdr.

OK, enough about specs.  Type List_Type is a non-limited private type
implemented as a private derivation from Controlled:

private

   type Root_Node_Type;
   type Root_Node_Access is access all Root_Node_Type'Class;

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

Since it's a controlled type, it has two hidden methods, Adjust and
Finalization, that we're going to use to implement our
reference-counting scheme.

When Adjust is called, it's because you've assigned one list object to
another.  Which means you have to increment the reference count, since
the node now has another list pointing to it:

   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;

Finalize is just the opposite.  It gets called when the scope in which a
list object is declared ends, and so it has to decrement the reference
count, because there is now one less list object designating that node:

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

   procedure Finalize (Node : in Root_Node_Access) is
   begin

      if Node = null then
         return;
      end if;

      Node.Count := Node.Count - 1;

      if Node.Count = 0 then

         

      end if;

   end Finalize;


(Finalize is implemented in two parts, because the Next pointer of a
node is an access object, not a list.)

Normally you just decrement the reference count.  But when the count
goes to zero, it means that the last list pointing to that node has
disappeared, and so we need to return the now-unused node to storage.
I'll explain how that happens later.

When you cons an item and a list, you're creating a new list whose head
is the item and whose tail is the list.  You have to do two things:
allocate a new node to store the item, and increment the reference count
of the (head of the) list passed to cons.

So cons basically looks like this:

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

      Result : List_Type;

   begin

      Result.Head := ;

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

      return Result;

   end Cons;

The only other thing to take care of is Get_Tail.  Because it returns a
new list object, it must increment the reference count of the head of
the tail:

   function Get_Tail
     (List : List_Type) return List_Type is

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

      return Tail;
   end Get_Tail;

That's about it for the reference counting scheme.  Let's say a few
words about the node type, which will allow us to segue into our
discussion of memory management.

The actual node type is an abstract tagged record:

   type Root_Node_Type is
     abstract tagged record
        Count : Natural;
        Next  : Root_Node_Access;
     end record;

Count is what we use to keep track of how many references there are to a
node, and Next just implements the link to the rest of the list.

Note carefully the original partial declaration:

   type Root_Node_Type;
   type Root_Node_Access is access all Root_Node_Type'Class;

Notice how access type Root_Node_Access points to the class-wide type,
Root_Node_Type'Class.  You're allowed to do this even though there's
nothing in the partial declaration that tells you Root_Node_Type is
tagged.

The items in a list have to get stored somewhere.  So where are the
items?

Every time you instantiate generic package Lists.Items, you create a new
node type that derives from Root_Node.  It extends the root type with a
record component to hold an object of the item type:

   type Item_Node is
     new Root_Node_Type with record
        Item : Item_Type;
     end record;

When Cons allocates a new node, it allocates an Item_Node for the head
of the new list, and stores the item in that new node.

The linked list is thus implemented as a chain of nodes of different
types, a different node type for each kind of item you put on the list.
That's why the Next component of Node is an access object that
designates Root_Node_Type'Class, so it can point to any kind of node.

The memory management scheme we use here is very similar to the one we
used back in the implementation of the Interpreter pattern.  Each
instantiation of Lists.Items creates a free list of Item_Nodes, from
which we draw new nodes during a Cons, and to which we return nodes that
have been Finalize'd.

The interesting thing is how you return the node to its own storage
pool, since it is designated by an access object (Next) that points to
class-wide objects (Root_Node_Type'Class).  How does Next know to which
pool to return the node?

This is where the magic of dynamic dispatching comes in.  Node types
have a primitive operation for reclaiming storage:

   type Root_Node_Type is
     abstract tagged record ...;

   procedure Free (Node : access Root_Node_Type) is abstract;

When you're done with a node (meaning that the count of references to
that node has gone to zero), you call Free, which dispatches according
to the tag of the node.

Free is implemented by inserting the node at the front of the local free
list:


   Free_List : Root_Node_Access;
...
   procedure Free (Node : access Item_Node) is
   begin

      Node.Next := Free_List;
      Free_List := Root_Node_Access (Node);

   end Free;


Note that even though Free_List has type Root_Node_Access (which can in
theory point to any kind of node), all the nodes in that list have the
same specific type.

Free gets called during the finalization of a list object, when the
reference count is zero:

   procedure Finalize (Node : in Root_Node_Access) is
   begin
      ...

      if Node.Count = 0 then

         Finalize (Node.Next);

         Node.Next := null;

         Free (Node);

      end if;

   end Finalize;


When you finalize a node, you have to decrement the reference count of
the node it points to (by calling Finalize, on Node.Next), and then Free
the node.  This returns the node to its own storage pool, in the
(instantiation of the) package where the specific node type was declared.

Finalizing a list object can set off a chain reaction of recursive
calls, as each node whose reference count drops to zero finalizes the
next node, which causes finalization of the next node, and so on.  The
recursion terminates when you hit a node with more than one reference,
or fall off the end of the list.

Happy linking,
Matt

P.S. You were waiting for this, right?  It's time once again for
Matt's Ada95 Tip O' The Day!

Have you ever made a type-cast on the left-hand side of an assignment
statement?  Jamais?  Quelle Horreur!

In the implementation of Cons, you'll find this assignment:

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

which has a type-cast on the left-hand side.

Wow.  Yeah, like, way cool dude.  Oh, I can hear it now!  Oohs and aahs
and gasps for breath by members of today's studio audience!

So you pull a new node off the free list, and you know that the node is
of type Item_Node, because that's the only kind of node in the free
list.  But Free_List and List.Head point to Root_Node_Type'Class, which
isn't the node type we want, and is abstract anyway.

So what do you do?  How do you get at an object whose type is
non-abstract and specific, if it's designated by a pointer to a type
that is abstract and class-wide?

Have no fear, my son.  Just cast the object from the class-wide type,
Root_Node_Type'Class, to the specific type, Item_Node.

Huh?  Technically, this isn't a "type cast," it's a "view conversion,"
because it just converts between views of an object.  The type of the
object doesn't actually change: once you're born as an Item_Node, you
always stay an Item_Node.

Note that this particular view conversion is a down-cast, because you're
going from a view of the parent type to a view of the derived type.  A
tag check is thusly involved, but you can suppress it easily enough.

So there you are.  Now go out and impress your friends and relatives
with your newfound Ada95 prowess.  You handsome devil!

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

--STX
with Ada.Finalization;
package Lists is

   type List_Type is tagged private;
   --
   -- This type should be
   --
   --    type List_Type is private;
   --
   -- but my buggy compiler, GNAT 3.10p, refuses to call Adjust and
   -- Finalize when List_Type is a generic actual parameter.  If you're
   -- using a different compiler, then remove the keyword "tagged" in the
   -- declaration above.


   Null_List : constant List_Type;

   function Get_Tail
     (List : List_Type) return List_Type;

   function Get_Image
     (List : List_Type) return String;

private

   type Root_Node_Type;
   type Root_Node_Access is access all Root_Node_Type'Class;

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

   use Ada.Finalization;

   procedure Adjust (List : in out List_Type);

   procedure Finalize (List : in out List_Type);

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


   type Root_Node_Type is
     abstract tagged record
        Count : Natural;
        Next  : Root_Node_Access;
     end record;

   function Get_Image
     (Node : access Root_Node_Type) return String is abstract;

   procedure Free (Node : access Root_Node_Type) is abstract;

end Lists;



package body Lists is

   function Get_Tail
     (List : List_Type) return List_Type is

      Tail : constant List_Type :=
        List_Type'(Controlled with Head => List.Head.Next);
   begin
      if Tail.Head /= null then
         Tail.Head.Count := Tail.Head.Count + 1;
      end if;

      return Tail;
   end Get_Tail;


   function Get_Image (List : List_Type) return String is

      function Get_Image_Internal
        (Node : Root_Node_Access) return String is
      begin
         if Node = null then
            return "";
         else
            return
              " " &
              Get_Image (Node) &
              Get_Image_Internal (Node.Next);
         end if;
      end;

   begin

      if List = Null_List then
         return "()";
      else
         return
           "(" &
           Get_Image (List.Head) &
           Get_Image_Internal (List.Head.Next) &
           ")";
      end if;

   end Get_Image;


   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 (Node : in Root_Node_Access) is
   begin

      if Node = null then
         return;
      end if;

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

      Node.Count := Node.Count - 1;

      if Node.Count = 0 then
         Finalize (Node.Next);
         Node.Next := null;
         Free (Node);
      end if;

   end Finalize;


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

end Lists;


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

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

   function Is_Item
     (List : List_Type) return Boolean;

   function Get_Item
     (List : List_Type) return Item_Type;

private

   type Item_Node is
     new Root_Node_Type with record
        Item : Item_Type;
     end record;

   function Get_Image
     (Node : access Item_Node) return String;

   procedure Free (Node : access Item_Node);

end Lists.Items;


package body Lists.Items is

   Free_List : Root_Node_Access;


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

      Result : List_Type;

   begin

      if Free_List = null then

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

      else

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

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

      end if;

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

      return Result;

   end Cons;


   function Is_Item
     (List : List_Type) return Boolean is
   begin
      return List /= Null_List and then List.Head.all in Item_Node;
   end;


   function Get_Item
     (List : List_Type) return Item_Type is
   begin
      return Item_Node (List.Head.all).Item;
   end;


   function Get_Image
     (Node : access Item_Node) return String is

      Count_Image : constant String :=
        Integer'Image (Node.Count);
   begin
      return
        Get_Image (Node.Item) &
        "(" &
        Count_Image (2 .. Count_Image'Last) &
        ")";
   end Get_Image;


   procedure Free (Node : access Item_Node) is
   begin

      pragma Assert (Node.Count = 0);
      pragma Assert (Node.Next = null);

      Node.Next := Free_List;
      Free_List := Root_Node_Access (Node);

   end Free;

end Lists.Items;


with Lists.Items;
package Lists.Float_Items is
   new Lists.Items (Float, Float'Image);


with Lists.Items;
package Lists.Integer_Items is
   new Lists.Items (Integer, Integer'Image);


package Lists.String_Items is

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

   function Is_String
     (List : List_Type) return Boolean;

   function Get_String
     (List : List_Type) return String;

end Lists.String_Items;


with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Lists.Items;
package body Lists.String_Items is

   package Unbounded_String_Items is
     new Lists.Items (Unbounded_String, To_String);
   use Unbounded_String_Items;

   function Cons
     (Item : String;
      List : List_Type) return List_Type is
   begin
      return Cons (To_Unbounded_String (Item), List);
   end;

   function Is_String
     (List : List_Type) return Boolean is
   begin
      return Is_Item (List);
   end;

   function Get_String
     (List : List_Type) return String is
   begin
      return To_String (Get_Item (List));
   end;

end Lists.String_Items;


with Lists.Items;
package Lists.List_Items is
   new Lists.Items (List_Type);


with Lists;               use Lists;
with Lists.Float_Items;   use Lists.Float_Items;
with Lists.Integer_Items; use Lists.Integer_Items;
with Lists.String_Items;  use Lists.String_Items;
with Lists.List_Items;    use Lists.List_Items;
with Ada.Text_IO;         use Ada.Text_IO;
with Ada.Float_Text_IO;   use Ada.Float_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 (5.0, List);
   Put_Line (Get_Image (List));
   New_Line;

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

   declare
      Temp : constant List_Type :=
        Cons ("another", Cons ("brick", 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;

   List := Cons ("wall", List);
   Put_Line (Get_Image (List));
   New_Line;

   declare
      Temp : constant List_Type :=
        Cons (99, Cons ("nuef", Cons ("ballons", 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;

end Test_Lists;

Contributed by: Matthew Heaney
Contributed on: February 25, 1999
License: Public Domain
Back