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
Using the Visitor Pattern to Display the Image of a Boolean Expression (Matthew Heaney)

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;


(c) 1998-2004 All Rights Reserved David Botton