Dispatching to a common most special ancestor

Dispatching to a common most special ancestor

[Stephan Heinemann]

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

Re: Dispatching to a common most special ancestor

[Dmitry A. Kazakov]

Stephan Heinemann wrote:

> Please have a look at the following code:

[...] 

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

There is a work-around for multiple dispatch. You might look at
http://www.dmitry-kazakov.de/ada/components.htm which presumably does what 
you want. In short, you declare:

function Equal
         (  Left  : Object;
            Right : Object'Class;
            Flag  : Boolean := False
         )  return Boolean;
function Less
         (  Left  : Object;
            Right : Object'Class;
            Flag  : Boolean := False
         )  return Boolean;

and then override, for instance Less:

function Less
         (  Left  : A_New_Object;
            Right : Object'Class;
            Flag  : Boolean := False
         )  return Boolean is
begin
   if (  Flag
      or else
         Right not in A_New_Object'Class
      or else
         Right in A_New_Object
      )
   then
      -- Implement it here
      ...
   else
      -- Dispatch on the second parameter
      return
         not (  Less (Right, Left, True)
             or else
                Equal (Right, Left, True)
             );
   end if;
end Less;

The idea is that you do something if Left :> Right, otherwise you redispatch 
through Right. For a commutative operation it is pretty straightforward. 
For a non-commutative (like Less) it is a little bit tricky, as the code 
shows.

Beware, that the predefined "=" cannot be disallowed, so you cannot do

function "=" (Left : Object; Right : Object'Class) is
begin
   return Equal (Left, Right);
end "=";

because it would just overload the predefined one.

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

Re: Dispatching to a common most special ancestor

[Georg Bauhaus]

Stephan Heinemann <zombie@cs.tu-berlin.de> wrote:
:    function Equals(This, Another: access Object) return Boolean;
:    ------------------------------------------------------------------
:    -- Class Derived_1 -----------------------------------------------
:    function Equals(This, Another: access Derived_1) return Boolean;
:    ------------------------------------------------------------------
: 
:    -- Class Derived_2 -----------------------------------------------
:    function Equals(This, Another: access Derived_2) return Boolean;
:    ------------------------------------------------------------------
: 
: 
: I wanted Equals to be dispatched to the common object ancestor but
: instead a constraint error is raised. How might I resolve this?

First, I would reconsider the accesses all over the place.
If they are just there to trigger pass by reference, then they
are not needed, as this happens automatically, see RM 6.2:

4     A type is a by-reference type if it is a descendant of one of the
following:

5     a tagged type;

What you get in addition is an easy way of passing
up part of the comparison using just conversion like in, say,

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


If I understand your example correctly, you want dispatching to
the common object ancestor's Equals if and only if the objects
are not of the same type (O1 not in Derived_2 and vice versa),
because otherwise there are Equals
functions for each of the types in the hierarchy.

But that intent is not reflected in the function names, and not
by the choice of a specific equals operation for each type, I'd say.
There is nothing wrong with comparing objects by various criteria
and choosing an appropriate name for each comparison variant ;-)

You could for example pass a comparison function tailored for a
specific purpose (i.e., not one of those defined for Object and
derivatives), as a generic parameter to where it is needed.
This function might then, as Dmitry has explained,
consume parameters of classwide types, and make the appropriate
dispatching-or-not choices.
(There was a similar question about a dispatching print recently
I think)


HTH, georg

Re: Dispatching to a common most special ancestor

[Matthew Heaney]

Stephan Heinemann <zombie@cs.tu-berlin.de> wrote in message news:<bc8cnl$in0$1@news.cs.tu-berlin.de>...
> 
> I wanted Equals to be dispatched to the common object ancestor but
> instead a constraint error is raised. How might I resolve this?

Equals is primitive for the type, which means that the tags of both
objects must match.

One solution is to make the operation dispatch on only the first
object:

function Equals 
  (O1 : access Object;
   O2 : access Object'Class) return Boolean;

Alternatively, you can make Equals a class-wide operation, and then
internally dispatch as necessary:

function Equals (O1, O2 : access Object'Class) return Boolean;