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;
|
