Create  Edit  Diff  Phillro Industries  Index  Search  Changes  History  Source  RSS  Note  wikifarm  Login

dev-menu

Phi_main_menu の解析

Apollo の開発においては GC が大きな問題になってきた。

特に NewMenu? や NewItem? は、Delphi が内部で MenuItem の Owner を設定するために Delphi によって MenuItem が Free されることになり、下手な実装では、 Free したアドレスに不正なアクセスをしてしまったり、 Ruby 側でメモリがなかなか解放されなくなってしまったりするだろう。

ここでは Phi.main_menu の実装である Phi_main_menu 関数について、主に Ruby 側のインスタンス変数による has_a 関係を説明し、Apollo はどのように Ruby GC と折り合いをつけるべきか考えたい。

Phi_new_menu

以下は Phi_new_menu 関数定義の部分である( ... は省略を示す )。

function Phi_new_menu( ... ): Tvalue; cdecl;
var
  ceo: Tvalue;
  aname: PChar;
  real: TMainMenu;
...
begin
...
  MainMenu_setup(result, real);

  SetParentAttr(result, ceo, aname);
  rb_iv_set(result, '@parent', ceo);
  DefineMenuItem(real, real.items);
end;

ここで result は Phi_new_menu の返り値で Phi::MainMenu? クラスのインスタンスである。

realresult に対応する Delphi オブジェクトで TMainMenu? クラスのインスタンスである。

ceo は Phi_new_menu の第 1 引数で Ruby オブジェクトである。第 1 引数には普通 Form を与えるので、普通 ceo は Phi::Form クラスのインスタンスである。仮に Form でないオブジェクトを与えた場合は意味をなさないが、対処できるようにしておく必要がある。

「クラスのインスタンス」という表現は長ったらしいので、以降は単に「オブジェクト」と書くことにする。

aname は Phi_new_menu の第 2 引数で、 result の名前を与える。String あるいは Symbol クラスの Ruby オブジェクトである。

real.itemsreal の保持する TMenuItem? オブジェクトである。

Apollo では Delphi オブジェクトと Ruby オブジェクトが基本的には互いに 1 対 1 対応するようになっているが、 Delphi 関数内部でこれらを参照する変数名は、概ね以下のような関係になっている。

Delphi	Ruby

parent	ceo
real	This, obj, result
item	vtem, obj

Thisthis でないのは C++ に対応するためである。

基本的には Delphi 側の名前は大文字で始まるように書くが、real のように Apollo では小文字になっていることも多い。これは単に開発者の癖である。

MainMenu_setup(result, real)

uMenu.pas:

procedure MainMenu_setup(obj: Tvalue; real: TMainMenu);
begin
  rb_iv_set(obj, '@items', ap_iMenuItem(real.items, obj));
  rb_iv_set(obj, '@merged', rb_ary_new());
  ap_set_child_attr_module(obj);
end;

ap_iMenuItem(real.items, obj)

uMenuItem.pas

procedure MenuItem_setup(obj: Tvalue; real: TMenuItem);
begin
  rb_iv_set(obj, '@bitmap', ap_iBitmap(real.Bitmap, obj));
  ap_set_child_attr_module(obj);
  AssignPropMethod(real, [Handle]);
end;

function MenuItem_alloc(This: Tvalue; real: TMenuItem): Tvalue;
begin
  result := ChildAlloc(This, real);
  MenuItem_setup(result, real);
end;

function ap_iMenuItem(real: TMenuItem; owner: Tvalue): Tvalue;
begin
  result := MenuItem_alloc(cMenuItem, real);
  ap_owner(result, owner);
end;

ChildAlloc?(This, real)

uAlloc.pas:

procedure ChildFree(real: TComponent); cdecl;
begin
...
    real.tag := 0;
...
end;

function ChildAlloc(klass: Tvalue; real: TComponent): Tvalue;
begin
...
  result := rb_data_object_alloc(klass, real, nil, @ChildFree);
  rb_iv_set(result, '@events', rb_hash_new);
  real.tag := result;
end;

ap_set_child_attr_module(obj)

uPhi.pas:

procedure ap_set_child_attr_module(This: Tvalue);
var
  module: Tvalue;
begin
  module := rb_module_new;
  rb_extend_object(This, module);
  rb_iv_set(This, '@child_attr_module', module);
end;

ap_owner(result, owner)

uAlloc.pas:

function ap_owner(obj, owner: Tvalue): Tvalue;
begin
  result := rb_iv_set(obj, '@owner', owner);
end;

SetParentAttr?(result, ceo, aname)

uComponent.pas:

procedure SetParentAttr(obj, ceo: Tvalue; name: PChar);
var
  module: Tvalue;
begin
  rb_iv_set(ceo, PChar('@'+name), obj);
  module := rb_iv_get(ceo, '@child_attr_module');
  if module = Qnil then
    ap_raise(eDelphiError, 'child attr module not defined');
  rb_define_attr(module, name, 1, 0);
end;

rb_iv_set(result, '@parent', ceo)

DefineMenuItem?(real, real.items)

uMenuItem.pas

procedure DefineMenuItem(real: TComponent; Items: TMenuItem);
var
  ceo: Tvalue;
  parent: TComponent;
  form_p: Boolean;

  procedure SetParent(real: TComponent; Item: TMenuItem);
  var
    This, obj: Tvalue;
    name: string;
    i: Integer;
  begin
    PhiObjectList.Extract(Item);

    This := real.Tag;
    obj := Item.Tag;
    name := LowerCase1(Item.name);

    SetParentAttr(obj, This, PChar(name));
    rb_iv_set(obj, '@parent', This);

    if form_p then
    begin
      SetParentAttr(obj, ceo, PChar(name));
      rb_iv_set(obj, '@form', This);
    end;

    for i := 0 to Item.Count-1 do
      SetParent(Item, Item[i]);
  end;

begin
  parent := real.Owner;
  form_p := parent is TForm;
  if form_p then ceo := parent.Tag else ceo := Qnil;
  SetParent(real, Items);
end;

MenuItem_add

uMenuItem.pas

function MenuItem_add( ... ): Tvalue; cdecl;
var
  real, item: TMenuItem;
...
begin
...
    real.Add(item);
    DefineMenuItem(real, item);
...
  result := This;
end;

MenuItem_remove

uMenuItem.pas

function MenuItem_remove(This, v: Tvalue): Tvalue; cdecl;
var
  real, item: TMenuItem;
begin
...
  RemoveMenuItem(real, item);
  real.Remove(item);
  result := This;
end;

RemoveMenuItem?(real, item)

uMenuItem.pas

procedure RemoveFormAttr(real: TComponent);
var
  obj, ceo, module: Tvalue;
begin
  if Length(real.name) = 0 then Exit;
  obj := real.tag;
  ceo := rb_iv_get(obj, '@form');
  rb_iv_set(ceo, PChar('@'+real.name), Qnil);

  module := rb_iv_get(ceo, '@child_attr_module');
  if module = Qnil then Exit;
  rb_undef_method(module, PChar(real.name));
end;

procedure RemoveMenuItem(real: TComponent; Items: TMenuItem);
var
  parent: TComponent;
  form_p: Boolean;

  procedure RemoveParent(Item: TMenuItem);
  var
    i: Integer;
  begin
    RemoveParentAttr(Item);

    if form_p then
      RemoveFormAttr(Item);

    for i := 0 to Item.Count-1 do
      RemoveParent(Item[i]);
  end;

begin
  parent := real.Owner;
  form_p := parent is TForm;
  RemoveParent(Items);
end;
Last modified:2003/07/14 21:39:22
Keyword(s):
References: