Implementing Design Patterns in Ada95

1
Implementing Design Patterns in Ada95

• Tips, Tricks,and Idioms
• by Matthew Heaney
• ltmailtomatthew_heaney_at_acm.orggt

2
Join the Ada95 patterns list!
Send a message with the body subscribe patterns
ltyour full namegt to the ACM mailing list
server ltmailtolistserv_at_acm.orggt Search the
archives for pattern implementations lthttp//www
.acm.org/archives/patterns.htmlgt
3
Interpreter
4
Whats An Interpreter?

• Interpret sentences in a language specified by a
  grammar.
• Each production in the grammar is implemented as
  a type.
• As a lexical expression is parsed, an object is
  created for each production in the sentence.

5
Boolean Expression Grammar
ltexpgt ltand expgt ltor expgt ltnot expgt
ltvar expgt ltconst expgt ltand expgt ltexpgt
and ltexpgt ltor expgt ltexpgt or ltexpgt ltnot expgt
not ltexpgt ltvar expgt ltnamegt ltconst expgt
true false
6
package Bool_Exps is type Bool_Exp (ltgt) is
abstract tagged limited private type
Bool_Exp_Access is access all
Bool_Exp'Class function Eval (Exp
access Bool_Exp Context in
Exp_Context) return Boolean is abstract
function Copy (Exp access Bool_Exp)
return Bool_Exp_Access is abstract ...
7
... procedure Free (Exp in out
Bool_Exp_Access) private type Bool_Exp is
abstract tagged limited null record
procedure Do_Free (Exp access
Bool_Exp) ... end Bool_Exps
8
The Need For Indirection

• Some expressions (ltandgt, ltorgt, ltnotgt) contain
  other expressions.
• We dont know the size of the expression
  component (of type Bool_ExpClass, which is
  indefinite), so we must refer to it indirectly.
• Containment by reference instead of
  containment by value.

9
package Bool_Exps.And_Exps is type And_Exp is
new Bool_Exp with private function
New_And (L, R access Bool_Exp'Class)
return Bool_Exp_Access function Eval
(Exp access And_Exp Context in
Exp_Context) return Boolean ...
10
... private type And_Exp is new Bool_Exp
with record L, R Bool_Exp_Access
end record procedure Do_Free (Exp
access And_Exp) end Bool_Exps.And_Exps
11
Desiderata

• We want prevent the client from creating or
  destroying instances directly, to allow each type
  to define and enforce its own storage management
  policy, and hide the details.
• We want to minimize syntactic overhead (dont
  want to have to explicitly dereference a pointer).

12
Implementation

• Designated type is limited and indefinite.
  Limited-ness prevents (shallow) copies, and
  indefinite-ness prevents direct allocation.
• Each specific type declares a constructor, so a
  client can create instances of type. (A client
  never calls allocator new directly.)

13

• Primitive operations take access parameters.
  Therefore, no explicit dereferencing is
  necessary.
• Each type declares its own private deconstructor,
  which performs type-specific clean-up prior to
  actual deallocation.
• The client reclaims storage for an object by
  explicitly calling a public, class-wide
  deconstructor, which is implemented by calling
  the types private deconstructor.

14
((True and X) or (Y and (not X)))
declare Exp Bool_Exp_Access New_Or
(New_And (New_Const (True),
New_Var ('X')), New_And (New_Var ('Y'),
New_Not (New_Var ('X'))))
Exp_Value constant Boolean Eval (Exp,
Context) begin Free (Exp) end
15
package body Bool_Exps.And_Exps is ...
function Eval (Exp access And_Exp
Context in Exp_Context) return
Boolean is begin return Eval
(Exp.L, Context) and Eval (Exp.R,
Context) end Eval
16
package body Bool_Exps.And_Exps is type
And_Exp_Access is access all And_Exp
function New_And (L, R access
Bool_Exp'Class) return Bool_Exp_Access is
Exp constant And_Exp_Access
new And_Exp begin Exp.L
Bool_Exp_Access (L) Exp.R
Bool_Exp_Access (R) return
Bool_Exp_Access (Exp) end New_And
17
Deallocation

• Client manually calls a class-wide Free operation
  to deallocate an expression object.
• Free cant deallocate the (class-wide) object
  directly, because type-specific clean-up may be
  required.
• Free internally calls the private operation
  Do_Free, which dispatches according to the
  objects tag. The type itself does the clean-up
  and actual deallocation.
• Free is an example of a template method.

18
body Bool_Exps is ... procedure Free
(Exp in out Bool_Exp_Access) is begin
if Exp / null then Do_Free (Exp) --
dispatches Exp null end if
end Free end Bool_Exps
19
package body Bool_Exps.And_Exps is ...
procedure Do_Free (Exp access And_Exp) is
procedure Deallocate is new
Ada.Unchecked_Deallocation (And_Exp,
And_Exp_Access) EA And_Exp_Access
And_Exp_Access (Exp) begin Do_Free
(Exp.L) Do_Free (Exp.R) Deallocate
(EA) end Do_Free end Bool_Exps.And_Exps
20
Constant Expressions

• The type Const_Exp has only two values True and
  False.
• Because objects are referred to indirectly,
  multiple clients can share the same object, thus
  avoiding allocation of duplicate values.
• This is an example of the Flyweight pattern.

21
package Bool_Exps.Const_Exps is pragma
Elaborate_Body type Const_Exp is new
Bool_Exp with private ... function
New_Const (Value Boolean) return
Bool_Exp_Access ...
22
package body Bool_Exps.Const_Exps is type
Const_Exp_Array is array (Boolean) of
aliased Const_Exp Const_Exps
Const_Exp_Array function New_Const
(Value Boolean) return Bool_Exp_Access
is begin return Const_Exps
(Value)'Access end ...
23
... begin for Value in Const_Exps'Range
loop Const_Exps (Value).Value Value
end loop end Bool_Exps.Const_Exps
24
Smart Pointers
25
Motivation

• One issue with the Interpreter example is that
  deallocation of expression objects must be done
  manually by the client, by explicitly calling
  Free.
• This is an obvious source of memory leaks and
  dangling references.
• Besides its being prone to error, explicit
  deallocation also carries a fair amount of
  syntactic overhead.

26
Perform_Mental_Gymnastics declare
Replacement Bool_Exp_Access New_Not
(New_Var ('Z')) Rep_Exp constant
Bool_Exp_Access Replace (Exp, 'Y',
Replacement) begin Free (Replacement)
Free (Exp) Exp Rep_Exp end
Perform_Mental_Gymnastics
27
Desiderata

• Low syntactic overhead. Manipulation of smart
  pointers should be similar to regular access
  objects.
• By-reference semantics implies a
  reference-counting scheme.
• No explicit deallocation is ever required.
  Implies use of a Controlled type.

28
package Bool_Exps is type Bool_Exp (ltgt) is
abstract tagged limited private type
Bool_Exp_Access is access all
Bool_Exp'Class type Exp_Handle is private
function "" (Handle Exp_Handle)
return Bool_Exp_Access function Null_Handle
return Exp_Handle ...
29
private type Bool_Exp is abstract tagged
limited record Count Natural end
record type Exp_Handle_Rep is new
Controlled with record Exp
Bool_Exp_Access end record procedure
Adjust (Handle ...) procedure Finalize
(Handle ...) type Exp_Handle is
record Rep Exp_Handle_Rep end
record
30
((True and X) or (Y and (not X)))
declare Exp constant Exp_Handle
New_Or (New_And (New_Const (True),
New_Var ('X')), New_And
(New_Var ('Y'), New_Not
(New_Var ('X')))) Exp_Value constant
Boolean Eval (Exp, Context) begin
null end
31
Without Smart Pointers
declare Replacement Bool_Exp_Access
New_Not (New_Var ('Z')) Rep_Exp constant
Bool_Exp_Access Replace (Exp, 'Y',
Replacement) begin Free (Replacement)
Free (Exp) Exp Rep_Exp end
32
With Smart Pointers
declare Replacement constant Exp_Handle
New_Not (New_Var ('Z')) begin Exp Replace
(Exp, 'Y', Replacement) end
33
function Eval (Exp access And_Exp
Context in Exp_Context) return
Boolean is begin return Eval
(Exp.L, Context) and Eval (Exp.R,
Context) end Eval
34
Implementation

• A smart pointer is a non-limited type that
  privately derives from Controlled, and has an
  access object as its only component.
• It uses unary plus to return the value of the
  internal access object, which is used immediately
  as the actual parameter in subprogram calls.

35

• The type designated by the access type has a
  Count component to store the number of
  references.
• When the reference count drops to zero (meaning
  there are no more references to the object), the
  designated object is automatically returned to
  storage.

36
Consequences

• Constructors now return Exp_Handle instead of
  Bool_Exp_Access.
• Expression components (of ltandgt, ltorgt, and ltnotgt
  expressions) are now of type Exp_Handle.
• Small syntactic penalty necessary to dereference
  handle object.

37
package Bool_Exps.And_Exps is type And_Exp is
new Bool_Exp with private function
New_And (L, R Exp_Handle) return
Exp_Handle function Eval (Exp
access And_Exp Context in
Exp_Context) return Boolean ...
38
... private type And_Exp is new
Bool_Exp with record L, R Exp_Handle
end record procedure Do_Free (Exp
access And_Exp) end Bool_Exps.And_Exps
39
Allocation
function New_And (L, R Exp_Handle)
return Exp_Handle is Exp constant
And_Exp_Access new And_Exp
Handle_Rep constant Exp_Handle_Rep
(Controlled with Exp gt Exp.allAccess)
begin Exp.Count 1 Exp.L L
Exp.R R return (Rep gt Handle_Rep)
end New_And
40
Assignment

• During assignment, the private operation Adjust
  is called to increment the reference count of the
  object designated by the pointer.

41
package body Bool_Exps is ... procedure
Adjust (Handle in out Exp_Handle_Rep) is
begin if Handle.Exp / null then
Handle.Exp.Count
Handle.Exp.Count 1 end if end
Adjust ...
42
Deallocation

• When a smart pointer is assigned a new value, or
  goes out of scope, then the private operation
  Finalize is called.
• Finalize decrements the reference count of the
  designated object.
• If the reference count is zero, then Finalize
  also returns the object to storage, by calling
  (dispatching operation) Do_Free.

43
package body Bool_Exps is ... procedure
Finalize (Handle in out Exp_Handle_Rep)
is begin if Handle.Exp / null then
Handle.Exp.Count
Handle.Exp.Count - 1 if
Handle.Exp.Count 0 then Do_Free
(Handle.Exp) end if end if
end Finalize
44
package body Bool_Exps.And_Exps is ...
procedure Do_Free (Exp access And_Exp) is
EA And_Exp_Access And_Exp_Access (Exp)
procedure Deallocate is new
Ada.Unchecked_Deallocation (And_Exp,
And_Exp_Access) begin pragma Assert
(Exp.Count 0) Exp.L Null_Handle
Exp.R Null_Handle Deallocate (EA)
end end Bool_Exps.And_Exps
45
Dereferencing

• The deference operator () for the smart
  pointer has a trivial implementation it simply
  returns the internal access value.
• A weakness of the whole approach is that it
  depends on clients never making a copy or
  otherwise manipulating the access value.
• Limited access types or garbage-collecting
  storage pools would be a helpful addition to the
  language.

46
package body Bool_Exps is ... function ""
(Handle Exp_Handle) return
Bool_Exp_Access is begin return
Handle.Rep.Exp end function Null_Handle
return Exp_Handle is begin return
(Rep gt Controlled with null) end ... end
Bool_Exps
47
Observer
48
Motivation

• Its often the case that when the state changes
  in one object, another object needs to be
  notified of the change. There are a couple of
  ways of implementing this.
• The subject can know who its observers are by
  name, and tell them directly about the state
  change or,

49

• The subject only knows that its being observed.
  It tells its observer that its state has changed,
  and then the observer queries the subject for the
  new state.
• A consequence of the former approach is that
  every time a new observer is added to the system,
  the subject must be modified to update yet
  another observer.
• The latter approach doesnt suffer from this,
  because the observer just inserts itself into a
  list of anonymous observers.

50
package Subjects_And_Observers is type Subject
is tagged limited private procedure
Notify (Sub in out Subject'Class) type
Observer is abstract tagged limited
private procedure Update (Obs access
Observer) is abstract ...
51
... procedure Attach (Obs access
Observer'Class To in out Subject)
procedure Detach (Obs access
Observer'Class From in out
Subject) private ... end Subjects_And_Observe
rs
52
Subjects_And_Observers (public)

• Abstractions that wish to be observed derive from
  Subject. When the state changes, the abstraction
  calls Notify to let observers know about the
  change.
• Abstractions that wish to observe a subject
  derive from Observer, and Attach themselves to a
  subject. They must override Update, which is
  called by the subject during the notification.

53
private type Observer_Access is access
all ObserverClass type Subject is
tagged limited record Head
Observer_Access end record type
Observer is abstract tagged limited record
Next Observer_Access end
record end Subjects_And_Observers
54
Subjects_And_Obsrvrs (private)

• The subject type is implemented as a linked list
  of observers.
• When an observer wants to be notified of a state
  change in the subject, it places itself on the
  subjects list of observers.
• During a notification, the subject traverses the
  list, updating each observer in turn.

55
package body Subjects_And_Observers is
procedure Notify (Sub in out
Subject'Class) is Obs Observer_Access
Sub.Head begin while Obs / null
loop Update (Obs) Obs
Obs.Next end loop end Notify ...
56
package Clock_Timers is type Clock_Timer is
new Subject with private procedure Tick
(Timer in out Clock_Timer) subtype
Hour_Number is Natural range 0 .. 23
function Get_Hour (Timer Clock_Timer)
return Hour_Number ... end Clock_Timers
57
Clock_Timer Subject

• The subject Clock_Timer publicly derives from
  Subject, which allows it to be observed.
• Tick is the operation that updates the state of
  the clock timer, and then notifies any observers.
• Selector operations Get_Hour, Get_Minute, etc
  allow an observer to query the state.

58
Alternate Technique

• Derive from Subject privately, and provide public
  operations to attach an observer.

59
package Clock_Timers is type Clock_Timer is
private procedure Attach (Obs access
ObserverClass To in out
Clock_Timer) private type Clock_Timer is
new Subject with record ...
60
package body Clock_Timers is procedure Tick
(Timer in out Clock_Timer) is begin
ltupdate hour, min, sec attributesgt
Notify (Timer) -- Update observers end
Tick ... end Clock_Timers
61
package Digital_Clocks is type Digital_Clock
(Timer access Clock_Timer'Class) is
new Observer with null record procedure
Update (Clock access Digital_Clock) end
Digital_Clocks
62
Digital_Clock Observer

• The observer Digital_Clock derives from Observer
  type.
• The clock observer binds to its timer subject via
  an access discriminant. This guarantees that the
  (clock) subject lives at least as long as the
  observer, and therefore ensures that no dangling
  references from observer to subject can occur.

63

• Update is called by Notify, which is called by
  the timer subject just after it (the subject) has
  changed its state.
• The clock observer can see its timer subject
  through its access discriminant. During the
  Update, the clock queries the state of the timer,
  and then displays the time in a format specific
  to that observer.

64
package body Digital_Clocks is procedure
Update (Clock access Digital_Clock) is
Hour constant Hour_Number
Get_Hour (Clock.Timer.all) Hour_Image
constant String Integer'Image (Hour)
... Clock_Image constant String
Hour_Image ... begin
Put_Line (Clock_Image) end Update
65
declare Timer aliased Clock_Timer Clock
aliased Digital_Clock (Timer'Access) begin
Attach (ClockAccess, To gt Timer) Tick
(Timer) end
66
Dynamic Observers

• You may have an application in which observers of
  a subject are added and removed dynamically.
• We need to automate calls to Attach and Detach,
  to ensure no dangling reference from subject to
  observer occurs.

67
declare Timer aliased Clock_Timer begin
declare Clock aliased Digital_Clock(Timer
Access) begin Attach (ClockAccess, To gt
Timer) Tick (Timer) end -- Oops!
Forget to Detach... Tick (Timer) -- Notify
non-existent observer! end
68
package Digital_Clocks is type Digital_Clock
(Timer access Clock_Timer'Class) is
limited private private end
Digital_Clocks
69
private 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'Class) is new Observer with
record Control Control_Type
(Digital_Clock'Access) end record
procedure Update (Clock access
Digital_Clock) end Digital_Clocks
70
Adding Controlled-ness

• We dont really need to advertise that
  Digital_Clock derives from Observer, so we
  declare the partial view of the type as limited
  private, and implement the full view as a
  derivation.
• Controlled-ness is added as a component of the
  extension, because Ada doesnt have multiple
  inheritance (and doesnt need it).

71

• During its initialization, the observer inserts
  itself on its subjects observer list.
• During its finalization, the observer removes
  itself from its subjects observer list. This
  guarantees that no dangling reference from
  subject to observer can occur, because removal is
  automatic when the lifetime of the observer ends.

72
package body Digital_Clocks is procedure
Initialize (Control in out Control_Type) is
Clock Digital_Clock renames
Control.Clock.all Timer Clock_Timer
renames Clock.Timer.all begin Attach
(ClockAccess, To gt Timer) end
procedure Finalize (Control in out
Control_Type) is Clock Digital_Clock
renames Control.Clock.all Timer
Clock_Timer renames Clock.Timer.all begin
Detach (Clock'Access, From gt Timer) end
73
declare Timer aliased Clock_Timer begin
declare Clock Digital_Clock
(TimerAccess) -- automatically Attach
begin Tick (Timer) end -- automatically
Detach Tick (Timer) -- OK end
74
Dynamic Observer Note

• This example was rather contrived, and was really
  designed to illustrate how to add Controlled-ness
  to an existing type hierarchy.
• Realistically, a dynamic observer would be
  declared on the heap. In that case, you could
  simply Attach in the constructor, and Detach in
  the deconstructor. A Controlled observer
  wouldnt be necessary.

75
package Digital_Clocks is type
Digital_Clock(ltgt) is limited private function
New_Clock (Timer access Clock_Timer)
return Digital_Clock_Access ... private type
Digital_Clock (Timer access Clock_Timer)
is new Observer with record ...
76
package body Digital_Clocks is function
New_Clock (Timer access Clock_Timer)
return Digital_Clock_Access is Clock
constant Digital_Clock_Access new
Digital_Clock(Timer) begin Attach(Clock,
To gt Timer) return Clock end
77
Subject Displays Itself

• You might argue that a subject should be able to
  display itself, and that providing public
  selector operations to query the state is
  actually exposing implementation details about
  the abstraction.
• In that case, you may decide to make the observer
  more closely related to the subject, so that it
  can privately get the state it needs.

78

• We can do this very simply in Ada95, by making
  the observer a child of the subject. This gives
  the observer access to the private part of the
  subject, obviating the need for the subject to
  provide any public query functions.

79
package Clock_Timers is type Clock_Timer is
limited private procedure Tick (Timer
in out Clock_Timer) private ... type
Clock_Timer is new Subject with record
Hour Hour_Number Minute
Minute_Number Second Second_Number
end record end Clock_Timers
80
Clock_Timer Subject

• Since the Digital_Clock observers are going to be
  children, we can privately derive the Clock_Timer
  subject from Subject.
• Since non-observer clients dont care that its a
  subject, the public view of the Clock_Timer type
  is just (non-tagged) limited private.

81
package Clock_Timers.Digital_Clocks is type
Digital_Clock (Timer access Clock_Timer)
is limited private private ... type
Digital_Clock (Timer access Clock_Timer)
is new Observer with null record
Control Control_Type (D_ClockAccess) end
record procedure Update (Clock
access Digital_Clock) end Clock_Timers.Digital_C
locks
82
Digital_Clock Observer

• The package Digital_Clocks is now a (public)
  child of Clock_Timers.
• As before, the Digital_Clock type privately
  derives from Observer.
• Update now queries the state of the timer
  directly, without using a query function. The
  clock has visibility to its subjects
  representation because the clock is a child.

83
package body Clock_Timers.Digital_Clocks is
procedure Update (Clock access
Digital_Clock) is Hour_Image constant
String Integer'Image (Clock.Timer.Hour
100) ... Clock_Image constant
String ... begin Put_Line
(Clock_Image) end Update end
Clock_Timers.Digital_Clocks
84
Observers Observed

• We now introduce another variation of our
  original example, which allows an observer itself
  to be observed, by another observer.
• As before, a Digital_Clock observes a
  Clock_Timer. Here, we add another observer, a
  Clock_Watcher, to observe the Digital_Clock.

85
package Digital_Clocks is type Digital_Clock
(Timer access Clock_Timer'Class) is
new Subject with private type Meridian_Type
is (AM, PM) function Get_Meridian (Clock
Digital_Clock) return Meridian_Type private

86
Digital_Clock (public)

• The Digital_Clock must announce the fact that it
  can be observed, so it publicly derives from
  Subject.
• But its also an observer, so it binds to its
  Clock_Timer subject via an access discriminant.
• Like any subject, the Digital_Clock provides
  selector operations to allow its state to be
  queried by observers.

87
type Timer_Obs_Type (Clock access
Digital_Clock) is new Observer with null
record procedure Update (Timer_Obs access
Timer_Obs_Type) type Control_Type (Clock
access Digital_Clock) is new
Limited_Controlled with record Timer_Obs
aliased Timer_Obs_Type (Clock) end
record procedure Initialize (Control in
out Control_Type) procedure Finalize
(Control in out Control_Type) type
Digital_Clock (Timer access Clock_Timer'Class)
is new Subject with record Control
Control_Type (Digital_Clock'Access)
Meridian Meridian_Type end record end
Digital_Clocks
88
Digital_Clock (private)

• The Digital_Clock already derives from Subject,
  so in order to be an observer too it will have to
  have an Observer component.
• A helper type, Timer_Obs_Type, which derives from
  Observer, is used as the component.
• Here we also use a Controlled type to
  automatically Attach and Detach the observer.
  This wouldnt be necessary if you were to
  manually Attach to the subject.

89
package body Digital_Clocks is procedure
Initialize (Control in out Control_Type)
is begin Attach (Obs gt
Control.Timer_Obs'Access, To gt
Control.Clock.Timer.all) end procedure
Finalize (Control in out Control_Type)
is begin Detach (Obs gt
Control.Timer_Obs'Access, From gt
Control.Clock.Timer.all) end
90

• The Control_Type can see its enclosing record
  (Digital_Clock) via its access discriminant.
• The Digital_Clock observer can see its
  Clock_Timer subject via its access discriminant.
• Together, these allow the Control_Type to Attach
  its Timer_Obs component to the Timer subject
  during Initialize, and Detach it during Finalize.

91
procedure Update (Timer_Obs access
Timer_Obs_Type) is begin ltget time from
Timer_Obs.Clock.Timer.allgt ltdisplay new
timegt if Hour lt 12 then
Timer_Obs.Clock.Meridian AM else
Timer_Obs.Clock.Meridian PM end if
Notify (Timer_Obs.Clock.all) end
Update end Digital_Clocks
92

• As an observer, the Clock_Timer (really, the
  Timer_Obs_Type) must provide an implementation of
  Update.
• Update displays the new time (plays its observer
  role), then updates its own state and Notifys
  its own observers (plays its subject role).
• This organization has the effect of propagating a
  signal all the way back from the ultimate subject
  to the ultimate observer.

93
Clock_Watcher

• A very simple observer that observes a
  Digital_Clock.
• Per the idiom, it binds to its subject via an
  access discriminant.
• Here we manually Attach and Detach to the
  subject, instead of using Controlled-ness to do
  it automatically.

94
package Clock_Watchers is type Clock_Watcher
(Clock access Digital_Clock'Class) is
limited private procedure
Start_Watching_Clock (Watcher access
Clock_Watcher) procedure Stop_Watching_Clock
(Watcher access Clock_Watcher) private
type Clock_Watcher (Clock access
Digital_Clock'Class) is new Observer with
null record procedure Update (Watcher
access Clock_Watcher) end Clock_Watchers
95
package body Clock_Watchers is procedure
Start_Watching_Clock (Watcher access
Clock_Watcher) is begin Attach (Watcher,
To gt Watcher.Clock.all) end procedure
Stop_Watching_Clock (Watcher access
Clock_Watcher) is begin Detach (Watcher,
From gt Watcher.Clock.all) end ...
96
... procedure Update (Watcher
access Clock_Watcher) is begin case
Get_Meridian (Watcher.Clock.all) is when
AM gt Put_Line ("It's still
morning.") when PM gt
Put_Line ("It's afternoon.") end case
end Update end Clock_Watchers
97
declare Timer aliased Clock_Timer
Clock aliased Digital_Clock (Timer'Access)
Watcher aliased Clock_Watcher
(Clock'Access) begin Start_Watching_Clock
(Watcher) Tick (Timer) end
98
Observable-Observer Note

• There is another way to allow an observer to be
  both an observer and a subject.
• Simply change the declaration of Observer type in
  package Subjects_And_Observers so that it derives
  from Subject.
• Implementing the observing subject with an
  observer component isnt necessary, because the
  type is already an observer.

99
package Subjects_And_Observers is type
Subject is tagged limited private ...
type Observer is abstract new Subject with
private ... end Subjects_And_Observers
100
package Digital_Clocks is type Digital_Clock
(Timer access C_Timer'Class) is new
Subject with private ... private type
Control_Type (Clock access Digital_Clock) is
new Limited_Controlled with null record
... type Digital_Clock (Timer access
C_Timer'Class) is new Observer with record
Control Control_Type (D_Clock'Access)
Meridian Meridian_Type end
record procedure Update (Clock access
Digital_Clock) end Digital_Clocks
101
Observing Multiple Subjects

• We introduce yet another variation of the
  observer pattern, this time allowing an observer
  to observe multiple subjects.
• Now the digital clock simultaneously observes
  both a timer and a battery. The battery subject
  notifies its observer when it is drained or
  charged.

102
package Batteries is type Battery_Type is
new Subject with private procedure Charge
(...) procedure Drain (...) function
Is_Low (...) return Boolean private type
Battery_Type is new Subject with record
State Positive 1 end record
103
Battery Subject (spec)

• The battery is observable, asserting this by
  publicly deriving from Subject.
• Modifier operations Charge and Drain adjust the
  available energy, and then Notify any observers.
• A selector operation, Is_Low, queries whether
  there is any energy remaining.

104
package body Batteries is procedure Charge
(Battery in out Battery_Type) is begin
Battery.State 1 Notify (Battery)
end procedure Drain (Battery in out
Battery_Type) is begin Battery.State
Battery.State 1 Notify (Battery)
end function Is_Low (Battery in
Battery_Type) return Boolean is begin
return Battery.State gt 3 end
105
package Digital_Clocks is type Digital_Clock
(Timer access Clock_Timer'Class
Battery access Battery_Type'Class) is
limited private private ... end
Digital_Clocks
106
Digital_Clock (public)

• The public part of the observer type
  Digital_Clock has been modified to accept two
  access discriminants, one for each subject it
  observes.

107
private type Timer_Obs_Type (Clock
access Digital_Clock) is new Observer with
null record procedure Update (Observer
access Timer_Obs_Type) type Battery_Obs_Type
(Clock access Digital_Clock) is new
Observer with null record procedure Update
(Observer access Battery_Obs_Type) ...
108
... type Digital_Clock (Timer
access Clock_Timer'Class Battery access
Battery_Type'Class) is new
Limited_Controlled with record Timer_Obs
aliased Timer_Obs_Type
(D_Clock'Access) Battery_Obs
aliased Battery_Obs_Type (D_Clock'Access)
end record procedure Initialize (Clock in
out Digital_Clock) procedure Finalize (Clock
in out Digital_Clock) end Digital_Clocks
109
Digital_Clock (private)

• There has to be some type that derives from
  Observer and overrides Update to process
  Clock_Timer notifications.
• There has to be some type that derives from
  Observer and overrides Update to process
  Battery_Type notifications.
• The same type cant do both, because we dont
  have multiple inheritance in Ada95. No problem,
  we just use the multiple views idiom.

110

• An internal type, Timer_Obs_Type, observes just
  the Clock_Timer.
• Another internal type, Battery_Obs_Type, observes
  just the Battery_Type.
• Each type is bound to its enclosing record, the
  Digital_Clock, via an access discriminant.
• These internal types will be used to declare the
  observer components of the Digital_Clock type,
  which itself already derives from
  Limited_Controlled.

111
package body Digital_Clocks is procedure
Update (Observer access Timer_Obs_Type)
is procedure Update (Observer
access Battery_Obs_Type) is Clock
Digital_Clock renames Observer.Clock.all
Battery Battery_Type'Class renames
Clock.Battery.all begin if Is_Low
(Battery) then ... end Update
112
procedure Initialize (Clock in out
Digital_Clock) is begin Attach (Obs gt
Clock.Timer_Obs'Access, To gt
Clock.Timer.all) Attach (Obs gt
Clock.Battery_Obs'Access, To gt
Clock.Battery.all) end Initialize
113
Observing Multiple Attributes

• One issue is that when a subject notifies an
  observer that a state change has occurred, the
  observer has no way of knowing which specific
  attribute has changed.
• This may require the observer to redo all her
  processing (say, redraw a window), which may be
  inefficient.

114

• One solution is to make observation more
  fine-grained that is, to be able to observe
  individual attributes of a object, instead of
  just one monolithic object.
• When an object being observed changes the value
  of an attribute, he can notify the observers of
  that one attribute.
• Its analogous to observing multiple subjects,
  but here, all the subjects are part of a single
  object.

115
package Clock_Timers is type Clock_Timer is
limited private ... 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
116
... private type Clock_Timer is
limited record Hour Integer
-1 Hour_Subject aliased Subject
Minute Integer -1
Minute_Subject aliased Subject Second
Integer -1 Second_Subject
aliased Subject end record end
Clock_Timers
117
package body Clock_Timers is procedure Tick
(Timer in out Clock_Timer) is begin
ltupdate timegt if Timer.Hour / Hour
then Timer.Hour Hour
Notify (Timer.Hour_Subject) end if
... end Tick
118
function Get_Hour_Subject (Timer access
Clock_Timer) return Subject_Access is
begin return Timer.Hour_Subject'Access
end
119
package Digital_Clocks is type Digital_Clock
(Timer access Clock_Timer) is limited
private private type H_Obs_Type (Timer
access Clock_Timer) is new Observer with
null record procedure Update (H_Obs
access H_Obs_Type) ... type Digital_Clock
(Timer access Clock_Timer) is new
Limited_Controlled with record H_Obs
aliased H_Obs_Type (Timer) ... end
record ...
120
package body Digital_Clocks is procedure
Update (H_Obs access H_Obs_Type) is
Image constant String Integer'Image
(Get_Hour (H_Obs.Timer) 100) begin
ltdisplay hourgt end procedure Initialize
(Clock in out Digital_Clock) is
begin Attach (Obs gt
Clock.H_Obs'Access, To gt
Get_Hour_Subject (Clock.Timer))
121
Factory Method
122
Motivation

• Suppose we have a family of stack types, and we
  want to provide a class-wide operation to print a
  stack.
• We plan on using an active iterator to implement
  the operation. Each type in the class has its
  own iterator.
• Heres the problem if the stack parameter has a
  class-wide type, then how do we get an iterator
  that works for this stack object?

123
procedure Stacks.Put (Stack in
Root_Stack_TypeClass) is Iterator ltwhats
its type?gt lthow do we get one for Stacks
type?gt begin while not Is_Done (Iterator)
loop ...
124
What's A Factory Method?

• If you need an iterator for this type of stack,
  then just ask the stack for one.
• A factory method is a constructor that
  dispatches on one type, and returns a value of
  some other type.
• In Ada95, the return type has to be classwide,
  since an operation can only be primitive for one
  type.

125
generic type Item_Type is private package
Stacks is type Root_Stack_Type is
abstract tagged limited null record type
Root_Iterator_Type is abstract tagged null
record -- Heres the factory method --
function Start_At_Top (Stack
Root_Stack_Type) return Root_Iterator_Type'Cl
ass is abstract
126
procedure Stacks.Put (Stack in
Root_Stack_TypeClass) is Iterator
Root_Iterator_TypeClass Start_At_Top
(Stack) begin while not Is_Done (Iterator)
loop Get_Item (Iterator) Advance
(Iterator) end loop New_Line end
Stacks.Put
127
generic Max_Depth in Positive package
Stacks.Bounded_G is type Stack_Type is
new Root_Stack_Type with private type
Iterator_Type is new Root_Iterator_Type
with private function Start_At_Top
(Stack Stack_Type) return
Root_Iterator_Type'Class
128
Copying A Stack

• Requires care, because its easy to populate the
  target stack in reverse order.
• You can either (1) traverse the items in the
  source stack in bottom-to-top order, and populate
  the target stack in the normal way (using Push)
  or,
• You can (2) traverse the items in the source
  stack in top-to-bottom order, and populate the
  target stack in reverse order, using a special
  operation (like Copy).

129
procedure Copy_That_Does_Not_Work (From in
Root_Stack_TypeClass To in out
Root_Stack_TypeClass) is Iter
Root_Iterator_TypeClass Start_At_Top
(From) begin if ltFrom and To are the same
stackgt then return end if Clear
(To) while not Is_Done (Iter) loop Push
(Get_Item (Iter), On gt To) Advance
(Iter) end loop end Copy_That_Does_Not_Work
130
procedure Stacks.Copy -- technique (1) (From
in Root_Stack_TypeClass To in out
Root_Stack_TypeClass) is Iterator
Root_Iterator_TypeClass Start_At_Bottom
(From) begin if FromAddress ToAddress
then -- per RM95 3.10 (9) and 13.3 (16)
return end if Clear (To) while not
Is_Done (Iterator) loop Push (Get_Item
(Iterator), On gt To) Backup (Iterator)
end loop end Stacks.Copy
131
package body Stacks.Bounded_G is procedure
Copy -- technique (2) (From in
Root_Stack_Type'Class To in out
Stack_Type) is Depth constant Natural
Get_Depth (From) Iterator
Root_Iterator_Type'Class Start_At_Top
(From) use type System.Address begin
...
132
... if From'Address To'Address
then return end if if
Depth gt Max_Depth then raise
Storage_Error end if To.Top
Depth for I in reverse 1 .. Depth loop
To.Items (I) Get_Item (Iterator)
Advance (Iterator) end loop end Copy
133
Summary of Stack Copying

• Technique (1) requires that you be able to
  traverse stacks in reverse order.
• Technique (1) can be implemented as a class-wide
  operation, or as a primitive operation with a
  default implementation.
• Technique (2) must be implemented as a primitive
  operation, for each type, because it needs to
  know the types representation.

134
Singleton
135
Using a State Machine Package

• The package itself is the object an instance of
  an anonymous type.
• State data is declared in the package body and
  manipulated via public operations.
• Popular in Ada because static-ness is the default
  for objects and operations.

136
with Ownship_Types use Ownship_Types package
Ownship is procedure Update function
Get_Speed_In_Knots return
Speed_In_Knots_Type function
Get_Heading_In_Deg return
Heading_In_Deg_Type procedure Set_Heading
(Heading in Heading_In_Deg_Type) ...
end Ownship
137
with Ownship package body P is procedure
Op is Ownship_Speed constant
Speed_In_Knots_Type
Ownship.Get_Speed_In_Knots begin ltdo
something with speedgt end Op
138
Using a Named Type

• Instance creation can be controlled by the
  abstraction by declaring the type as limited and
  indefinite.
• The (single) instance of the type is declared in
  the package body.
• A public operation returns an access object
  designating the singleton instance.
• All operations of the type take access parameters
  (so no explicit deref is reqd).

139
package Ownships is type Ownship_Type (ltgt) is
limited private function Get_Speed_In_Knots
(Ownship access Ownship_Type) return
Speed_In_Knots_Type ... type
Ownship_Access is access all
Ownship_Type function Ownship return
Ownship_Access private type Ownship_Type is
end Ownships
140
with Ownships use Ownships package body P
is procedure Op is Ownship_Speed
constant Speed_In_Knots_Type
Get_Speed_In_Knots (Ownship) begin ltdo
something with speedgt end Op
141
package body Ownships is function
Get_Speed_In_Knots (Ownship access
Ownship_Type) return Speed_In_Knots_Type
is begin return Ownship.Speed end
... Singleton aliased Ownship_Type
function Ownship return Ownship_Access is
begin return Singleton'Access end end
Ownships
142
Well-Known Objects

• Well-known objects are global abstractions that
  have a defined cardinality.
• They tend to be passive holders of systemwide
  state.
• A singleton is a well-known object whose
  cardinality happens to be 1.
• Use a discrete identifier to refer to a specific
  instance.

143
with Rodmeter_Types use Rodmeter_Types package
Rodmeters is type Rodmeter_Id is range 1 ..
2 procedure Update (Rodmeter in
Rodmeter_Id) function Get_Speed_In_Knots
(Rodmeter Rodmeter_Id) return
Speed_In_Knots_Type procedure Set_Bias
(Rodmeter in Rodmeter_Id Bias in
Bias_In_Knots_Type) function Get_Bias
(Rodmeter Rodmeter_Id) return
Bias_In_Knots_Type end Rodmeters
144
with Ownships, Ownship_Types package body
Rodmeters is type Speed_Array_Type is
array (Rodmeter_Id) of Speed_In_Knots_Type
Speed_Array Speed_Array_Type type
Bias_Array_Type is array (Rodmeter_Id) of
Bias_In_Knots_Type Bias_Array
Bias_Array_Type ...
145
function Get_Speed_In_Knots (Rodmeter
Rodmeter_Id) return Speed_In_Knots_Type
is begin return Speed_Array (Rodmeter)
end procedure Set_Bias (Rodmeter in
Rodmeter_Id Bias in
Bias_In_Knots_Type) is begin Bias_Array
(Rodmeter) Bias end function
Get_Bias (Rodmeter Rodmeter_Id)
return Bias_In_Knots_Type is begin
return Bias_Array (Rodmeter) end
146
procedure Update (Rodmeter in
Rodmeter_Id) is OS_Speed constant
OS_Types.Speed_In_Knots_Type
Get_Speed_In_Knots (Ownship)
Speed Speed_In_Knots_Type'Base
Speed_In_Knots_Type'Base (OS_Speed)
Speed_In_Knots_Type'Base (Bias_Array
(Rodmeter)) begin if Speed lt 0.0
then Speed 0.0 elsif Speed gt
Speed_In_Knots_Type'Last then Speed
Speed_In_Knots_Type'Last end if
Speed_Array (Rodmeter) Speed end Update
147
package TCP.States is type Root_State_Type
(ltgt) 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 Transmit (State access
Root_State_Type Connection in out
Root_Connection_Type'Class Item in
Stream_Element_Array) ...
148
package TCP.States.Listen is 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
149
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
... Set_State (Connection,
Established.State) end Send function
State return State_Access is begin
return Singleton'Access end end
TCP.States.Listen
150
package TCP.Connections is type
Connection_Type is limited private
... private 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
151
Strategy
152
Whats A Strategy?

• The simple answer a fancy name for a generic
  formal subprogram.
• Its a way to parameterize a component.
• You effect different behavior by plugging in a
  different algorithm (the strategy).

153
generic type Item_Type is limited
private package Storage_Nodes is type
Storage_Node type Storage_Node_Access is
access all Storage_Node type Storage_Node
is limited record Item aliased
Item_Type Next Storage_Node_Access
end record procedure Do_Nothing
(Node in out Storage_Node) end Storage_Nodes
154
with Storage_Nodes generic with package
Nodes is new Storage_Nodes (ltgt) use Nodes
with procedure Finalize (Node in out
Storage_Node) is Do_Nothing package Storage
is function New_Node return
Storage_Node_Access procedure Free (Node
in out Storage_Node_Access) end Storage
155
package body Storage is Free_List
Storage_Node_Access function New_Node return
Storage_Node_Access is ... procedure Free
(Node in out Storage_Node_Access) is begin
if Node null then return
end if Finalize (Node.all)
Node.Next Free_List Free_List Node
Node null end Free end Storage
156
with Storage_Nodes generic type Item_Type is
private package Unbounded_Stacks is type
Stack_Type is limited private ... private
package Nodes is new Storage_Nodes (Item_Type)
use Nodes type Stack_Type is limited
record Top Storage_Node_Access
end record end Unbounded_Stacks
157
with Storage package body Unbounded_Stacks is
package Stack_Storage is new Storage (Nodes)
use Stack_Storage procedure Pop (Stack
in out Stack_Type) is Node
Storage_Node_Access Stack.Top begin
Stack.Top Stack.Top.Next Free (Node)
end Pop end Unbounded_Stacks
158
with Storage_Nodes generic type Item_Type is
private package Lists is type List_Type is
private procedure Clear (List in out
List_Type) private package Nodes is new
Storage_Nodes (Item_Type) use Nodes type
List_Type is record Head
Storage_Node_Access end record end Lists
159
with Storage package body Lists is
procedure Finalize (Node in out
Storage_Node) package List_Storage is new
Storage (Nodes, Finalize) use List_Storage
procedure Finalize (Node in out Storage_Node)
is begin Free (Node.Next) end
... procedure Clear (List in out List_Type)
is begin Free (List.Head) end end
Lists
160
Generic Dispatching
161
Motivation

• Suppose we want to import, as generic formal
  parameters, a tagged type and one of its
  primitive operations, and we want dynamically
  dispatch the operation inside the generic.
• The problem is that you cant dispatch on a
  formal subprogram, because a formal subprogram
  isnt primitive for a formal type.

162
package P is type T is tagged limited
private procedure Op (O in out T)
end P package P.C is type NT is new T
with private procedure Op (O in out NT)
end P.C
163
generic type T (ltgt) is abstract tagged
limited private with procedure Op (O
in out T) is ltgt package GQ is procedure
Do_Something (O in out T'Class) end GQ
164

• Heres what we want to do

with P, GQ package Q is new GQ (T gt P.T, Op
gt P.Op)
165
package body GQ is procedure Do_Something
(O in out T'Class) is begin Op (O)
--heres the offending line end end
GQ gq.adb610 class-wide argument not
allowed here gq.adb610 "Op" is not a primitive
operation of "T"
166

• The problem is that the compiler has no way of
  knowing (at the time of compilation of the
  generic) that formal procedure Op is really
  primitive for type T. So it assumes the worst,
  and doesnt allow you to dispatch on a formal
  operation.
• The actual operation we import must be statically
  bound to T. What we can do is import the
  class-wide type, TClass, and import a class-wide
  operation (that takes an object of type TClass)
  that calls the (primitive) dispatching operation.
  

167
Changes to Client

• Implement a new, class-wide operation (as a
  child, if you dont have it already)

procedure P.Call_Op (O in out T'Class)
is begin Op (O) -- dispatches end
168
Changes to Server

• Declare the formal type as non-tagged and
  indefinite. This allows a class-wide type to be
  used as the generic actual.
• In the generic operations, declare the formal
  parameters to be of type T instead of TClass.
  (This is required anyway, because the formal type
  isnt tagged anymore.)

169
generic type T (ltgt) is limited
private with procedure Op (O in out T)
is ltgt package GQ is procedure Do_Something
(O in out T) end GQ
170
package body GQ is procedure Do_Something
(O in out T) is begin ... Op (O)
-- legal (static call) ... end end GQ
171
Changes to Instantiation

• Now lets instantiate the new version of the
  generic using TClass as the actual type, and our
  special class-wide operation as the actual
  operation

with GQ, P.Call_Op package Q is new GQ
(P.T'Class, P.Call_Op)
172
with P.C, Q procedure Test_Q is OT P.T
-- T is root of class ONT P.C.NT -- NT
derives from T begin Q.Do_Something (OT)
-- call Ts Op Q.Do_Something (ONT) -- call
NTs Op end Test_Q
173
The Rosen Trick
174
Ada I/O Model

• A communication path, such as disk I/O, socket
  I/O, etc, is modeled as a file.
• You open the file to establish communication
  with a device.
• You close the file to sever the connection to
  the device.

175

• The communication path to a device is
  represented as a handle, which designates
  connection state. The state may change, but the
  handle itself does not.

176
package Files is type File_Type is limited
private procedure Open(File in out
File_Type Name in
String) procedure Close(File in out
File_Type) procedure Read(File in
File_Type Item out
Item_Type) procedure Write(File in
File_Type Item in Item_Type)
177
Issue

• Read and Write are state-changing operations, yet
  the File object (the handle) is passed as an
  in-mode parameter.
• How to we implement File_Type in order to
  implement this model?

178
Use the Heap
private type Connection_State type
File_Type is access all Connection_State e
nd Files
179
Use the Heap (contd)
procedure Open (File in out File_Type
Name in String) is begin File
new Connection_State ... end Open procedure
Write (File in File_Type ...) is begin
File.all ... end
180
Use the Heap Consequences

• Well, requires heap use. In general, if given a
  choice, wed rather use the stack.
• The declaration of a named access type means you
  cant declare the package using pragma Pure.
• In order to prevent memory leaks, you have to
  implement File_Type as controlled. This adds a
  certain amount of heaviness.

181
Use Static Allocation
private type File_Type is limited record
Index Natural 0 end record end
Files
182
Use Static Allocation (contd)
package body Files is type Descriptor_Type is
... Descriptors array (1 .. 20) of
Descriptor_Type procedure Open (File in out
File_Type ...) is begin
File.Index Get_Descriptor_Index
183
Static Allocation Consequences

• Limits number of file objects (although theres
  probably a system-defined limit anyway).
• Having package state means you wont be able to
  declare the package using pragma Pure.

184
Use Chapter 13 Tricks
private type File_Type is limited record
ltconnection stategt end record end
Files
185
Chapter 13 (contd)
package body Files is package
Address_To_Access_Conversions is new
System.Addr_To_Acc_Conversions... procedure
Write (File in File_Type
...) is FA const Object_Pointer
To_Pointer(FileAddress) F File_Type
renames FA.all begin
186
Chapter 13 Consequences

• Using Address turns off type-checking.

187
The Rosen Trick

• A clean way to modify a limited (byreference)
  in-mode subprogram parameter, that doesnt
  require any Chap 13 tricks.
• Allocate memory for the handle directly adjacent
  to the connection state, on the stack. No
  package state is necessary.

188
generic type Result_Subtype is (ltgt) package
Ada.Numerics.Discrete_Random is type
Generator is limited private function Random
(Gen Generator) return Result_Subtype ...
private type Handle_Type (Gen access
Generator) is limited null record type
Generator is limited record Handle
Handle_Type (GeneratorAccess)
Gen_State State end record
189
function Random (Gen Generator) return
Result_Subtype is Gen_State State renames
Gen.Handle.Gen.Gen_State begin ltmodify
Gen_State as necessarygt