VMT弄ってinterfaceを後付けで実装するテクニックが一番役に立つよ派
Haskellの型クラスとDelphiのimplementsのいいとこ取り。
Ase.Tagsは当然ながら俺ライブラリです。
with Ada.Tags; use Ada.Tags; with System; with Ase.Tags; use Ase.Tags; with Ada.Text_IO; use Ada.Text_IO; procedure test is -- 最初に犬猫があるのです type Cat is tagged limited null record; The_Cat : aliased Cat; type Dog is tagged limited null record; The_Dog : aliased Dog; -- Haskellっぽく後から基底を宣言 -- class Pet t where package Pets is type Pet is limited interface; procedure Speak (Object : in Pet) is abstract; end Pets; -- instance Pet Cat where type Pet_Cat is limited new Pets.Pet with null record; overriding procedure Speak (Object : in Pet_Cat) is pragma Unreferenced (Object); begin Put_Line ("meow!"); end Speak; -- instance Pet Dog where type Pet_Dog is limited new Pets.Pet with null record; overriding procedure Speak (Object : in Pet_Dog) is pragma Unreferenced (Object); begin Put_Line ("nwoof"); end Speak; -- Delphiっぽく委任関数を用意 -- property GetPet: Pet read Displace implements Pet; Cat_Proxy : aliased Pet_Cat; function Displace (Object : not null access Cat; Tag : Ada.Tags.Tag) return System.Address is pragma Unreferenced (Object); begin if Tag = Pets.Pet'Tag then return Pets.Pet (Cat_Proxy)'Address; else raise Constraint_Error; end if; end Displace; package Cat_Delegating is new Delegating (Cat, (1 => Pets.Pet'Tag), Displace); -- property GetPet: Pet read Displace implements Pet; Dog_Proxy : aliased Pet_Dog; function Displace (Object : not null access Dog; Tag : Ada.Tags.Tag) return System.Address is pragma Unreferenced (Object); begin if Tag = Pets.Pet'Tag then return Pets.Pet (Dog_Proxy)'Address; else raise Constraint_Error; end if; end Displace; package Dog_Delegating is new Delegating (Dog, (1 => Pets.Pet'Tag), Displace); begin -- VMT書き換え -- この2行はできることなら要らないようにしたい -- しかしそうするにはVMTだけではなくランタイムも書き換える必要がある Cat_Delegating.Implements (The_Cat); Dog_Delegating.Implements (The_Dog); -- 準備OK declare -- 共通基底を持たないはずのCatとDogをなぜかPetにアップキャストして同じ配列に格納できる -- いやま、文法上はdynamicなダウンキャストです Pet_Array : constant array (1 .. 2) of access Pets.Pet'Class := ( Pets.Pet'Class (Cat'Class (The_Cat))'Access, Pets.Pet'Class (Dog'Class (The_Dog))'Access); begin for I in Pet_Array'Range loop -- そしてなぜかdynamicに多態できる Pets.Speak (Pet_Array (I).all); end loop; end; end test;
いいとこ取りではありますが両方の手間なとこも引き継いで面倒さも半端ないという。
使いどころとしては、例えばAdaのストリームの基底型のRoot_Stream_TypeにはSeekが無いため、自分でSeekable_Streamを定義した場合、既存のストリームにSeekable_Streamを実装させるために使うことができます。逆にいえばそれぐらいしか思いつかない……Adaはgenericが設計当時から存在していて、継承のほうが後付けの言語ですので、継承を使う場面がほとんどないのですよね。こうやって無理矢理ネタにできて良かったです。
この手法自体は、ダウンキャストをオブジェクトに埋め込んだVMTその他の型情報で判定している言語であれば(書き換え方は異なりますが)使えるはずです。例えばC++でもOKです。*1
こんなことしなくてもObjective-Cならカテゴリで一発です。Haskellにも型クラスをinterfaceのように扱う拡張があるらしいです。
*1:ちなみにGNATのVMTはg++互換らしいです。