Delphi : クロージャ

[id:lethevert:20060107:p1]で作成したクロージャを使って、memoizeとfixの問題「[id:lethevert:20050904:p3]」を書こうと思っているのだけれど・・・
maker関数が上手く作れない。というのは、IClosureとPointerを交換できないのだ。（前回、TObjectとして定義したIClosureは、Pointerを使って書き直している）
クロージャオブジェクトを複数のパターン作成するのはなるべく避けたいのだけれど・・・

• • • -

と思ったのだが、自己解決した。
recordでインターフェースを包んでしまえばよい。

• • • -

と思ったのだが、やはり上手くいかない・・・。

• • • -

でけた！！
一部、レコードの解放ができていないところがあるけど、一応動く。

program fib_fix;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  OptClosure in 'OptClosure.pas';

//キャストのエイリアス
type
  _i = Integer;
  _p = Pointer;

//IClosureのラッパー
type
  PClosure = ^TClosure;
  TClosure = record
    _: IClosure;
  end;
function Init(c: IClosure): PClosure; begin New(Result); Result._ := c; end;
procedure Final(e: PClosure); begin Dispose(e); end;

//固定点を求める関数
function fix(maker: IClosure): IClosure;

  function f(obj: Pointer; maker: PClosure): Pointer;
    var
      ff: TClosure; //受け渡しのみ
    begin
      ff._ := _(@f, Init(maker._), @Final);
      Result := PClosure(maker._._(@ff))._._(obj);
    end;

  begin
    Result := _(@f, Init(maker), @Final);
  end;

//フィボナッチ関数を作る関数
function fib_maker(ff: PClosure): PClosure;

  function f(I: Integer; ff: PClosure): Integer;
    begin
      if I = 0 then Result := 0
      else
      if I = 1 then Result := 1
      else
        Result := _i(ff._._(_p(I-1))) + _i(ff._._(_p(I-2)));
    end;

  begin
    New(Result); //TODO: この解放が行えていない。
    Result._ := _(@f, Init(ff._), @Final);
  end;

var
  fib: IClosure;
  I: Integer;
begin
  //フィボナッチ関数の作成
  fib := fix(_(@fib_maker));

  //テスト実行
  for I := 0 to 10 do begin
    Writeln(IntToStr(I) + ' -> ' + IntToStr(_i(fib._(_p(I)))));
  end;
end.

ちなみに、ここでつかっったOptClosure.pasは、以下です。

unit OptClosure;

interface

type
  TClosureFunction = function (obj: Pointer): Pointer;
  TClosureProcedure = procedure (obj: Pointer);
  TClosureFunctionWithEnv = function (obj, env: Pointer): Pointer;
  TClosureFunctionM = function (obj: Pointer): Pointer of object;
  TClosureProcedureM = procedure (obj: Pointer) of object;
  IClosure = interface
    function _(obj: Pointer): Pointer;
  end;

function _(aFunction: Pointer): IClosure; overload; register;
function _(aFunction: TClosureFunction): IClosure; overload; register;
function _(aProcedure: TClosureProcedure): IClosure; overload; register;
function _(aFunction: TClosureFunctionM): IClosure; overload; register;
function _(aProcedure: TClosureProcedureM): IClosure; overload; register;

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

implementation

// =============================================================================
// 通常関数と関数内関数向け
// =============================================================================
type
  TClosureF = class(TInterfacedObject, IClosure)
  private
    fFunction: TClosureFunction;
    fContext: Pointer;
    function _(obj: Pointer): 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;

function _(aProcedure: TClosureProcedure): IClosure;
  asm
    jmp mkClosureF
  end;

function TClosureF._(obj: Pointer): Pointer;
  var
    aContext: Pointer;
  begin
    aContext := fContext;
    asm push aContext end;
    Result := fFunction(obj);
    asm pop aContext end;
  end;

// =============================================================================
// Pointer -> Pointer 型メソッド向け
// =============================================================================
type
  TClosureFM = class(TInterfacedObject, IClosure)
  private
    fMethod: TClosureFunctionM;
    function _(obj: Pointer): Pointer;
  end;

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

function TClosureFM._(obj: Pointer): Pointer;
  begin
    Result := fMethod(obj);
  end;

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

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

function TClosurePM._(obj: Pointer): Pointer;
  begin
    fMethod(obj);
    Result := nil;
  end;

// =============================================================================
// 関数（環境付き）
// =============================================================================
type
  TClosureFE = class(TInterfacedObject, IClosure)
  public
    destructor Destroy; override;
  private
    fFunction: TClosureFunctionWithEnv;
    fEnv: Pointer;
    fFinal: procedure(Env: Pointer);
    function _(obj: Pointer): 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;

function TClosureFE._(obj: Pointer): Pointer;
  begin
    Result := fFunction(obj, fEnv);
  end;

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

end.