I whipped up a new (better?) version of the observer pattern.
The only unit that changed is package Subjects_And_Observers:
o Notify is now a class-wide operation.
o The private subject operations Register and Unregister are gone, and
the work they did has been incorporated into observer operations
Initialize and Finalize.
o The observer type no longer privately derives from Limited_Controlled.
Instead, a controlled component of the observer does the list
manipulation during its own initialization and finalization:
type Observer_Control (Observer : access Root_Observer_Type'Class) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Observer_Control);
procedure Finalize (Control : in out Observer_Control);
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract tagged limited record
Control : Observer_Control (Root_Observer_Type'Access); <--
Next : Observer_Access;
end record;
In general, it's better to make components controlled, rather than the
entire type. That way there's no conflict if a descendent type
overrides Initialize and Finalize.
o Accessibility checks are turned off using Unchecked_Access instead of
pragma Suppress.
procedure Initialize (Control : in out Observer_Control) is
Observer : constant Observer_Access :=
Control.Observer.all'Unchecked_Access;
...
o The component of the subject that denotes the head of the observer
list has been renamed:
type Root_Subject_Type is
abstract tagged limited record
Head : Observer_Access;
end record;
The following code is ready for GNAT Chop:
--STX
with Ada.Finalization;
package Subjects_And_Observers is
type Root_Subject_Type is
abstract tagged limited private;
procedure Notify (Subject : in out Root_Subject_Type'Class);
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract tagged limited private;
procedure Update (Observer : access Root_Observer_Type) is abstract;
private
type Observer_Access is access all Root_Observer_Type'Class;
pragma Suppress (Access_Check, On => Observer_Access);
type Root_Subject_Type is
abstract tagged limited record
Head : Observer_Access;
end record;
use Ada.Finalization;
type Observer_Control (Observer : access Root_Observer_Type'Class) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Observer_Control);
procedure Finalize (Control : in out Observer_Control);
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract tagged limited record
Control : Observer_Control (Root_Observer_Type'Access);
Next : Observer_Access;
end record;
end Subjects_And_Observers;
package body Subjects_And_Observers is
procedure Notify (Subject : in out Root_Subject_Type'Class) is
Observer : Observer_Access := Subject.Head;
begin
while Observer /= null loop
Update (Observer);
Observer := Observer.Next;
end loop;
end Notify;
procedure Initialize (Control : in out Observer_Control) is
Observer : constant Observer_Access :=
Control.Observer.all'Unchecked_Access;
Subject : Root_Subject_Type'Class renames
Observer.Subject.all;
begin
Observer.Next := Subject.Head;
Subject.Head := Observer;
end;
procedure Finalize (Control : in out Observer_Control) is
Observer : constant Observer_Access :=
Control.Observer.all'Unchecked_Access;
Subject : Root_Subject_Type'Class renames
Observer.Subject.all;
Prev : Observer_Access;
Index : Observer_Access;
begin
if Subject.Head = Observer then
Subject.Head := Subject.Head.Next;
else
Prev := Subject.Head;
Index := Subject.Head.Next;
while Index /= Observer loop
Prev := Index;
Index := Index.Next;
end loop;
Prev.Next := Index.Next;
end if;
end Finalize;
end Subjects_And_Observers;
|
