1. Phi_main_menu の解析

Apollo の開発においては GC が大きな問題になってきた。
特に NewMenu や NewItem は、Delphi が内部で MenuItem の Owner を設定するために Delphi によって MenuItem が Free されることになり、下手な実装では、 Free したアドレスに不正なアクセスをしてしまったり、 Ruby 側でメモリがなかなか解放されなくなってしまったりするだろう。
ここでは %c:Phi.main_menu% の実装である %c:Phi_main_menu% 関数について、主に Ruby 側のインスタンス変数による has_a 関係を説明し、Apollo はどのように Ruby GC と折り合いをつけるべきか考えたい。

1.1. Phi_new_menu

以下は %c:Phi_new_menu% 関数定義の部分である( %c:...% は省略を示す )。
--code
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;
--

ここで %v:result% は %c:Phi_new_menu% の返り値で %c:Phi::MainMenu% クラスのインスタンスである。
%v:real% は %v:result% に対応する Delphi オブジェクトで %c:TMainMenu% クラスのインスタンスである。
%v:ceo% は %c:Phi_new_menu% の第 1 引数で Ruby オブジェクトである。第 1 引数には普通 Form を与えるので、普通 %v:ceo% は %c:Phi::Form% クラスのインスタンスである。仮に Form でないオブジェクトを与えた場合は意味をなさないが、対処できるようにしておく必要がある。
「クラスのインスタンス」という表現は長ったらしいので、以降は単に「オブジェクト」と書くことにする。
%v:aname% は %c:Phi_new_menu% の第 2 引数で、 %v:result% の名前を与える。String あるいは Symbol クラスの Ruby オブジェクトである。
%v:real.items% は %v:real% の保持する %c:TMenuItem% オブジェクトである。

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

parent	ceo
real	This, obj, result
item	vtem, obj
--
%v:This% が %v:this% でないのは C++ に対応するためである。
基本的には Delphi 側の名前は大文字で始まるように書くが、%v:real% のように Apollo では小文字になっていることも多い。これは単に開発者の癖である。

1.1. MainMenu_setup(result, real)

--code
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;
--

1.1. ap_iMenuItem(real.items, obj)

--code
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;
--

1.1. ChildAlloc(This, real)

--code
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;
--

1.1. ap_set_child_attr_module(obj)

--code
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;
--

1.1. ap_owner(result, owner)

--code
uAlloc.pas:

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

1.1. SetParentAttr(result, ceo, aname)

--code
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;
--

1.1. rb_iv_set(result, '@parent', ceo)


1.1. DefineMenuItem(real, real.items)

--code
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;
--

1.1. MenuItem_add

--code
uMenuItem.pas

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

1.1. MenuItem_remove

--code
uMenuItem.pas

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

1.1. RemoveMenuItem(real, item)

--code
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;
--

