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
Observer Notification Using Callbacks (Matthew Heaney)

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;


(c) 1998-2004 All Rights Reserved David Botton