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
State Pattern, Implemented As A Look-Up Table (Matthew Heaney)

This is an alternate implementation of the State pattern that uses a
look-up table to map states to procedures.

The implementation in the GoF book mapped the action associated with an
event to a primitive operation of a type, with a derivation for each
different state.

States were represented by declaring a singleton instance of every type
in the derivation class.  A state change was effected by designating a
state object with different type.

This is a rather heavy solution to a relatively simple problem.  But as
I have pointed out in other articles, many of the examples in the GoF
book --even the C++ examples-- have a very Smalltalk flavor, and this is
indeed the case here.

The type-based solution in the book was probably influenced by the fact
that you don't have free subprograms in Smalltalk.  You have to
implement the subprogram as a method in a class, and invoke it by
sending a message to a stateless object.

This seems like a roundabout way to implement what is essentially just
table look-up.  Why not declare the table directly?  That is what we do
here.  Instead using a derivation class, we represent state as a
discrete type and use values of the type to index into an array of
procedure pointers.

Implementation

In a naive implementation, the state type would be declared as an
enumeration type, like this:

     type State_Type is (Established, Listen, Closed, ...);

The problem is that there's no way to add new states without modifying
the type and recompiling the spec of TCP.States.  This will necessitate
recompilation of all of its children and all of the clients of package
TCP.Connections.

The dependency of Connection_Type on State_Type thus makes the system
very sensitive to changes in that type, which can trigger a potentially
massive recompilation.  This is not acceptable for large applications.

We must to find a way to implement State_Type so that adding states has
little or no compilation penalty.

The solution is to represent the state as an integer type with a wide
range:

     type State_Type is new Integer;

Each state is assigned a unique id.  To add a new state, you just map it
to a value not already assigned to an existing state.

In order to keep track of the assignment of states to values, we
document the mapping using an ordinary text file:

  (start of file tcp-states.txt)
  1 listen
  2 closed
  3 established
  4 <unassigned>
  5 <unassigned>

  The maximum value assigned in this file cannot exceed the Max_State
  value in the body of package tcp-states.

  If you need to add more states, then adjust the Max_State value in
  body of tcp-states, recompile the body, and then relink your
  executable.  (end of file tcp-states.txt)


When a developer needs to create a new state, she simply checks the file
out of the CM library, claims a number for the state, and then checks
the file back in.  No source code changes are required.

The look-up tables, declared in the body of package TCP.States, are
implemented as arrays indexed by state.  Each table contains slots for
the values actually assigned to states.

There are a few extra slots too for unassigned values, so you don't have
to modify the table size every time you add a new state.

If you do have to adjust the table size (because all the slots have been
allocated to states), the compilation penalty is minimal, because the
tables are local to the body of the package.

The tables contain pointers to procedures.  There is a separate
procedure access type and a separate table for each kind of action:

  package TCP.States is
     ...

     type Transmit_Access is
        access procedure (Connection : in out Root_Connection_Type'Class;
                          Item       : in     Stream_Element_Array);

     ...

     type Active_Open_Access is
        access procedure (Connection : in out Root_Connection_Type'Class);

     ...
  end TCP.States;


  package body TCP.States is
     ...

     type Transmit_Array_Type is
        array (State_Range) of Transmit_Access;

     Transmit_Array : Transmit_Array_Type :=
       (others => Default_Transmit'Access);

     ...

     type Active_Open_Array_Type is
        array (State_Range) of Active_Open_Access;


     Active_Open_Array : Active_Open_Array_Type :=
       (others => Default_Active_Open'Access);

     ...
  end TCP.States;


The tables are in the body, so we need to provide a selector that
returns the action procedure corresponding to a state:

   function Transmit
     (State : State_Type) return Transmit_Access is
   begin
      return Transmit_Array (State);
   end;

   function Active_Open
     (State : State_Type) return Active_Open_Access is
   begin
      return Active_Open_Array (State);
   end;


To implement the Connection_Type operations, first we get the procedure
mapped to the current state, and then we call the procedure:

  package body TCP.Connections is

    procedure Active_Open
      (Connection : in out Connection_Type) is
    begin
       Active_Open (Connection.State) (Connection);
    end;

    ...

    procedure Send
      (Connection : in out Connection_Type) is
    begin
       Send (Connection.State) (Connection);
    end;

  end TCP.Connections;


Note that we've combined these two steps (the query and the call) into
one statement.

There's also a modifier operation to set the value of the action
procedure for a state.  We declare these operations in the private
region of the TCP.States spec, so they can only be called its children:

  package TCP.States is

    ...

  private

    procedure Set_Transmit
      (State    : in State_Type;
       Transmit : in Transmit_Access);

    procedure Set_Active_Open
      (State       : in State_Type;
       Active_Open : in Active_Open_Access);

    ...

  end TCP.States;


These operations are implemented in the obvious way, by assigning the
procedure pointer to the indicated slot in the table:

   procedure Set_Transmit
     (State    : in State_Type;
      Transmit : in Transmit_Access) is
   begin
      Transmit_Array (State) := Transmit;
   end;

   procedure Set_Active_Open
     (State       : in State_Type;
      Active_Open : in Active_Open_Access) is
   begin
      Active_Open_Array (State) := Active_Open;
   end;


For each state there's a child package, containing the implementation of
the action procedures for that state.  All the spec needs to export is
the State_Type value assigned to that state:

  package TCP.States.Listen is

     pragma Elaborate_Body;

     State : constant State_Type := 1;

  end TCP.States.Listen;


  package TCP.States.Established is

     pragma Elaborate_Body;

     State : constant State_Type := 3;

  end TCP.States.Established;


Other state packages use the state value as the target of a transition
to a new state:

  with TCP.States.Established;
  package body TCP.States.Closed is
     ...
     Set_State (Connection, Established.State);


The Elaborate_Body pragma is necessary (not just desired) because
there's nothing in the spec that requires a body.

During its elaboration, the child package sets the values of the action
procedures for that state:

  package body TCP.States.Established is

     procedure Transmit
       (Connection : in out Root_Connection_Type'Class;
        Item       : in     Stream_Element_Array) is
     begin
        Process_Stream (Connection, Item);
     end;


     procedure Close
       (Connection : in out Root_Connection_Type'Class) is
     begin
        -- send FIN, receive ACK of FIN

        Set_State (Connection, Listen.State);
     end Close;

  begin

     Set_Transmit (State, Transmit'Access);  <--

     Set_Close (State, Close'Access);        <--

  end TCP.States.Established;



--STX
with TCP.States.Closed;

package body TCP.Connections is

   function Get_Default return State_Type is
   begin
      return States.Closed.State;
   end;


   procedure Set_State
     (Connection : in out Connection_Type;
      State      : in     State_Type) is
   begin
      Connection.State := State;
   end;


   procedure Active_Open
     (Connection : in out Connection_Type) is
   begin
      Active_Open (Connection.State) (Connection);
   end;


   procedure Passive_Open
     (Connection : in out Connection_Type) is
   begin
      Passive_Open (Connection.State) (Connection);
   end;


   procedure Close
     (Connection : in out Connection_Type) is
   begin
      Close (Connection.State) (Connection);
   end;


   procedure Send
     (Connection : in out Connection_Type) is
   begin
      Send (Connection.State) (Connection);
   end;


   procedure Acknowledge
     (Connection : in out Connection_Type) is
   begin
      Acknowledge (Connection.State) (Connection);
   end;


   procedure Synchronize
     (Connection : in out Connection_Type) is
   begin
      Synchronize (Connection.State) (Connection);
   end;


   procedure Process_Stream
     (Connection : in out Connection_Type;
      Item       : in     Stream_Element_Array) is

      use Streams;
   begin
      Write (Connection.File, Item);
   end;


end TCP.Connections;
with TCP.States;
with TCP.Streams;
with Ada.Streams;  use Ada.Streams;

package TCP.Connections is

   pragma Elaborate_Body;


   type Connection_Type is limited private;

   procedure Active_Open
     (Connection : in out Connection_Type);

   procedure Passive_Open
     (Connection : in out Connection_Type);

   procedure Close
     (Connection : in out Connection_Type);

   procedure Send
     (Connection : in out Connection_Type);

   procedure Acknowledge
     (Connection : in out Connection_Type);

   procedure Synchronize
     (Connection : in out Connection_Type);


   procedure Process_Stream
     (Connection : in out Connection_Type;
      Item       : in     Stream_Element_Array);

private

   use States;

   function Get_Default return State_Type;

   type Connection_Type is
     new Root_Connection_Type with record
        State : State_Type := Get_Default;
        File  : Streams.File_Type;
     end record;

   procedure Set_State
     (Connection : in out Connection_Type;
      State      : in     State_Type);

end TCP.Connections;
with TCP.States.Established;
with TCP.States.Listen;

pragma Elaborate_All (TCP.States);

package body TCP.States.Closed is


   procedure Active_Open
     (Connection : in out Root_Connection_Type'Class) is
   begin
      -- send SYN, receive SYN, ACK, etc

      Set_State (Connection, Established.State);
   end;


   procedure Passive_Open
     (Connection : in out Root_Connection_Type'Class) is
   begin
      Set_State (Connection, Listen.State);
   end;


begin

   Set_Active_Open (State, Active_Open'Access);

   Set_Passive_Open (State, Passive_Open'Access);

end TCP.States.Closed;
package TCP.States.Closed is

   pragma Elaborate_Body;

   State : constant State_Type := 2;

end TCP.States.Closed;
with TCP.States.Listen;

pragma Elaborate_All (TCP.States);

package body TCP.States.Established is

   procedure Transmit
     (Connection : in out Root_Connection_Type'Class;
      Item       : in     Stream_Element_Array) is
   begin
      Process_Stream (Connection, Item);
   end;


   procedure Close
     (Connection : in out Root_Connection_Type'Class) is
   begin
      -- send FIN, receive ACK of FIN

      Set_State (Connection, Listen.State);
   end Close;

begin

   Set_Transmit (State, Transmit'Access);

   Set_Close (State, Close'Access);

end TCP.States.Established;
package TCP.States.Established is

   pragma Elaborate_Body;

   State : constant State_Type := 3;

end TCP.States.Established;







with TCP.States.Established;

pragma Elaborate_All (TCP.States);

package body TCP.States.Listen is

   procedure Send
     (Connection : in out Root_Connection_Type'Class) is
   begin
      -- send SYN, receive SYN, ACK, etc

      Set_State (Connection, Established.State);
   end Send;

begin

   Set_Send (State, Send'Access);

end TCP.States.Listen;
package TCP.States.Listen is

   pragma Elaborate_Body;

   State : constant State_Type := 1;

end TCP.States.Listen;
package body TCP.States is

   Max_State : constant State_Type := 5;
   --
   -- You'll have to adjust this as you add more states.

   subtype State_Range is
     State_Type range 1 .. Max_State;
   --
   -- The mapping of tcp states to State_Type values is defined in the
   -- file tcp-states.txt.
   --


   type Transmit_Array_Type is
      array (State_Range) of Transmit_Access;

   procedure Default_Transmit
     (Connection : in out Root_Connection_Type'Class;
      Item       : in     Stream_Element_Array) is
   begin
      null;
   end;

   Transmit_Array : Transmit_Array_Type :=
     (others => Default_Transmit'Access);

   function Transmit
     (State : State_Type) return Transmit_Access is
   begin
      return Transmit_Array (State);
   end;

   procedure Set_Transmit
     (State    : in State_Type;
      Transmit : in Transmit_Access) is
   begin
      Transmit_Array (State) := Transmit;
   end;




   type Active_Open_Array_Type is
      array (State_Range) of Active_Open_Access;

   procedure Default_Active_Open
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Active_Open_Array : Active_Open_Array_Type :=
     (others => Default_Active_Open'Access);

   function Active_Open
     (State : State_Type) return Active_Open_Access is
   begin
      return Active_Open_Array (State);
   end;

   procedure Set_Active_Open
     (State       : in State_Type;
      Active_Open : in Active_Open_Access) is
   begin
      Active_Open_Array (State) := Active_Open;
   end;



   type Passive_Open_Array_Type is
      array (State_Range) of Passive_Open_Access;

   procedure Default_Passive_Open
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Passive_Open_Array : Passive_Open_Array_Type :=
     (others => Default_Passive_Open'Access);

   function Passive_Open
     (State : State_Type) return Passive_Open_Access is
   begin
      return Passive_Open_Array (State);
   end;

   procedure Set_Passive_Open
     (State        : in State_Type;
      Passive_Open : in Passive_Open_Access) is
   begin
      Passive_Open_Array (State) := Passive_Open;
   end;


   type Close_Array_Type is
      array (State_Range) of Close_Access;

   procedure Default_Close
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Close_Array : Close_Array_Type :=
     (others => Default_Close'Access);

   function Close
     (State : State_Type) return Close_Access is
   begin
      return Close_Array (State);
   end;

   procedure Set_Close
     (State : in State_Type;
      Close : in Close_Access) is
   begin
      Close_Array (State) := Close;
   end;


   type Synchronize_Array_Type is
      array (State_Range) of Synchronize_Access;

   procedure Default_Synchronize
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Synchronize_Array : Synchronize_Array_Type :=
     (others => Default_Synchronize'Access);

   function Synchronize
     (State : State_Type) return Synchronize_Access is
   begin
      return Synchronize_Array (State);
   end;

   procedure Set_Synchronize
     (State       : in State_Type;
      Synchronize : in Synchronize_Access) is
   begin
      Synchronize_Array (State) := Synchronize;
   end;



   type Acknowledge_Array_Type is
      array (State_Range) of Acknowledge_Access;

   procedure Default_Acknowledge
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Acknowledge_Array : Acknowledge_Array_Type :=
     (others => Default_Acknowledge'Access);

   function Acknowledge
     (State : State_Type) return Acknowledge_Access is
   begin
      return Acknowledge_Array (State);
   end;

   procedure Set_Acknowledge
     (State       : in State_Type;
      Acknowledge : in Acknowledge_Access) is
   begin
      Acknowledge_Array (State) := Acknowledge;
   end;



   type Send_Array_Type is
      array (State_Range) of Send_Access;

   procedure Default_Send
     (Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

   Send_Array : Send_Array_Type :=
     (others => Default_Send'Access);

   function Send
     (State : State_Type) return Send_Access is
   begin
      return Send_Array (State);
   end;

   procedure Set_Send
     (State : in State_Type;
      Send  : in Send_Access) is
   begin
      Send_Array (State) := Send;
   end;


end TCP.States;
with Ada.Streams;  use Ada.Streams;

package TCP.States is

   pragma Elaborate_Body;


   type State_Type is new Integer;


   type Root_Connection_Type is
     abstract tagged limited null record;

   procedure Set_State
     (Connection : in out Root_Connection_Type;
      State      : in     State_Type) is abstract;

   procedure Process_Stream
     (Connection : in Root_Connection_Type;
      Item       : in Stream_Element_Array) is abstract;



   type Transmit_Access is
      access procedure (Connection : in out Root_Connection_Type'Class;
                        Item       : in     Stream_Element_Array);

   function Transmit
     (State : State_Type) return Transmit_Access;


   type Active_Open_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Active_Open
     (State : State_Type) return Active_Open_Access;


   type Passive_Open_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Passive_Open
     (State : State_Type) return Passive_Open_Access;


   type Close_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Close
     (State : State_Type) return Close_Access;


   type Synchronize_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Synchronize
     (State : State_Type) return Synchronize_Access;


   type Acknowledge_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Acknowledge
     (State : State_Type) return Acknowledge_Access;


   type Send_Access is
      access procedure (Connection : in out Root_Connection_Type'Class);

   function Send
     (State : State_Type) return Send_Access;


private

   procedure Set_Transmit
     (State    : in State_Type;
      Transmit : in Transmit_Access);

   procedure Set_Active_Open
     (State       : in State_Type;
      Active_Open : in Active_Open_Access);

   procedure Set_Passive_Open
     (State        : in State_Type;
      Passive_Open : in Passive_Open_Access);

   procedure Set_Close
     (State : in State_Type;
      Close : in Close_Access);

   procedure Set_Synchronize
     (State       : in State_Type;
      Synchronize : in Synchronize_Access);

   procedure Set_Acknowledge
     (State       : in State_Type;
      Acknowledge : in Acknowledge_Access);

   procedure Set_Send
     (State : in State_Type;
      Send  : in Send_Access);

end TCP.States;
package body TCP.Streams is

   Max_Streams : constant := 10;

   subtype Stream_Count is
     Natural range 0 .. Max_Streams;

   subtype Positive_Stream_Count is
     Stream_Count range 1 .. Stream_Count'Last;

   type Stream_Array is
      array (Positive_Stream_Count) of aliased TCP_Stream_Type;

   Streams      : Stream_Array;
   Streams_Last : Stream_Count := 0;


   procedure Open
     (File : in out File_Type;
      Name : in     String) is
   begin
      Streams_Last := Streams_Last + 1;
      File.Index := Streams_Last;

      null; -- open stream
   end Open;


   procedure Close
     (File : in out File_Type) is
   begin
      null; -- close stream
   end;


   function Get_Stream
     (File : File_Type) return Stream_Access is
   begin
      return Streams (File.Index)'Access;
   end;


   procedure Read
     (File : in     File_Type;
      Item :    out Stream_Element_Array;
      Last :    out Stream_Element_Offset) is

      Stream : TCP_Stream_Type renames
        Streams (File.Index);
   begin
      Read (Stream, Item, Last);
   end;


   procedure Write
     (File : in File_Type;
      Item : in Stream_Element_Array) is

      Stream : TCP_Stream_Type renames
        Streams (File.Index);
   begin
      Write (Stream, Item);
   end;


   procedure Read
     (Stream : in out TCP_Stream_Type;
      Item   :    out Stream_Element_Array;
      Last   :    out Stream_Element_Offset) is
   begin
      null; -- read elements from stream

      Item (Item'Range) := (others => 0);
      Last := 0;
   end;


   procedure Write
     (Stream : in out TCP_Stream_Type;
      Item   : in     Stream_Element_Array) is
   begin
      null; -- write elements into stream
   end;


end TCP.Streams;












with Ada.Streams;  use Ada.Streams;

package TCP.Streams is

   pragma Elaborate_Body;


   type Stream_Access is access all Root_Stream_Type'Class;

   type File_Type is limited private;


   procedure Open
     (File : in out File_Type;
      Name : in     String);

   procedure Close
     (File : in out File_Type);

   function Get_Stream
     (File : File_Type) return Stream_Access;

   procedure Read
     (File : in     File_Type;
      Item :    out Stream_Element_Array;
      Last :    out Stream_Element_Offset);

   procedure Write
     (File : in File_Type;
      Item : in Stream_Element_Array);

private

   type TCP_Stream_Type is
     new Root_Stream_Type with null record; --???


   procedure Read
     (Stream : in out TCP_Stream_Type;
      Item   :    out Stream_Element_Array;
      Last   :    out Stream_Element_Offset);

   procedure Write
     (Stream : in out TCP_Stream_Type;
      Item   : in     Stream_Element_Array);


   type File_Type is
      limited record
         Index : Natural := 0;
      end record;

end TCP.Streams;












package TCP is

   pragma Pure;

end TCP;


(c) 1998-2004 All Rights Reserved David Botton