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