When a subject changes its state, it notifies its observers by calling
their Update operation, which is primitive for observer types.
This mechanism requires that each observer derive from Observer_Type and
override the Update operation. If you're observing multiple subject
attributes, this means a separate observer derivation for each one.
This approach may seem a bit heavy to some, especially as the number of
subject attributes needing observation grows large.
A less heavy but more traditional approach is to simply use callbacks.
To notify an observer, the subject calls a procedure designated by a
pointer, instead of dispatching a primitive operation.
Implementation
Before, an observer would attach itself to a subject by passing itself
(really, its address) to the subject. Now we have to pass another piece
of information to the subject, the pointer to the callback procedure.
This will change the implementation of the subject a little, because it
now has to maintain a list comprising observer address and callback
address pairs.
The elided spec of the Subjects_And_Observers now looks like this:
package Subjects_And_Observers is
<subject type declarations>
type Observer_Type is
tagged limited null record;
type Update_Type is
access procedure (Observer : in out Observer_Type'Class);
procedure Attach
(Observer : access Observer_Type'Class;
Update : in Update_Type;
To : access Subject_Type'Class);
procedure Detach
(Observer : access Observer_Type'Class;
From : access Subject_Type'Class);
private
...
end Subjects_And_Observers;
The Observer_Type is just a (tagged) limited null record, because it has
no state the subject cares about. The subject is just going to put the
observer's address on its internal list of observer information.
The Update_Type defines the qualities of the callback itself. The
callback accepts an observer parameter, and the subject will pass the
observer as the callback argument during the notification.
The only other change to the spec is that Attach now takes an Update
parameter, which is the address of the callback procedure.
The private part of the spec now looks like this:
package Subjects_And_Observers is
...
private
type Observer_Access is access all Observer_Type'Class;
type Node_Type;
type Node_Access is access Node_Type;
type Node_Type is
limited record
Observer : Observer_Access;
Update : Update_Type;
Next : Node_Access;
end record;
type Subject_Type is
tagged limited record
Head : Node_Access;
end record;
end Subjects_And_Observers;
The subject contains a pointer designating a singly-linked list of
observers and callbacks. This is slightly different from before, when
the subject was a list of just observers.
In the body, the subject notifies its observers by dereferencing the
Update pointer, and invoking the designated callback:
procedure Notify (Subject : in out Subject_Type'Class) is
Node : Node_Access := Subject.Head;
begin
while Node /= null loop
-- Call callback Update, passing Observer as actual parameter.
--
Node.Update (Node.Observer.all);
Node := Node.Next;
end loop;
end Notify;
Attach is implemented by allocating a new list node, and inserting it at
the head of the subject's internal list:
procedure Attach
(Observer : access Observer_Type'Class;
Update : in Update_Type;
To : access Subject_Type'Class) is
Node : constant Node_Access :=
new Node_Type;
begin
Node.Observer := Observer.all'Unchecked_Access;
Node.Update := Update;
Node.Next := To.Head;
To.Head := Node;
end Attach;
We are still using the now-familiar example of a digital clock that
observes a clock timer. All the changes in this implementation affect
the observer, so Clock_Timer hasn't changed.
Here's the spec of the observer:
package Digital_Clocks is
type Digital_Clock (Timer : access Clock_Timer) is
limited private;
private
type Control_Type (Clock : access Digital_Clock) is
new Limited_Controlled with null record;
procedure Initialize (...);
procedure Finalize (...);
type Digital_Clock
(Timer : access Clock_Timer) is
new Observer_Type with record
Control : Control_Type (Digital_Clock'Access);
end record;
end Digital_Clocks;
As before, there's a Control component to attach and detach the observer
to the subject(s) during elaboration and end of scope. However, there
aren't separate observer types anymore, and the full view of
Digital_Clock privately derives from Observer_Type in the normal way.
The novelty of this implementation of the Observer pattern is that the
observer registers a subprogram pointer with the subject. This callback
has to conform to the profile:
type Update_Type is
access procedure (Observer : in out Observer_Type'Class);
That is, it takes one argument, of type Observer_Type'Class.
Ultimately, the implementation of a callback will look like this:
procedure Update_Hour
(Observer : in out Observer_Type'Class) is
begin
<get hour from clock timer>
<display hour>
end;
The obvious problem is that you pass in an object of type Observer_Type,
but you need an object of type Digital_Clock, so you can get at its
Timer discriminant (that's the source of the hour, min, and sec).
The solution is easy enough: we just downcast from Observer_Type to
Digital_Clock type, like this:
procedure Update_Hour
(Observer : in out Observer_Type'Class) is
Clock : Digital_Clock renames Digital_Clock (Observer);
This is a view conversion between tagged types, and so the result of the
conversion is renameable.
Of course, you incur the penalty of a Tag_Check, since this is a
conversion away from the root. If that bothers you, then just use
pragma Suppress to turn the check off.
The entire implementation of a typical callback looks like this:
procedure Update_Hour
(Observer : in out Observer_Type'Class) is
Clock : Digital_Clock renames Digital_Clock (Observer);
Image : constant String :=
Integer'Image (Get_Hour (Clock.Timer) + 100);
begin
Put_Line ("new hour is " & Image (3 .. Image'Last));
end;
We first downcast the Observer arg to Digital_Clock, and then query the
timer (visible now as the Clock's access discriminant) to get the new
value of the timer's attribute.
In this example, there are three callbacks, one for each subject
(attribute) we're observing. During Initialization, we pass the
procedure addresses to Attach:
procedure Initialize (Control : in out Control_Type) is
begin
Attach
(Observer => Control.Clock,
Update => Update_Hour'Access,
To => Get_Hour_Subject (Control.Clock.Timer));
Attach
(Observer => Control.Clock,
Update => Update_Minute'Access,
To => Get_Minute_Subject (Control.Clock.Timer));
Attach
(Observer => Control.Clock,
Update => Update_Second'Access,
To => Get_Second_Subject (Control.Clock.Timer));
end Initialize;
The Finalize procedure is unchanged from before.
--STX
package body Clock_Timers is
function Default_Time return Natural is
begin
return 1 * 3600 + 59 * 60 + 55;
end;
procedure Do_Tick
(Timer : in out Clock_Timer) is
Hour : constant Hour_Number :=
Timer.Current_Time / 3600;
Minute : constant Minute_Number :=
(Timer.Current_Time - 3600 * Hour) / 60;
Second : constant Second_Number :=
Timer.Current_Time -
3600 * Hour -
60 * Minute;
begin
if Timer.Hour /= Hour then
Timer.Hour := Hour;
Notify (Timer.Hour_Subject);
end if;
if Timer.Minute /= Minute then
Timer.Minute := Minute;
Notify (Timer.Minute_Subject);
end if;
if Timer.Second /= Second then
Timer.Second := Second;
Notify (Timer.Second_Subject);
end if;
end Do_Tick;
procedure Tick
(Timer : in out Clock_Timer) is
begin
Timer.Current_Time := Timer.Current_Time + 1;
Do_Tick (Timer);
end Tick;
function Get_Hour
(Timer : access Clock_Timer)
return Hour_Number is
begin
return Timer.Hour;
end;
function Get_Hour_Subject
(Timer : access Clock_Timer)
return Subject_Access is
begin
return Timer.Hour_Subject'Access;
end;
function Get_Minute
(Timer : access Clock_Timer)
return Minute_Number is
begin
return Timer.Minute;
end;
function Get_Minute_Subject
(Timer : access Clock_Timer)
return Subject_Access is
begin
return Timer.Minute_Subject'Access;
end;
function Get_Second
(Timer : access Clock_Timer)
return Second_Number is
begin
return Timer.Second;
end;
function Get_Second_Subject
(Timer : access Clock_Timer)
return Subject_Access is
begin
return Timer.Second_Subject'Access;
end;
end Clock_Timers;
with Subjects_And_Observers; use Subjects_And_Observers;
package Clock_Timers is
pragma Preelaborate;
type Clock_Timer is limited private;
procedure Tick
(Timer : in out Clock_Timer);
subtype Hour_Number is
Natural range 0 .. 23;
function Get_Hour
(Timer : access Clock_Timer)
return Hour_Number;
function Get_Hour_Subject
(Timer : access Clock_Timer)
return Subject_Access;
subtype Minute_Number is
Natural range 0 .. 59;
function Get_Minute
(Timer : access Clock_Timer)
return Minute_Number;
function Get_Minute_Subject
(Timer : access Clock_Timer)
return Subject_Access;
subtype Second_Number is
Natural range 0 .. 59;
function Get_Second
(Timer : access Clock_Timer)
return Second_Number;
function Get_Second_Subject
(Timer : access Clock_Timer)
return Subject_Access;
private
function Default_Time return Natural;
type Clock_Timer is
limited record
Current_Time : Natural := Default_Time;
Hour : Integer := -1;
Hour_Subject : aliased Subject_Type;
Minute : Integer := -1;
Minute_Subject : aliased Subject_Type;
Second : Integer := -1;
Second_Subject : aliased Subject_Type;
end record;
end Clock_Timers;
with Ada.Text_IO; use Ada.Text_IO;
package body Digital_Clocks is
procedure Update_Hour
(Observer : in out Observer_Type'Class) is
Clock : Digital_Clock renames Digital_Clock (Observer);
Image : constant String :=
Integer'Image (Get_Hour (Clock.Timer) + 100);
begin
Put_Line ("new hour is " & Image (3 .. Image'Last));
end;
procedure Update_Minute
(Observer : in out Observer_Type'Class) is
Clock : Digital_Clock renames Digital_Clock (Observer);
Image : constant String :=
Integer'Image (Get_Minute (Clock.Timer) + 100);
begin
Put_Line ("new min is " & Image (3 .. Image'Last));
end;
procedure Update_Second
(Observer : in out Observer_Type'Class) is
Clock : Digital_Clock renames Digital_Clock (Observer);
Image : constant String :=
Integer'Image (Get_Second (Clock.Timer) + 100);
begin
Put_Line ("new sec is " & Image (3 .. Image'Last));
end;
procedure Initialize (Control : in out Control_Type) is
begin
Attach
(Observer => Control.Clock,
Update => Update_Hour'Access,
To => Get_Hour_Subject (Control.Clock.Timer));
Attach
(Observer => Control.Clock,
Update => Update_Minute'Access,
To => Get_Minute_Subject (Control.Clock.Timer));
Attach
(Observer => Control.Clock,
Update => Update_Second'Access,
To => Get_Second_Subject (Control.Clock.Timer));
end Initialize;
procedure Finalize (Control : in out Control_Type) is
begin
Detach
(Observer => Control.Clock,
From => Get_Hour_Subject (Control.Clock.Timer));
Detach
(Observer => Control.Clock,
From => Get_Minute_Subject (Control.Clock.Timer));
Detach
(Observer => Control.Clock,
From => Get_Second_Subject (Control.Clock.Timer));
end Finalize;
end Digital_Clocks;
with Clock_Timers; use Clock_Timers;
with Subjects_And_Observers;
with Ada.Finalization;
package Digital_Clocks is
pragma Elaborate_Body;
type Digital_Clock (Timer : access Clock_Timer) is
limited private;
private
use Subjects_And_Observers;
use Ada.Finalization;
type Control_Type (Clock : access Digital_Clock) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Control_Type);
procedure Finalize (Control : in out Control_Type);
type Digital_Clock
(Timer : access Clock_Timer) is
new Observer_Type with record
Control : Control_Type (Digital_Clock'Access);
end record;
end Digital_Clocks;
with Ada.Unchecked_Deallocation;
package body Subjects_And_Observers is
procedure Free is
new Ada.Unchecked_Deallocation
(Node_Type,
Node_Access);
procedure Notify (Subject : in out Subject_Type'Class) is
Node : Node_Access := Subject.Head;
begin
while Node /= null loop
Node.Update (Node.Observer.all);
Node := Node.Next;
end loop;
end Notify;
procedure Attach
(Observer : access Observer_Type'Class;
Update : in Update_Type;
To : access Subject_Type'Class) is
Node : constant Node_Access :=
new Node_Type;
begin
Node.Observer := Observer.all'Unchecked_Access;
Node.Update := Update;
Node.Next := To.Head;
To.Head := Node;
end Attach;
procedure Detach
(Observer : access Observer_Type'Class;
From : access Subject_Type'Class) is
OA : constant Observer_Access :=
Observer.all'Unchecked_Access;
Prev : Node_Access := From.Head;
Index : Node_Access;
begin
if Prev.Observer = OA then
From.Head := From.Head.Next;
Free (Prev);
else
Index := From.Head.Next;
while Index.Observer /= OA loop
Prev := Index;
Index := Index.Next;
end loop;
Prev.Next := Index.Next;
Free (Index);
end if;
end Detach;
end Subjects_And_Observers;
package Subjects_And_Observers is
pragma Preelaborate;
type Subject_Type is
tagged limited private;
type Subject_Access is
access all Subject_Type'Class;
procedure Notify
(Subject : in out Subject_Type'Class);
type Observer_Type is
tagged limited null record;
type Update_Type is
access procedure (Observer : in out Observer_Type'Class);
procedure Attach
(Observer : access Observer_Type'Class;
Update : in Update_Type;
To : access Subject_Type'Class);
procedure Detach
(Observer : access Observer_Type'Class;
From : access Subject_Type'Class);
private
type Observer_Access is access all Observer_Type'Class;
pragma Suppress (Access_Check, On => Observer_Access);
type Node_Type;
type Node_Access is access Node_Type;
type Node_Type is
limited record
Observer : Observer_Access;
Update : Update_Type;
Next : Node_Access;
end record;
type Subject_Type is
tagged limited record
Head : Node_Access;
end record;
end Subjects_And_Observers;
with Ada.Text_IO; use Ada.Text_IO;
with Clock_Timers; use Clock_Timers;
with Digital_Clocks; use Digital_Clocks;
procedure Test_Observers is
Timer : aliased Clock_Timer;
Clock : Digital_Clock (Timer'Access);
procedure Do_Ticks is
begin
Tick (Timer);
Tick (Timer);
Tick (Timer);
New_Line;
end Do_Ticks;
begin
Put_Line ("(one observer)");
Do_Ticks;
declare
Another_Clock : Digital_Clock (Timer'Access);
begin
Put_Line ("(two observers)");
Do_Ticks;
declare
Yet_Another_Clock : Digital_Clock (Timer'Access);
begin
Put_Line ("(three observers)");
Do_Ticks;
end;
Put_Line ("(two observers)");
Do_Ticks;
end;
Put_Line ("(one observer)");
Do_Ticks;
end Test_Observers;
|
