覆盖在Ada中接收类范围类型作为参数的过程

Question

我试图了解面向对象在Ada中是如何工作的。我发现了一个我无法解决的情况。

我知道如何使用类宽类型来启用多态，我知道如何从派生类中重写父类的方法。

我不知道该怎么做的是覆盖一个接收类范围类型作为参数的过程，因为我总是得到编译错误。我在下面深入解释：

What I have tried

输入1

package Pack1

    type Type1 is tagged
    record
        i : Integer := 20;
    end record;

    function get_number(self : Type1) return Integer;

    procedure do_something(self : Type1'class);

end Pack1;

----------------------------------------------------

package body Pack1 is 

    function get_number(self : Type1) return Integer is
    begin
        return 200;
    end get_number;

    procedure do_something(self : Type1'class) is
    begin
        Put_Line("Calling from Type1, " & (Integer'Image(self.i + self.get_number)));
    end do_something;

end Pack1;

类型2

package Pack2

    type Type2 is new Type1 with
    record
        ii : Integer := 20;
    end record;

    overriding function get_number(self : Type2) return Integer;

    overriding procedure do_something(self : Type2'class);

end Pack2;

----------------------------------------------------

package body Pack2 is 

    function get_number(self : Type2) return Integer is
    begin
        return 300;
    end get_number;

    procedure do_something(self : Type2'class) is
    begin
        Put_Line("Calling from Type2, " & (Integer'Image(self.i + self.ii + self.get_number)));
    end do_something;

end Pack2;

主要

procedure Main is
    t1 : Type1;
    t2 : Type2;
begin
    t1.do_something;
    t2.do_something;
end Main;

获得错误

我在编译期间遇到错误：

possible interpretation at Type1.ads
possible interpretation at Type2.ads

Expected output

当我可以编译代码时，我期望获得以下内容：

Calling from Type1, 220

Calling from Type2, 350

我怎样才能实现我想要的行为？

Answer 1

采用类范围参数的子程序不是类的父类的基本操作，因此不能被继承。

如果子程序采用类范围的参数，那么关键是它的实现是根据为类的父类定义的操作来编写的。如果要更改派生类型的行为，可以通过覆盖派生类型的相关基本操作来完成。

产品规格：

package A is
   type Values is range 0 .. 999;

   type Instance is tagged private;
   subtype Class is Instance'Class; --'

   function Name       (Item : in Instance) return String;
   function Get_Number (Item : in Instance) return Values;
   function Get_Sum    (Item : in Instance) return Values;
private
   type Instance is tagged
      record
         First : Values := 20;
      end record;
end A;

with A;

package B is
   subtype Parent is A.Instance;
   type Instance is new Parent with private;
   subtype Class is Instance'Class; --'

   overriding
   function Name       (Item : in Instance) return String;
   overriding
   function Get_Number (Item : in Instance) return A.Values;
   overriding
   function Get_Sum    (Item : in Instance) return A.Values;
private
   type Instance is new Parent with
      record
         Second : A.Values := 20;
      end record;
end B;

with Ada.Text_IO;

with A;

procedure Do_Something (Item : in A.Class);

实现：

package body A is
   function Name       (Item : in Instance) return String is ("Class A");
   function Get_Number (Item : in Instance) return Values is (200);
   function Get_Sum    (Item : in Instance) return Values is (Item.First);
end A;

package body B is
   use all type A.Values;

   overriding
   function Name       (Item : in Instance) return String   is ("Class B");
   overriding
   function Get_Number (Item : in Instance) return A.Values is (300);
   overriding
   function Get_Sum    (Item : in Instance) return A.Values is (Parent (Item).Get_Sum + Item.Second);
end B;

procedure Do_Something (Item : in A.Class) is
   use all type A.Values;
begin
   Ada.Text_IO.Put_Line
      ("Calling from " & Item.Name & ", " & A.Values'Image (Item.Get_Number + Item.Get_Sum));
end Do_Something;

最后一个示威者：

with A;
with B;
with Do_Something;

procedure Inheritance_Demo_2018_06_13 is
   O : A.Instance;
   P : B.Instance;
begin
   Do_Something (O);
   Do_Something (P);
end Inheritance_Demo_2018_06_13;

Answer 2

正如雅各布在this answer所说，你不能覆盖Do_Something，因为它不是原始的，因为它的控制参数是全班的。

如果你完全删除Pack2.Do_Something，你的程序将编译。但是，输出是

$ ./main
Calling from Type1,  220
Calling from Type1,  320

这越来越接近你想要的。

一个更好的解决方案是消除’Class中的Pack2.Do_Something，这使得它成为一种原始（可调度）操作。

我仍然没有得到你想要的结果：

$ ./main
Calling from Type1,  220
Calling from Type2,  340

也许你打算将Pack2.Type2.ii初始化为30？

（顺便说一下，你发布的代码不能编译。请通过提交可编译的例子让我们更容易帮助你！）

Answer 3

问题是你试图过早使用类类型。您希望Do_Something过程接受Type1和Type2的输入，而不是Type1'Class或Type2'Class。然后你可以从另一个带有类类型参数的程序中调用这些程序（这将为你提供多态性）。

Jacob Sparre Andersen在他的回答中向您展示了这一点，但我希望将更接近原始代码的内容作为额外的参考。

下面是一个基于您的原始测试程序（在jdoodle在线编译器中编译），它显示了以多态方式调用函数的各种方法。

码：

with Ada.Text_IO; use Ada.Text_IO;

procedure jdoodle is

    package Pack1 is

        type Type1 is tagged
        record
            i : Integer := 20;
        end record;

        type Type1_Class_Access is access all Type1'Class;

        function get_number(self : Type1) return Integer;

        procedure do_something(self : Type1);  -- note the change here

    end Pack1;

    ----------------------------------------------------

    package body Pack1 is 

        function get_number(self : Type1) return Integer is
        begin
            return 200;
        end get_number;

        procedure do_something(self : Type1) is  -- note the change here
        begin
            Put_Line("Calling from Type1, " & (Integer'Image(self.i + self.get_number)));
        end do_something;

    end Pack1;

    package Pack2 is

        use Pack1;

        type Type2 is new Type1 with
        record
            ii : Integer := 20;
        end record;

        overriding function get_number(self : Type2) return Integer;

        overriding procedure do_something(self : Type2);  -- note the change here

    end Pack2;

    ----------------------------------------------------

    package body Pack2 is 

        function get_number(self : Type2) return Integer is
        begin
            return 300;
        end get_number;

        procedure do_something(self : Type2) is
        begin
            Put_Line("Calling from Type2, " & (Integer'Image(self.i + self.ii + self.get_number)));
        end do_something;

    end Pack2;


    t1 : aliased Pack1.Type1;
    t2 : aliased Pack2.Type2;

    p1 : Pack1.Type1'Class := Pack1.Type1'(others => <>);
    p2 : Pack1.Type1'Class := Pack2.Type2'(others => <>);

    procedure Do_Something(Object : Pack1.Type1'Class) is
    begin
        Object.Do_Something;  -- polymorphically calls Do_Something
    end Do_Something;

    type Class_Array is array(Integer range <>) of Pack1.Type1_Class_Access;

    a : Class_Array(1..2) := (1 => t1'Access, 2 => t2'Access);

begin
    -- Non Polymorphic calls
    t1.do_something;
    t2.do_something;

    -- Polymorphic variable calls
    -- both variables are of type Pack1.Type1'Class
    p1.do_something;
    p2.do_something;

    -- Polymorphic procedure calls
    -- the input type of the procedure is Pack1.Type1'Class
    Do_Something(t1);
    Do_Something(t2);

    -- Polymorphic array of class access variable calls
    for e of a loop
        e.Do_Something;
    end loop;
    for e of a loop
        Do_Something(e.all);
    end loop;
end jdoodle;

输出：

Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340
Calling from Type1,  220
Calling from Type2,  340