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