State Pattern

The State pattern appears whenever you have an abstraction that
executes a state machine.

A state machine comprises a set of states and event/action pairs.  When
the machine receives a message (an event happens), the machine does
something (performs some action).  How the machine reacts to the message
is a function of both the event and the current state of the machine.

In this implementation of the pattern, events map to operations of a
state class, and actions to the implementation of the operations.  Each
specific type in the class corresponds to a different connection state.

State transitions are effected by pointing to different state objects
that have different specific types.  Operation invocations dispatch on
the tag of the state object, which causes different actions occur for
the same event.

Implementation

The state machine in this example is a TCP connection, implemented as an
abstract data type whose full view has a pointer to a state object:

  with TCP.States;
  package TCP.Connections is

     type Connection_Type is limited private;

     <connection ops>

  private

     type Connection_Type is ...
       record
          State : State_Access := ...;
       end record;

  end TCP.Connections;


The state type is implemented as limited and indefinite, to control
instance creation:

  package TCP.States is

     type Root_State_Type (<>) is
       abstract tagged limited private;

     type State_Access is access all Root_State_Type'Class;
     ...

  end TCP.States;


In this particular case, the need for this strict kind of enforcement is
less compelling, since clients only use connection types, not state
types.  But, as we shall see, the types that derive from Root_State_Type
are all singletons, and it's nice to have a guarantee of this.

TCP connection operations are implemented by calling the corresponding
(primitive) operations of the state object, which dispatch on the tag.
Some of those invocations may cause a state transition to occur.

In order to allow the operation to change the state object to which the
connection object points, you have to pass the connection object as a
parameter of the state operation.

But state types don't know anything connection types.  Even if they did,
they still don't have access to the representation of connection type,
so how can they change its state object?

What we do is create a sort of forward declaration of the connection
type in the state package, and provide whatever operations are needed by
state types to manipulate connection instances.  It is this type that is
passed as a parameter in state operations, like this:


  package TCP.States is
     ...
     type Root_Connection_Type is                         <--
       abstract tagged limited null record;

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

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


     procedure Transmit
       (State      : access Root_State_Type;
        Connection : in out Root_Connection_Type'Class;   <--
        Item       : in     Stream_Element_Array);

     procedure Active_Open
       (State      : access Root_State_Type;
        Connection : in out Root_Connection_Type'Class);  <--
     ...
  end TCP.States;


The Connection_Type (in TCP.Connections) has to be in the
Root_Connection_Type (in TCP.States) class, in order to pass itself as
the connection parameter of state operations.  We therefore implement
Connection_Type as a private derivation from Root_Connection_Type:

    type Connection_Type is limited private;
    ...
  private

    type Connection_Type is
      new Root_Connection_Type with record
         State : State_Access := Get_Default;
      end record;


This is another example of Ada's expressive power: we can implement the
full view of a type as tagged, even though the partial view is not
tagged.  We're using tagged-ness strictly as an implementation
technique, because there's no reason for clients to extend this type.

The implementation of connection operations is now strait-forward:

   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;


As we mentioned earlier, the types in the state class are all
implemented as singletons.  Per that idiom, each specific type declares
a singleton instance in the package body, and exports a function that
returns a pointer to that instance:


  package TCP.States.Established is

    type Established_State_Type is new Root_State_Type with private;

    function State return State_Access;



  package body TCP.States.Established is

    Singleton : aliased Established_State_Type;

    function State return State_Access is
    begin
       return Singleton'Access;
    end;


Primitive operations of state type also take access parameters, so that
no explicit dereferencing is necessary.

   procedure Close
     (State      : access Established_State_Type;       <--
      Connection : in out Root_Connection_Type'Class);


This allows operation calls to have a natural syntax:

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

(Connection.State is a pointer to a singleton.)


State type clients change the state of the connection by calling
Set_State, which has a trivial implementation (in TCP.Connections):

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


State type operations that do change the connection state pass the
singleton pointer of some other type in the class:

  with TCP.States.Listen;
  package body TCP.States.Established is

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

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



  with TCP.States.Established;
  package body TCP.States.Listen is

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

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



  with TCP.States.Established;
  with TCP.States.Listen;
  package body TCP.States.Closed is

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

        Set_State (Connection, Established.State);    <--
     end;


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


Notice how this creates a mutual dependency among all the types in the
state class, although only at the body level.

One thing we need to do is initialize a connection object to a
closed-state default.  We don't want to do this:

    type Connection_Type is
      new Root_Connection_Type with record
        State : State_Access := TCP.States.Closed.State;  <--
      end record;

because that makes TCP.Connections depend on TCP.States.Closed in its
spec.  We want to move the dependency on TCP.States.Closed to the body.

So what we do is declare a function that returns the default state, and
call that during elaboration of connection objects:

   function Get_Default return State_Access;

   type Connection_Type is
     new Root_Connection_Type with record
        State : State_Access := Get_Default;
     end record;

This allows us to move the dependency on TCP.States.Closed to the body:

  with TCP.States.Closed;
  package body TCP.Connections is

    function Get_Default return State_Access renames
      States.Closed.State;

Notice that we implement the body of Get_Default as a renaming of the
selector that returns a pointer to the closed-state singleton.


Matt
<mailto:matthew_heaney@acm.org>

The code below is in a format suitable for use with gnatchop.  Note that
there's no driver program, since the real exercise was how to organize
modules.


--STX
with TCP.States.Closed;

package body TCP.Connections is

   function Get_Default return State_Access renames
     States.Closed.State;


   procedure Set_State
     (Connection : in out Connection_Type;
      State      : in     State_Access) 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_Access;

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

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

end TCP.Connections;



with TCP.States.Established;
with TCP.States.Listen;

package body TCP.States.Closed is

   Singleton : aliased Closed_State_Type;


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

      Set_State (Connection, Established.State);
   end;


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


   function State return State_Access is
   begin
      return Singleton'Access;
   end;

end TCP.States.Closed;


package TCP.States.Closed is

   pragma Elaborate_Body;


   type Closed_State_Type is new Root_State_Type with private;

   procedure Active_Open
     (State      : access Closed_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Passive_Open
     (State      : access Closed_State_Type;
      Connection : in out Root_Connection_Type'Class);


   function State return State_Access;

private

   type Closed_State_Type is new Root_State_Type with null record;

end TCP.States.Closed;


with TCP.States.Listen;

package body TCP.States.Established is

   Singleton : aliased Established_State_Type;


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


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

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



   function State return State_Access is
   begin
      return Singleton'Access;
   end;

end TCP.States.Established;



package TCP.States.Established is

   pragma Elaborate_Body;


   type Established_State_Type is new Root_State_Type with private;

   procedure Transmit
     (State      : access Established_State_Type;
      Connection : in out Root_Connection_Type'Class;
      Item       : in     Stream_Element_Array);

   procedure Close
     (State      : access Established_State_Type;
      Connection : in out Root_Connection_Type'Class);

   function State return State_Access;

private

   type Established_State_Type is
     new Root_State_Type with null record;

end TCP.States.Established;



with TCP.States.Established;

package body TCP.States.Listen is

   Singleton : aliased Listen_State_Type;


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

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


   function State return State_Access is
   begin
      return Singleton'Access;
   end;


end TCP.States.Listen;



package TCP.States.Listen is

   pragma Elaborate_Body;


   type Listen_State_Type is new Root_State_Type with private;

   procedure Send
     (State      : access Listen_State_Type;
      Connection : in out Root_Connection_Type'Class);

   function State return State_Access;

private

   type Listen_State_Type is
     new Root_State_Type with null record;

end TCP.States.Listen;


package body TCP.States is

   procedure Transmit
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class;
      Item       : in     Stream_Element_Array) is
   begin
      null;
   end;


   procedure Active_Open
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;


   procedure Passive_Open
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;


   procedure Close
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;


   procedure Synchronize
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;


   procedure Acknowledge
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;


   procedure Send
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class) is
   begin
      null;
   end;

end TCP.States;



with Ada.Streams;  use Ada.Streams;

package TCP.States is

   pragma Preelaborate;


   type Root_State_Type (<>) is
     abstract tagged limited private;

   type State_Access is access all Root_State_Type'Class;


   type Root_Connection_Type is
     abstract tagged limited null record;

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

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


   procedure Transmit
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class;
      Item       : in     Stream_Element_Array);

   procedure Active_Open
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Passive_Open
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Close
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Synchronize
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Acknowledge
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);

   procedure Send
     (State      : access Root_State_Type;
      Connection : in out Root_Connection_Type'Class);


private

   type Root_State_Type is
     abstract tagged limited null record;

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;