Ada 中的动态调度

Question

即使使用这个简单的示例，我也无法让动态调度正常工作。我相信问题在于我如何设置类型和方法，但看不到在哪里！

with Ada.Text_Io;
procedure Simple is

   type Animal_T is abstract tagged null record;

   type Cow_T is new Animal_T with record
      Dairy : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cow_T) is
   begin
      Ada.Text_Io.Put_Line ("Cow");
   end Go_To_Vet;

   type Cat_T is new Animal_T with record
      Fur : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cat_T)
   is
   begin
      Ada.Text_Io.Put_Line ("Cat");
   end Go_To_Vet;

   A_Cat : Cat_T := (Animal_T with Fur => True);
   A_Cow : Cow_T := (Animal_T with Dairy => False);
   Aa : Animal_T'Class := A_Cat;
begin

   Go_To_Vet (Aa); -- ERROR This doesn't dynamically dispatch!
end Simple;

Answer 1

两件事：

首先，您必须有一个 Go_To_Vet 的抽象规范，这样才能进行委托（这也引起了我的注意：-）：

procedure Go_To_Vet (A : in out Animal_T) is abstract;

第二个是Ada要求父定义在自己的包中：

package Animal is

   type Animal_T is abstract tagged null record;

   procedure Go_To_Vet (A : in out Animal_T) is abstract;

end Animal;

您的 Simple 过程中的类型定义需要相应地调整（这里我只是使用 Animal 包来保持简单）：

with Ada.Text_Io;
with Animal; use Animal;
procedure Simple is

   type Cow_T is new Animal_T with record
      Dairy : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cow_T) is
   begin
      Ada.Text_Io.Put_Line ("Cow");
   end Go_To_Vet;

   type Cat_T is new Animal_T with record
      Fur : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cat_T)
   is
   begin
      Ada.Text_Io.Put_Line ("Cat");
   end Go_To_Vet;

   A_Cat : Cat_T := (Animal_T with Fur => True);
   A_Cow : Cow_T := (Animal_T with Dairy => False);
   Aa : Animal_T'Class := A_Cat;
begin

   Go_To_Vet (Aa); -- ERROR This doesn't dynamically dispatch! DOES NOW!!  :-)
end Simple;

编译：

[17] Marc say: gnatmake -gnat05 simple
gcc -c -gnat05 simple.adb
gcc -c -gnat05 animal.ads
gnatbind -x simple.ali
gnatlink simple.ali

最后：

[18] Marc say: ./simple
Cat

Answer 2

如何将 A_Cow 分配给 Aa ？ （Aa := A_Cow；抱怨！）

你不能也不应该。尽管它们共享一个共同的基类，但它们是两种不同的类型。与 Java 相比，将猫转换为牛的尝试会在运行时导致 ClassCastException。 Ada 在编译时排除了问题，就像 Java 泛型声明一样。

我扩展了@Marc C 的示例来展示您如何可以调用基类子程序。请注意prefixed notation 在procedure Simple 中的使用。

附录：正如您提到的class wide programming，我应该添加与以下示例相关的几点。特别是，类范围的操作，例如Get_Weight 和Set_Weight，是not inherited，但prefixed notation 使它们可用。此外，这些子程序相当做作，因为标记的记录组件可以直接访问，例如Tabby.Weight.

package Animal is

   type Animal_T is abstract tagged record
      Weight : Integer := 0;
   end record;

   procedure Go_To_Vet (A : in out Animal_T) is abstract;
   function  Get_Weight (A : in Animal_T'Class) return Natural;
   procedure Set_Weight (A : in out Animal_T'Class; W : in Natural);

end Animal;

package body Animal is

   function Get_Weight (A : in Animal_T'Class) return Natural is
   begin
      return A.Weight;
   end Get_Weight;

   procedure Set_Weight (A : in out Animal_T'Class; W : in Natural) is
   begin
      A.Weight := W;
   end Set_Weight;

end Animal;

with Ada.Text_IO; use Ada.Text_IO;
with Animal; use Animal;
procedure Simple is

   type Cat_T is new Animal_T with record
      Fur : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cat_T)
   is
   begin
      Ada.Text_Io.Put_Line ("Cat");
   end Go_To_Vet;

   type Cow_T is new Animal_T with record
      Dairy : Boolean;
   end record;

   procedure Go_To_Vet (A : in out Cow_T) is
   begin
      Ada.Text_Io.Put_Line ("Cow");
   end Go_To_Vet;

   A_Cat : Cat_T := (Weight => 5, Fur => True);
   A_Cow : Cow_T := (Weight => 200, Dairy => False);
   Tabby : Animal_T'Class := A_Cat;
   Bossy : Animal_T'Class := A_Cow;

begin
   Go_To_Vet (Tabby);
   Put_Line (Tabby.Get_Weight'Img);
   Go_To_Vet (Bossy);
   Put_Line (Bossy.Get_Weight'Img);
   -- feed Bossy
   Bossy.Set_Weight (210);
   Put_Line (Bossy.Get_Weight'Img);
end Simple;