Dispatching to a common most special ancestor

[Stephan Heinemann <zombie@cs.tu-berlin.de>]

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