In the Bool_Exp types used to illustrate the Interpreter pattern, I had
added a primitive operation to return the image of a Boolean expression,
because it was useful for debugging:
type Bool_Exp is abstract tagged limited private;
...
function Get_Image (Exp : access Bool_Exp) return String;
It occurred to me that I could use the Visitor pattern to implement the
Image function, so that I wouldn't have to make it primitive.
To use a visitor, we must extend to class with an Accept_Visitor
operation:
package Bool_Exps is
type Bool_Exp (<>) is
abstract tagged limited private;
...
type Visitor_Type is abstract tagged limited null record;
procedure Accept_Visitor
(Exp : access Bool_Exp;
Visitor : in out Visitor_Type'Class) is abstract;
private
...
end Bool_Exps;
Accept_Visitor is primitive for Bool_Exp types, so it takes Bool_Exp as
an access parameter. Visitor_Type must be passed as a class-wide
parameter, since an operation can only be primitive for one type.
The only operation a client cares about is Accept_Visitor, so that one
is declared publicly. There are of course primitive operations for
types in the Visitor_Type class, but we declare these as private
operations, because they are never called by clients:
package Bool_Exps is
...
private
...
procedure Visit_And_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Or_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Not_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Const_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Var_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
end Bool_Exps;
There is one Visit_<exp> operation for each expression type, which is
overridden by types that derive from Visitor_Type. Here, they're given
default implementations that do nothing. (They can't be declared
abstract if they're private operations.)
You can see immediately the problem with the Visitor pattern: you have
to anticipate all the types in the class up front, during the
declaration of the abstract root type.
If you were to add another type to the Bool_Exp class, you'd have to go
in and modify the root package of the subsystem (package Bool_Exps) to
add another Visit operation for the new type, which would force a
recompilation of the ENTIRE subsystem.
So any volatility in the class has a potentially steep recompilation
cost. This is why the Visitor pattern is only appropriate for stable
hierarchies.
Each type in the Bool_Exp class overrides Accept_Visitor, and implements
it by calling the Visit_<exp> operation for that type. For example, the
And_Exp type implements Accept_Visitor this way:
package body Bool_Exps.And_Exps is
...
procedure Accept_Visitor
(Exp : access And_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_And_Exp (Visitor, Exp);
end;
end Bool_Exps.And_Exps;
This shows how you fake double-dispatching in a single-dispatching
language.
Really, you want to dispatch on both Bool_Exp and Visitor_Type, but
that's illegal, because an operation can be primitive for only one type.
So what you do is dispatch once on Bool_Exp (Accept_Visitor), and then
dispatch again on Visitor_Type (Visit_<exp>). Voila! Double
dispatching.
Ultimately, what we want is the operation:
function Bool_Exps.Get_Image
(Exp : access Bool_Exp'Class) return String;
We're going to implement it by creating an Image_Visitor:
private package Bool_Exps.Image_Visitors is
type Image_Visitor is
new Visitor_Type with private;
function Get_Image
(Visitor : Image_Visitor) return String;
...
end Bool_Exps.Image_Visitors;
The Image_Visitors package is declared as a private package, since we
don't we clients to call that package directly (although it would be
harmless to let them). We want clients to use the Bool_Exp class-wide
image function, which has a trivial implementation:
with Bool_Exps.Image_Visitors; use Bool_Exps.Image_Visitors;
function Bool_Exps.Get_Image
(Exp : access Bool_Exp'Class) return String is
Visitor : Image_Visitor;
begin
Accept_Visitor (Exp, Visitor);
return Get_Image (Visitor);
end;
The Image_Visitor type overrides the Visit_<exp> operations:
private package Bool_Exps.Image_Visitors is
...
private
type Image_Visitor is
new Visitor_Type with record
Image : String (1 .. 100); -- should use Unbounded_Strings
Length : Natural := 0;
end record;
procedure Visit_And_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Or_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Not_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Const_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Var_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
end Bool_Exps.Image_Visitors;
Each of the Image_Visitor Visit operations is implemented by returning
the image of that particular Boolean expression. For example, an
And_Exp has an image that looks like:
"(<image of left exp> and <image of right exp>)"
Clearly, some kind of recursion is necessary, because an and-exp doesn't
know the specific type of its left and right expression components. Any
expression that contains subexpressions will ultimately have to be
implemented using an Image_Visitor.
The immediate problem is, How do you implement a Visit operation?
Boolean expression types don't export any selector functions to let you
query the value of the subexpression (e. g. to determine the value of
the left expression of an and-exp).
The solution is to implement a (non-primitive) Get_Image operation as a
child of the package in which each Boolean expression type is declared.
For example,
function Bool_Exps.And_Exps.Get_Image
(Exp : access And_Exp) return String;
We can use the class-wide Get_Image to implement the Get_Image function
for a specific type:
with Bool_Exps.Get_Image;
function Bool_Exps.And_Exps.Get_Image
(Exp : access And_Exp) return String is
begin
return
'(' &
Get_Image (Exp.L) &
" and " &
Get_Image (Exp.R) &
')';
end Bool_Exps.And_Exps.Get_Image;
The Get_Image function for each specific Boolean expression type is
implemented similarly.
Now that we have a functions to get the image of each kind of Boolean
expression, we use them to implement the Visit operations for
Image_Visitor.
The algorithm is the same for all Visit operations:
procedure Visit_<exp>
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) is
<downcast Exp to <exp> type>
<call the Get_Image function for <exp> type>
begin
<set the Image and Length components of Visitor>
end Visit_<exp>;
Since the algorithm is the same for each expression, and only the type
changes, we can write a little local generic that we instantiate for
each type.
with Bool_Exps.And_Exps.Get_Image; use Bool_Exps.And_Exps;
with Bool_Exps.Or_Exps.Get_Image; use Bool_Exps.Or_Exps;
...
package Bool_Exps.Image_Visitors is
...
generic
type Exp_Type (<>) is
abstract new Bool_Exp with private;
with function Get_Image
(Exp : access Exp_Type) return String is <>;
procedure Visit_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) is
Image : constant String :=
Get_Image (Exp_Type (Exp.all)'Access);
begin
Visitor.Image (1 .. Image'Length) := Image;
Visitor.Length := Image'Length;
end Visit_Exp;
...
end Bool_Exps.Image_Visitors;
We have to declare the body of the generic prior to making any
instantiations; otherwise, Program_Error will be raised during
elaboration of Image_Visitors.
We instantiate the generic once for each Boolean expression, and then
implement the Visit_<exp> operation as a renaming of the instantiation.
For example:
procedure Do_Visit_And_Exp is
new Visit_Exp (And_Exp);
procedure Visit_And_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_And_Exp;
procedure Do_Visit_Or_Exp is
new Visit_Exp (Or_Exp);
procedure Visit_Or_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_Or_Exp;
...
end Bool_Exps.Image_Visitors;
That's basically it. To show how this works, let's declare a Boolean
expression and get its image:
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'))));
begin
Put_Line (Get_Image (Exp));
end;
This has the output:
((TRUE and X) or (Y and not X))
Let's replace each X variable with the expression "Z or False":
declare
<as above>
begin
...
Exp :=
Replace (Exp, 'X', New_Or (New_Var ('Z'), New_Const (False)));
Put_Line (Get_Image (Exp));
end;
This has the output:
((TRUE and (Z or FALSE)) or (Y and not (Z or FALSE)))
Bonus:
Ada95 Tip O' The Day: There is a clean way to change the state of
an in-mode subprogram parameter, whose type is limited, without having
to rely on RM95 13.3 (16).
It's called the "Rosen Trick," in honor of Jean-Pierre Rosen. What you
do is refer to the object indirectly, through an access discriminant.
This gives you a variable view of the object.
Let's use the Rosen Trick to implement the random number generator:
package Discrete_Random is
type Generator is limited private;
function Random (Gen : Generator) -- in-mode!
return Result_Subtype;
private
type Handle_Type (Gen : access Generator) is
limited null record;
type Generator is
limited record
Handle : Handle_Type (Generator'Access);
Gen_State : State;
end record;
end Discrete_Random;
To implement function Random, you do this:
function Random (Gen : Generator) return Result_Subtype is
Gen_State : State renames Gen.Handle.Gen.Gen_State;
begin
<modify Gen_State is necessary>
return <random number>;
end;
When you look at the Gen object through the Handle's access
discriminant, you get a variable view, which allows to you to modify the
generator object's state.
You can only use this for types whose full view is limited, but that's
not much of a limitation, because most of the time you declare ADTs as
limited anyway.
The code below was compiled on 15 Oct 1999, using GNAT v3.11p, on
LinuxPPC R4.
--STX
with Bool_Exps.Get_Image;
function Bool_Exps.And_Exps.Get_Image
(Exp : access And_Exp) return String is
begin
return
'(' &
Get_Image (Exp.L) &
" and " &
Get_Image (Exp.R) &
')';
end Bool_Exps.And_Exps.Get_Image;
function Bool_Exps.And_Exps.Get_Image
(Exp : access And_Exp) return String;
with Bool_Exps.Storage;
pragma Elaborate (Bool_Exps.Storage);
package body Bool_Exps.And_Exps is
package And_Exp_Storage is
new Storage (And_Exp);
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;
function New_And
(L, R : access Bool_Exp'Class)
return Bool_Exp_Access is
use And_Exp_Storage;
Exp : constant Exp_Access := New_Exp;
begin
Exp.L := Bool_Exp_Access (L);
Exp.R := Bool_Exp_Access (R);
return Bool_Exp_Access (Exp);
end New_And;
function Copy
(Exp : access And_Exp)
return Bool_Exp_Access is
begin
return New_And (L => Copy (Exp.L), R => Copy (Exp.R));
end;
function Replace
(Var : access And_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is
L : constant Bool_Exp_Access := Replace (Var.L, Name, Exp);
R : constant Bool_Exp_Access := Replace (Var.R, Name, Exp);
begin
return New_And (L, R);
end;
procedure Accept_Visitor
(Exp : access And_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_And_Exp (Visitor, Exp);
end;
procedure Finalize (Exp : access And_Exp) is
begin
Free (Exp.L);
Free (Exp.R);
end Finalize;
procedure Do_Free (Exp : access And_Exp) renames
And_Exp_Storage.Do_Free;
end Bool_Exps.And_Exps;
package Bool_Exps.And_Exps is
pragma Preelaborate;
type And_Exp is new Bool_Exp with private;
function Eval
(Exp : access And_Exp;
Context : in Exp_Context) return Boolean;
function New_And
(L, R : access Bool_Exp'Class)
return Bool_Exp_Access;
function Copy
(Exp : access And_Exp)
return Bool_Exp_Access;
function Replace
(Var : access And_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access;
procedure Accept_Visitor
(Exp : access And_Exp;
Visitor : in out Visitor_Type'Class);
private
type And_Exp is
new Bool_Exp with record
L, R : Bool_Exp_Access;
end record;
procedure Finalize (Exp : access And_Exp);
procedure Do_Free (Exp : access And_Exp);
end Bool_Exps.And_Exps;
function Bool_Exps.Const_Exps.Get_Image
(Exp : access Const_Exp) return String is
begin
return Boolean'Image (Exp.Value);
end Bool_Exps.Const_Exps.Get_Image;
function Bool_Exps.Const_Exps.Get_Image
(Exp : access Const_Exp) return String;
package body Bool_Exps.Const_Exps is
type Const_Exp_Array is
array (Boolean) of aliased Const_Exp;
Const_Exps : Const_Exp_Array;
function Eval
(Exp : access Const_Exp;
Context : in Exp_Context)
return Boolean is
begin
return Exp.Value;
end;
function New_Const
(Value : Boolean)
return Bool_Exp_Access is
begin
return Const_Exps (Value)'Access;
end;
function Copy
(Exp : access Const_Exp)
return Bool_Exp_Access is
begin
return Bool_Exp_Access (Exp);
end;
function Replace
(Var : access Const_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is
begin
return Bool_Exp_Access (Var);
end;
procedure Accept_Visitor
(Exp : access Const_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_Const_Exp (Visitor, Exp);
end;
begin
for Value in Const_Exps'Range loop
Const_Exps (Value).Value := Value;
end loop;
end Bool_Exps.Const_Exps;
package Bool_Exps.Const_Exps is
pragma Elaborate_Body;
type Const_Exp is
new Bool_Exp with private;
function Eval
(Exp : access Const_Exp;
Context : in Exp_Context)
return Boolean;
function New_Const
(Value : Boolean)
return Bool_Exp_Access;
function Copy
(Exp : access Const_Exp)
return Bool_Exp_Access;
function Replace
(Var : access Const_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access;
procedure Accept_Visitor
(Exp : access Const_Exp;
Visitor : in out Visitor_Type'Class);
private
type Const_Exp is
new Bool_Exp with record
Value : Boolean;
end record;
end Bool_Exps.Const_Exps;
with Bool_Exps.Image_Visitors; use Bool_Exps.Image_Visitors;
function Bool_Exps.Get_Image
(Exp : access Bool_Exp'Class)
return String is
Visitor : Image_Visitor;
begin
Accept_Visitor (Exp, Visitor);
return Get_Image (Visitor);
end;
function Bool_Exps.Get_Image
(Exp : access Bool_Exp'Class)
return String;
with Bool_Exps.And_Exps.Get_Image; use Bool_Exps.And_Exps;
with Bool_Exps.Or_Exps.Get_Image; use Bool_Exps.Or_Exps;
with Bool_Exps.Var_Exps.Get_Image; use Bool_Exps.Var_Exps;
with Bool_Exps.Const_Exps.Get_Image; use Bool_Exps.Const_Exps;
with Bool_Exps.Not_Exps.Get_Image; use Bool_Exps.Not_Exps;
package body Bool_Exps.Image_Visitors is
function Get_Image (Visitor : Image_Visitor) return String is
begin
return Visitor.Image (1 .. Visitor.Length);
end;
generic
type Exp_Type (<>) is
abstract new Bool_Exp with private;
with function Get_Image
(Exp : access Exp_Type) return String is <>;
procedure Visit_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) is
Image : constant String :=
Get_Image (Exp_Type (Exp.all)'Access);
begin
Visitor.Image (1 .. Image'Length) := Image;
Visitor.Length := Image'Length;
end Visit_Exp;
procedure Do_Visit_And_Exp is
new Visit_Exp (And_Exp);
procedure Visit_And_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_And_Exp;
procedure Do_Visit_Or_Exp is
new Visit_Exp (Or_Exp);
procedure Visit_Or_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_Or_Exp;
procedure Do_Visit_Not_Exp is
new Visit_Exp (Not_Exp);
procedure Visit_Not_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_Not_Exp;
procedure Do_Visit_Const_Exp is
new Visit_Exp (Const_Exp);
procedure Visit_Const_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_Const_Exp;
procedure Do_Visit_Var_Exp is
new Visit_Exp (Var_Exp);
procedure Visit_Var_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class) renames Do_Visit_Var_Exp;
end Bool_Exps.Image_Visitors;
private package Bool_Exps.Image_Visitors is
pragma Elaborate_Body;
type Image_Visitor is new Visitor_Type with private;
function Get_Image (Visitor : Image_Visitor) return String;
private
type Image_Visitor is
new Visitor_Type with record
Image : String (1 .. 100);
Length : Natural := 0;
end record;
procedure Visit_And_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Or_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Not_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Const_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
procedure Visit_Var_Exp
(Visitor : in out Image_Visitor;
Exp : access Bool_Exp'Class);
end Bool_Exps.Image_Visitors;
with Bool_Exps.Get_Image;
function Bool_Exps.Not_Exps.Get_Image
(Exp : access Not_Exp) return String is
begin
return "not " & Get_Image (Exp.R);
end Bool_Exps.Not_Exps.Get_Image;
function Bool_Exps.Not_Exps.Get_Image
(Exp : access Not_Exp) return String;
with Bool_Exps.Storage;
pragma Elaborate (Bool_Exps.Storage);
package body Bool_Exps.Not_Exps is
package Not_Exp_Storage is
new Storage (Not_Exp);
function Eval
(Exp : access Not_Exp;
Context : in Exp_Context) return Boolean is
begin
return not Eval (Exp.R, Context);
end Eval;
function New_Not
(R : access Bool_Exp'Class)
return Bool_Exp_Access is
use Not_Exp_Storage;
Exp : constant Exp_Access := New_Exp;
begin
Exp.R := Bool_Exp_Access (R);
return Bool_Exp_Access (Exp);
end New_Not;
function Copy
(Exp : access Not_Exp)
return Bool_Exp_Access is
begin
return New_Not (R => Copy (Exp.R));
end;
function Replace
(Var : access Not_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is
begin
return New_Not (R => Replace (Var.R, Name, Exp));
end;
procedure Accept_Visitor
(Exp : access Not_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_Not_Exp (Visitor, Exp);
end;
procedure Finalize (Exp : access Not_Exp) is
begin
Free (Exp.R);
end Finalize;
procedure Do_Free (Exp : access Not_Exp) renames
Not_Exp_Storage.Do_Free;
end Bool_Exps.Not_Exps;
package Bool_Exps.Not_Exps is
pragma Preelaborate;
type Not_Exp is
new Bool_Exp with private;
function Eval
(Exp : access Not_Exp;
Context : in Exp_Context) return Boolean;
function New_Not
(R : access Bool_Exp'Class)
return Bool_Exp_Access;
function Copy
(Exp : access Not_Exp)
return Bool_Exp_Access;
function Replace
(Var : access Not_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access;
procedure Accept_Visitor
(Exp : access Not_Exp;
Visitor : in out Visitor_Type'Class);
private
type Not_Exp is
new Bool_Exp with record
R : Bool_Exp_Access;
end record;
procedure Finalize (Exp : access Not_Exp);
procedure Do_Free (Exp : access Not_Exp);
end Bool_Exps.Not_Exps;
with Bool_Exps.Get_Image;
function Bool_Exps.Or_Exps.Get_Image
(Exp : access Or_Exp) return String is
begin
return
'(' &
Get_Image (Exp.L) &
" or " &
Get_Image (Exp.R) &
')';
end Bool_Exps.Or_Exps.Get_Image;
function Bool_Exps.Or_Exps.Get_Image
(Exp : access Or_Exp) return String;
with Bool_Exps.Storage;
pragma Elaborate (Bool_Exps.Storage);
package body Bool_Exps.Or_Exps is
package Or_Exp_Storage is
new Storage (Or_Exp);
function Eval
(Exp : access Or_Exp;
Context : in Exp_Context)
return Boolean is
begin
return Eval (Exp.L, Context) or Eval (Exp.R, Context);
end Eval;
function New_Or
(L, R : access Bool_Exp'Class)
return Bool_Exp_Access is
use Or_Exp_Storage;
Exp : constant Exp_Access := New_Exp;
begin
Exp.L := Bool_Exp_Access (L);
Exp.R := Bool_Exp_Access (R);
return Bool_Exp_Access (Exp);
end New_Or;
function Copy
(Exp : access Or_Exp)
return Bool_Exp_Access is
begin
return New_Or (L => Copy (Exp.L), R => Copy (Exp.R));
end;
function Replace
(Var : access Or_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is
L : constant Bool_Exp_Access := Replace (Var.L, Name, Exp);
R : constant Bool_Exp_Access := Replace (Var.R, Name, Exp);
begin
return New_Or (L, R);
end;
procedure Accept_Visitor
(Exp : access Or_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_Or_Exp (Visitor, Exp);
end;
procedure Finalize
(Exp : access Or_Exp) is
begin
Free (Exp.L);
Free (Exp.R);
end Finalize;
procedure Do_Free
(Exp : access Or_Exp) renames
Or_Exp_Storage.Do_Free;
end Bool_Exps.Or_Exps;
package Bool_Exps.Or_Exps is
pragma Preelaborate;
type Or_Exp is
new Bool_Exp with private;
function Eval
(Exp : access Or_Exp;
Context : in Exp_Context)
return Boolean;
function New_Or
(L, R : access Bool_Exp'Class)
return Bool_Exp_Access;
function Copy
(Exp : access Or_Exp)
return Bool_Exp_Access;
function Replace
(Var : access Or_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access;
procedure Accept_Visitor
(Exp : access Or_Exp;
Visitor : in out Visitor_Type'Class);
private
type Or_Exp is
new Bool_Exp with record
L, R : Bool_Exp_Access;
end record;
procedure Finalize
(Exp : access Or_Exp);
procedure Do_Free
(Exp : access Or_Exp);
end Bool_Exps.Or_Exps;
package body Bool_Exps.Storage is
Free_List : Bool_Exp_Access;
function New_Exp return Exp_Access is
Exp : Bool_Exp_Access;
begin
if Free_List = null then
Exp := new Exp_Type;
else
Exp := Free_List;
Free_List := Free_List.Next;
Exp.Next := null;
end if;
declare
pragma Suppress (Tag_Check);
begin
return Exp_Access (Exp);
end;
end New_Exp;
procedure Do_Free (Exp : access Exp_Type) is
begin
Finalize (Exp);
Exp.Next := Free_List;
Free_List := Bool_Exp_Access (Exp);
end Do_Free;
end Bool_Exps.Storage;
private generic
type Exp_Type is new Bool_Exp with private;
package Bool_Exps.Storage is
type Exp_Access is access all Exp_Type;
for Exp_Access'Storage_Size use 0;
function New_Exp return Exp_Access;
procedure Do_Free (Exp : access Exp_Type);
end Bool_Exps.Storage;
with Bool_Exps.Get_Image;
function Bool_Exps.Var_Exps.Get_Image
(Exp : access Var_Exp) return String is
begin
return Character'Image (Exp.Name)(2 .. 2);
end Bool_Exps.Var_Exps.Get_Image;
function Bool_Exps.Var_Exps.Get_Image
(Exp : access Var_Exp) return String;
with Bool_Exps.Storage;
pragma Elaborate (Bool_Exps.Storage);
package body Bool_Exps.Var_Exps is
function Eval
(Exp : access Var_Exp;
Context : in Exp_Context)
return Boolean is
begin
return Context.Variables (Exp.Name);
end;
package Var_Exp_Storage is
new Storage (Var_Exp);
function New_Var
(Name : Var_Name)
return Bool_Exp_Access is
use Var_Exp_Storage;
Exp : constant Exp_Access := New_Exp;
begin
Exp.Name := Name;
return Bool_Exp_Access (Exp);
end New_Var;
function Copy
(Exp : access Var_Exp)
return Bool_Exp_Access is
begin
return New_Var (Exp.Name);
end Copy;
function Replace
(Var : access Var_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is
begin
if Var.Name = Name then
return Copy (Exp);
else
return Copy (Var);
end if;
end Replace;
procedure Accept_Visitor
(Exp : access Var_Exp;
Visitor : in out Visitor_Type'Class) is
begin
Visit_Var_Exp (Visitor, Exp);
end;
procedure Do_Free
(Exp : access Var_Exp) renames
Var_Exp_Storage.Do_Free;
end Bool_Exps.Var_Exps;
package Bool_Exps.Var_Exps is
pragma Preelaborate;
type Var_Exp is
new Bool_Exp with private;
type Var_Exp_Access is
access all Var_Exp;
function Eval
(Exp : access Var_Exp;
Context : in Exp_Context)
return Boolean;
function New_Var
(Name : Var_Name)
return Bool_Exp_Access;
function Copy
(Exp : access Var_Exp)
return Bool_Exp_Access;
function Replace
(Var : access Var_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access;
procedure Accept_Visitor
(Exp : access Var_Exp;
Visitor : in out Visitor_Type'Class);
private
type Var_Exp is
new Bool_Exp with record
Name : Var_Name;
end record;
procedure Do_Free
(Exp : access Var_Exp);
end Bool_Exps.Var_Exps;
package body Bool_Exps is
procedure Finalize
(Exp : access Bool_Exp) is
begin
null;
end;
procedure Do_Free
(Exp : access Bool_Exp) is
begin
null;
end;
procedure Free
(Exp : in out Bool_Exp_Access) is
begin
if Exp /= null then
Do_Free (Exp);
Exp := null;
end if;
end Free;
procedure Assign
(Context : in out Exp_Context;
Name : in Var_Name;
Value : in Boolean) is
begin
Context.Variables (Name) := Value;
end;
procedure Visit_And_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class) is
begin
null;
end;
procedure Visit_Or_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class) is
begin
null;
end;
procedure Visit_Not_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class) is
begin
null;
end;
procedure Visit_Const_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class) is
begin
null;
end;
procedure Visit_Var_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class) is
begin
null;
end;
end Bool_Exps;
package Bool_Exps is
pragma Preelaborate;
type Bool_Exp (<>) is
abstract tagged limited private;
type Bool_Exp_Access is
access all Bool_Exp'Class;
type Exp_Context is limited private;
subtype Var_Name is Character range 'A' .. 'Z';
procedure Assign
(Context : in out Exp_Context;
Name : in Var_Name;
Value : in Boolean);
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;
function Replace
(Var : access Bool_Exp;
Name : in Var_Name;
Exp : access Bool_Exp'Class)
return Bool_Exp_Access is abstract;
procedure Free
(Exp : in out Bool_Exp_Access);
type Visitor_Type is abstract tagged limited null record;
procedure Accept_Visitor
(Exp : access Bool_Exp;
Visitor : in out Visitor_Type'Class) is abstract;
private
type Bool_Exp is
abstract tagged limited record
Next : Bool_Exp_Access;
end record;
procedure Finalize
(Exp : access Bool_Exp);
procedure Do_Free
(Exp : access Bool_Exp);
type Var_Name_Value_Map_Base is
array (Character range <>) of Boolean;
subtype Var_Name_Value_Map is
Var_Name_Value_Map_Base (Var_Name);
type Exp_Context is
record
Variables : Var_Name_Value_Map;
end record;
procedure Visit_And_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Or_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Not_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Const_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
procedure Visit_Var_Exp
(Visitor : in out Visitor_Type;
Exp : access Bool_Exp'Class);
end Bool_Exps;
with Bool_Exps.Get_Image; use Bool_Exps;
with Bool_Exps.Const_Exps; use Bool_Exps.Const_Exps;
with Bool_Exps.Var_Exps; use Bool_Exps.Var_Exps;
with Bool_Exps.And_Exps; use Bool_Exps.And_Exps;
with Bool_Exps.Or_Exps; use Bool_Exps.Or_Exps;
with Bool_Exps.Not_Exps; use Bool_Exps.Not_Exps;
with Ada.Text_IO; use Ada.Text_IO;
procedure Test_Expression is
Exp : Bool_Exp_Access :=
New_Or
(New_And (New_Const (True), New_Var ('X')),
New_And (New_Var ('Y'), New_Not (New_Var ('X'))));
begin
Put_Line ("Image is '" & Get_Image (Exp) & "'");
Exp := Replace (Exp, 'X', New_Or (New_Var ('Z'), New_Const (False)));
Put_Line ("New image is '" & Get_Image (Exp) & "'");
end Test_Expression;
|
