FreePascalでリフレクションを実装する

FreePascal

リフレクションは便利なのでFreePascalでも使いたい。

Delphiの場合はRttiユニットがあるのでリフレクションは簡単に実装できるのですが、FreePascalには同等のユニットがありません。

昔作成してGitHubで公開していたテストフレームワークのほうにPullRequestをもらって、FPC用のリフレクション実装をマージしたことがあったのですが、古いバージョンのFPCでしか動かないものでした。

x86_64のFreePascalCompilerで動くように試行錯誤してうまくいったので、まとめておきます。

メモリレイアウトの情報を見つけきれなくて、結局メモリダンプで推測しつつ調整することになりました。

試したFPCのバージョンは、 Free Pascal Compiler version 3.2.2+dfsg-9ubuntu1 [2022/04/11] for x86_64

コード

my_class.pp:

unit my_class;

{$M+}  // publishedを使うのでM+オプション指定
{$MODE Delphi}

interface

type
  TMyClass = class(TObject)
  published  // RTTI生成のためにpublishedを使う
    procedure SayHello;
  end;

implementation

procedure TMyClass.SayHello;
begin
  WriteLn('Hello');
end;

end.

invokes.pp:

unit invokes;

{$MODE Delphi}

interface

uses
  SysUtils;

type
  TMethodtableEntry = packed record
    Name: PShortString;  // メソッド名
    Address: Pointer;  // メソッドの関数ポインタ
  end;

  TPlainMethod = procedure of object;  // 今回は引数無しのメソッド

  procedure InvokeMethod(Obj: TObject; Name: string; AClass: TClass);

implementation

procedure InvokeMethod(Obj: TObject; Name: string; AClass: TClass);
var
  pp: ^Pointer;
  pMethodTable: Pointer;
  pMethodEntry: ^TMethodTableEntry;
  I, numEntries: Word;
  VMethod: TMethod;
  VPlainMethod: TPlainMethod absolute VMethod;
begin
  if AClass = nil then Exit;
  pp := Pointer(NativeUInt(AClass) + vmtMethodtable);  // 仮想メソッドテーブルのオフセット分アドレスずらし
  pMethodTable := pp^;
  if pMethodtable <> nil then begin
    numEntries := PDWord(pMethodTable)^;  // メソッドテーブルのエントリ数をポインタ経由で取得
    pMethodEntry := Pointer(NativeUInt(pMethodTable) + SizeOf(DWord));  // ポインタ分ずらしてエントリにアクセス
    for I := 1 to numEntries do
    begin
      if LowerCase(pMethodEntry^.Name^) = LowerCase(Name) then  // 指定されたメソッド名と同じ場合
      begin
        VMethod.Code := pMethodEntry^.address;  // メソッドの関数ポインタ
        VMethod.Data := Obj;  // SelfをAssign
        VPlainMethod;  // メソッド呼び出し
      end;
      pMethodEntry := Pointer(NativeUInt(pMethodEntry) + SizeOf(TMethodtableEntry));
    end;
  end;
  InvokeMethod(Obj, Name, AClass.ClassParent);
end;

end.

method_invoke.lpr:

program method_invoke;

{$MODE Delphi}

uses
  MyClass in './my_class.pp',
  Invokes in './invokes.pp';

var
  obj: TMyClass;

begin
  obj := TMyClass.Create;
  // TMyClassのSayHelloを呼び出し、Selfにはobjを指定
  InvokeMethod(obj, 'SayHello', TMyClass);
end.

ビルド

$ fpc method_invoke.lpr

実行結果

$ ./method_invoke
Hello

参考