From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me
X-Spam-Level: 
X-Spam-Status: No, score=-0.3 required=5.0 tests=BAYES_00,
	REPLYTO_WITHOUT_TO_CC autolearn=no autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,760a0492b97ae06e
X-Google-Attributes: gid103376,public
X-Google-ArrivalTime: 2003-12-19 02:46:54 PST
Path: 
 archiver1.google.com!news2.google.com!fu-berlin.de!uni-berlin.de!dialin-145-254-037-189.arcor-ip.NET!not-for-mail
From: "Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de>
Newsgroups: comp.lang.ada
Subject: Re: How to test object hierarchy
Date: Fri, 19 Dec 2003 11:53:07 +0100
Organization: At home
Message-ID: <brukur$7il7a$2@ID-77047.news.uni-berlin.de>
References: <93172edb.0312181024.9a536b2@posting.google.com>
Reply-To: mailbox@dmitry-kazakov.de
NNTP-Posting-Host: dialin-145-254-037-189.arcor-ip.net (145.254.37.189)
Mime-Version: 1.0
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7Bit
X-Trace: news.uni-berlin.de 1071830812 7951594 145.254.37.189 ([77047])
User-Agent: KNode/0.7.2
Xref: archiver1.google.com comp.lang.ada:3550
Date: 2003-12-19T11:53:07+01:00
List-Id: <comp.lang.ada>

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