Delphi : クロージャ（完成版）

クロージャというのは、関数内関数などで、関数が定義されたところの環境（ローカル変数やローカル関数）への参照を維持した関数オブジェクトを作成する機能のことです。

過去の記事

[id:lethevert:20060106:p2] - ファンクタの作成
[id:lethevert:20060107] - クロージャの原案
[id:lethevert:20060109:p2] - fix関数によるフィボナッチ関数の作成

クロージャの型について

クロージャの型について、どのような型が一番適切なのかをいろいろ考えていたのですが、結論が出ました。
原案では、「TObject -> TObject」型で実装し、後に「Pointer -> Pointer」に変更したのですが、結論として、「Pointer -> ()」型がもっとも汎用的だという結論になりました。Delphiの型システムとメモリ管理の特徴を考えた上での結論です。
結果を蓄積する場合には、返値を使わずに、フリー変数を利用すれば実現できます。

function Sum(N: Integer): Integer;
  var
    Accum: Integer;
  procedure SumAccum(I: Integer);
    begin
      Accum := Accum + I;
    end;
  begin
    DoRepeat(N, _(@SumAccum));
    Result := Accum;
  end;

また、複数の引数を受け取ったり、返値を返したりする関数のクロージャを作りたい場合は、以下のようにレコードを作ります。

type
  PSS_S = ^TSS_S;
  TSS_S = record
    in0, in1, ret: string;
  end;

function ConCat(lst: TStringDynArray): string;
  procedure ConCatAccum(data: PSS_S);
    begin
      data.ret := data.in0 + data.in1;
    end;
  var
    call: TSS_S;
  begin
    call.ret := '';
      FoldL(_(@ConCatAccum), @call, lst);
      Result := call.ret;
  end;

これを使って、先日のフィボナッチ関数を作ったのがこちら（[id:lethevert:20060110:p2]）です。

クロージャの実装

unit OptClosure;

interface

type
  TClosureFunction = procedure (data: Pointer);
  TClosureMethod = procedure (data: Pointer) of object;
  TClosureFunctionWithEnv = function (data, env: Pointer): Pointer;
  IClosure = interface
    procedure _(data: Pointer);
  end;

function _(aFunction: Pointer): IClosure; overload; register;
function _(aFunction: TClosureFunction): IClosure; overload; register;
function _(aFunction: TClosureMethod): IClosure; overload; register;
function _(aFunction, aEnv, aFinal: Pointer): IClosure; overload; register;

implementation

// =============================================================================
// 通常関数と関数内関数向け
// =============================================================================
type
  TClosureF = class(TInterfacedObject, IClosure)
  private
    fFunction: TClosureFunction;
    fContext: Pointer;
    procedure _(data: Pointer);
  end;

function mkClosureF(aCode: Pointer): IClosure; register;
  function make(aCode, aContext: Pointer): IClosure; register;
    var
      Impl: TClosureF;
    begin
      Impl := TClosureF.Create;
      with Impl do begin
        fFunction := TClosureFunction(aCode);
        fContext := aContext;
      end;
      Result := Impl;
    end;
  asm
    // begin
    push ebx
    push esi
    push ebp
    mov esi,edx
    mov ebx,eax
    // Result := make(aCode, EBP)
    mov ecx,esi
    pop edx
    mov eax,ebx
    call make
    // end
    pop esi
    pop ebx
  end;

function _(aFunction: Pointer): IClosure;
  asm
    jmp mkClosureF
  end;

function _(aFunction: TClosureFunction): IClosure;
  asm
    jmp mkClosureF
  end;

procedure TClosureF._(data: Pointer);
  var
    aContext: Pointer;
  begin
    aContext := fContext;
    asm push aContext end;
    fFunction(data);
    asm pop aContext end;
  end;

// =============================================================================
// Pointer -> () 型メソッド向け
// =============================================================================
type
  TClosurePM = class(TInterfacedObject, IClosure)
  private
    fMethod: TClosureMethod;
    procedure _(data: Pointer);
  end;

function _(aFunction: TClosureMethod): IClosure;
  var
    Impl: TClosurePM;
  begin
    Impl := TClosurePM.Create;
    with Impl do begin
      fMethod := aFunction;
    end;
    Result := Impl;
  end;

procedure TClosurePM._(data: Pointer);
  begin
    fMethod(data);
  end;

// =============================================================================
// 関数（環境付き）
// =============================================================================
type
  TClosureFE = class(TInterfacedObject, IClosure)
  public
    destructor Destroy; override;
  private
    fFunction: TClosureFunctionWithEnv;
    fEnv: Pointer;
    fFinal: procedure(Env: Pointer);
    procedure _(data: Pointer);
  end;

function _(aFunction, aEnv, aFinal: Pointer): IClosure;
  var
    Impl: TClosureFE;
  begin
    Impl := TClosureFE.Create;
    with Impl do begin
      fFunction := aFunction;
      fEnv := aEnv;
      fFinal := aFinal;
    end;
    Result := Impl;
  end;

procedure TClosureFE._(data: Pointer);
  begin
    fFunction(data, fEnv);
  end;

destructor TClosureFE.Destroy;
  begin
    fFinal(fEnv);
    Inherited;
  end;

end.