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=-1.9 required=5.0 tests=BAYES_00 autolearn=ham
	autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,1dcef85eb875c8db,start
X-Google-Attributes: gid103376,public
X-Google-ArrivalTime: 2003-06-11 16:07:34 PST
Path: 
 archiver1.google.com!news1.google.com!newsfeed.stanford.edu!logbridge.uoregon.edu!newsfeed.vmunix.org!newsfeed.stueberl.de!eusc.inter.net!cs.tu-berlin.de!not-for-mail
From: Stephan Heinemann <zombie@cs.tu-berlin.de>
Newsgroups: comp.lang.ada
Subject: Dispatching to a common most special ancestor
Date: 11 Jun 2003 23:07:33 GMT
Organization: Technische Universitaet Berlin, Deutschland
Message-ID: <bc8cnl$in0$1@news.cs.tu-berlin.de>
NNTP-Posting-Host: fiesta.cs.tu-berlin.de
Mime-Version: 1.0
Content-Type: text/plain; charset=ISO-8859-1
Content-Transfer-Encoding: 8bit
X-Trace: news.cs.tu-berlin.de 1055372853 19168 130.149.17.4 (11 Jun 2003
 23:07:33 GMT)
X-Complaints-To: news@cs.tu-berlin.de
NNTP-Posting-Date: 11 Jun 2003 23:07:33 GMT
User-Agent: tin/1.4.6-20020816 ("Aerials") (UNIX) (SunOS/5.8 (sun4u))
Xref: archiver1.google.com comp.lang.ada:39015
Date: 2003-06-11T23:07:33+00:00
List-Id: <comp.lang.ada>

Please have a look at the following code:

with
    Ada.Finalization;

use
    Ada.Finalization;

package Objects is

    -- Abstract Class Object -----------------------------------------
    type Object is new Controlled with private;
    type Object_CA is access all Object'Class;
    
    -- ...
    -- fall back to this when objects of different kind are passed in
    function Equals(This, Another: access Object) return Boolean;
    ------------------------------------------------------------------

    -- Class Derived_1 -----------------------------------------------
    type Derived_1 is new Object with private;
    type Derived_1_CA is access all Derived_1'Class;
    
    -- ...
    function Equals(This, Another: access Derived_1) return Boolean;
    ------------------------------------------------------------------

    -- Class Derived_2 -----------------------------------------------
    type Derived_2 is new Object with private;
    type Derived_2_CA is access all Derived_2'Class;
    
    -- ...
    function Equals(This, Another: access Derived_2) return Boolean;
    ------------------------------------------------------------------

private

    -- Private Abstract Class Object ---------------------------------
    type Object is new Controlled with
        record
            Common: Natural;
        end record;
    ------------------------------------------------------------------
    
    -- Private Class Derived_1 ---------------------------------------
    type Derived_1 is new Object with
        record
            Value: Integer;
        end record;
    ------------------------------------------------------------------

    -- Private Class Derived_2 ---------------------------------------
    type Derived_2 is new Object with
        record
            Value: Boolean;
        end record;
    ------------------------------------------------------------------

end Objects;

package body Objects is

    function Equals(This, Another: access Object) return Boolean is
    begin
        return This.Common = Another.Common;
    end Equals;

    function Equals(This, Another: access Derived_1) return Boolean is
    begin
        return This.Common = Another.Common and This.Value = 
Another.Value;
    end Equals;    

    function Equals(This, Another: access Derived_2) return Boolean is
    begin
        return This.Common = Another.Common and This.Value = 
Another.Value;
    end Equals;

end Objects;

with
    Ada.Tags,
    Objects;
use
    Ada.Tags,
    Objects;

procedure Objects_Test is
    O1: Object_CA := new Derived_1;
    O2: Object_CA := new Derived_2;
    B: Boolean;
begin

    --if O1'Tag = O2'Tag then
        B := Equals(This => O1, Another => O2);
    --else
        -- B := Get_Common(This => O1) = Get_Common(This => O2);
    --end if;

    -- raised CONSTRAINT_ERROR : objects_test.adb:15

end Objects_Test;

I wanted Equals to be dispatched to the common object ancestor but
instead a constraint error is raised. How might I resolve this?

Thanks in advance,
Stephan