Re: How to test object hierarchy

["Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de>]

Pierre Favier wrote:

> I am wondering how to test for two objects which types both derive from a
> common root type if one of them derives from the other. In short, I am
> trying to run something like the following code which does not compile
> because the Class attribute applies to types or subtypes but not to
> objects:
> 
>    procedure Test_Hierarchy (Obj1 : in Root_Object'Class;
>                              Obj2 : in Root_Object'Class) is
>    begin
> 
>       if Obj1 in Obj2'Class then
> 
>          -- Do something
> 
>       else
> 
>          -- Do something else
> 
>       end if;
> 
>    end Test_Hierarchy;
> 
> Any suggestions on how to achieve the intended effect?

Unfortunately tags have no "<" defined. Otherwise, one could simply write
Obj1'Tag < Obj2'Tag (in the sense Obj1 <: Obj2).

However there is a trick to achieve what you want using dispatching. The
idea is to emulate multiple dispatch and so you go as follows:

procedure Do_It -- Obj1 :>= Obj2
(  Obj1 : in Root_Object'Class;
   Obj2 : in Root_Object'Class
);

procedure Test_Hierarchy
(  Obj1 : in Root_Object; -- Dispatches in this argument
   Obj2 : in Root_Object'Class;
   Recursion : Boolean := False
)  is
begin
   if Recursion or else Obj2 not in Root_Object'Class then
      Do_It (Obj1, Obj2); -- Deal with Obj1 :>= Obj2
   else
      Test_Hierarchy (Obj2, Obj1, True); -- Dispatch again
   end if;
end Test_Hierarchy;

type Derived_Object is new Root_Object with ...;
procedure Test_Hierarchy
(  Obj1 : in Derived_Object;
   Obj2 : in Root_Object'Class;
   Recursion : Boolean := False
)  is
begin
   if Recursion
      or else Obj2 not in Derived_Object'Class
      or else Obj2 in Derived_Object
   then
      Do_It (Obj1, Obj2); -- Deal with Obj1 :>= Obj2
   else
      Test_Hierarchy (Obj2, Obj1, True); -- Dispatch again
   end if;
end Test_Hierarchy;

You have to override Test_Hierarchy for each new type, but I suppose that
"do something" in your code is dispatching anyway. When Test_Hierarchy is
not commutative it gets a bit more complicated, but I think you have got
the idea.

-- 
Regards,
Dmitry A. Kazakov
www.dmitry-kazakov.de