ProPgObjectRtti

OBJECT 組み込みと RTTI 情報　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

OBJECT built-in が、継承ポリモーフィズムと、識別のための 実行時型情報 の能力を実装する方法。

序文:

組み込み型の Object は、（Extends 宣言を使って）派生したすべての型に提供されます：

- ベース型（スーパー型）を継承した派生型（サブ型）のメソッドを（Abstract / Virtual キーワードを使って）再定義することができます。これにより、オブジェクトの固有の型を気にすることなく、そのメソッドを呼び出すことができるようになります。これが継承多相性(サブタイプ多相性)です。
- 実行時にオブジェクトの実際の型を決定する能力で、コンパイル時の型とは異なる場合があります。演算子 Is (実行時型情報) は、オブジェクトがコンパイル時の型から派生した型と互換性があるかどうかをチェックするためにこの機能を使います。なぜなら、RTTI は、オブジェクトの実行時の型名だけでなく、Object の組み込み型までの、さまざまなベース型のすべての名前を提供するからです。

1. 継承ポリモーフィズムと RTTI 情報の内部メカニズム
2. 真の動作と忠実なエミュレーションの両方で示される継承多型メカニズム
3. RTTI 情報から復号化(demangle)された型名を抽出

1. 継承ポリモーフィズムと RTTI 情報の内部メカニズム

抽象/仮想メンバー手続きは、仮想手続きテーブル(vtbl)を使って実装されます。vtbl とは、簡単に言えば、静的手続きのポインタのテーブルです。
コンパイラは各多相型、つまり、少なくとも抽象/仮想手続きを定義している型、または前者から派生した型に対して vtbl を埋めます。
vtbl には、継承階層の上位で定義されている抽象/仮想手続きも含む、その型で使えるすべての抽象/仮想手続きのエントリが含まれています（まだ実装されていない抽象手続きについては、vtbl にヌルポインタが設定されます）。

各 vtbl には、対応する型の抽象的/仮想的な手続きごとに、手続きの正しいアドレスが含まれています。ここで正しいとは、その手続きを定義/上書きする最も派生した型の対応する手続きのアドレスを意味します：

- 型がインスタンス化されると、そのインスタンスには、インスタンス化された型の仮想手続き表(vtbl)へのポインタ(vptr)が含まれます。
- 派生型のオブジェクトが、ベース型のポインタ/参照の中で参照されると、抽象/仮想手続き機能が実際に実行されます。抽象/仮想手続きの呼び出しは、実行時に何らかの形で変換され、基底型のオブジェクト（ポインタ/参照型ではない）の型の仮想手続きテーブルから対応する手続きが選択されます。
- したがって、どの手続きが呼び出されるかは、ポインタ/参照が指し示すオブジェクトの実際の型が何であるかに依存しますが、これはコンパイル時には知ることができません。このため、抽象/仮想手続きの呼び出しは実行時に決定されるのです。

このため、（ポインタや参照による）抽象／仮想手続きの呼び出しは通常の呼び出しではなく、若干のパフォーマンス・オーバーヘッドがあります。これは、多数の呼び出しがある場合には膨大なものになる可能性があります。
抽象/仮想手続きの呼び出しは、コンパイラによって、vptr 値（インスタンスデータのオフセット 0 に位置する）でアドレス指定された適切な vtbl を使うことで、別のものに変換されます：

ここで、'method1()', 'method2()', 'method3()' を継承型構造で宣言された最初の3つの抽象的または仮想的なメンバー手続きとし、'pt' を派生オブジェクトへのベースポインタとします：

pt->method1()
pt->method2()
pt->method3()

は、コンパイラによってそれぞれに変換されます：

Cptr(Sub (Byref As typename), Cptr(Any Ptr Ptr Ptr, pt)[0][0])(*pt)
Cptr(Sub (Byref As typename), Cptr(Any Ptr Ptr Ptr, pt)[0][1])(*pt)
Cptr(Sub (Byref As typename), Cptr(Any Ptr Ptr Ptr, pt)[0][2])(*pt)

- 最初の間接参照 [0] は、インスタンスのアドレスから vptr の値にアクセスできるようにします。この値は vtbl のアドレスに対応します。
- 2つ目の間接参照 [0] または [1] または [2] により、vtbl 内の仮想手続き 'method1()' か 'method2()' か 'method3()' の静的アドレスにそれぞれアクセスできます（型構造体の抽象手続きまたは仮想手続きの宣言順）。

vptr の値の設定について:

- コンパイラは各型（ベース型からインスタンス化された型まで）の構築子の中に追加のコードを生成し，ユーザコードの前に追加します。ユーザーが構築子を定義しなくても，コンパイラはデフォルトの構築子を生成し，vptr の初期化が行われます（ベース型の vtbl アドレスからインスタンス化された型の vtbl アドレスまで）。そのため、多相型のオブジェクトが生成されるたびに、vptr は正しく初期化され、最終的にそのインスタンス化された型の vtbl を指すようになります。
- 最後に、オブジェクトが破壊されるときには、解体子が逆の順序で（インスタンス化された型からベース型まで）呼び出されます。コンパイラは、各型の解体子の中に追加のコードを生成して、ユーザコードの後に追加します。ユーザーが解体子を定義していなくても，コンパイラはデフォルトの解体子を生成し，vptr の初期化解除が行われます（インスタンス化された型の vtbl アドレスからベース型のものまで）。
- この vptr 値の段階的な初期化/非初期化は，各構築子/解体子のユーザコードが，構築/破棄の連続した段階で正しい型レベルのポリモーフィック手続きを呼び出せるようにするために必須です．

組み込みの Object 型は、Extends 宣言を使って派生したすべての型に対して、RTTI（Run-Time Type Information）能力を提供します：

- RTTI 能力により、実行時にオブジェクトの実際の型を判別することができ、それはコンパイル時のものとは異なる場合があります。
- 演算子 Is (rtti)はこれを使って、オブジェクトがコンパイル時の型から派生した型と互換性があるかどうかをチェックします。なぜなら、RTTI はオブジェクトの実際の実行時の型名だけでなく、組み込み型である Object までの基本型のすべての型名を提供するからです。
- それにもかかわらず、RTTI によって保存されたこれらの型名（vtbl 内の特定のポインタによって参照される）は、FreeBASIC キーワードから直接アクセスできないめちゃくちゃの名前です。

オブジェクトのインスタンス、vptr、vtbl（vtable）、RTTI情報の、各エンティティはどのように連鎖しているか：

- インスタンス -> Vptr -> Vtbl -> RTTI 情報の連鎖：

- オブジェクトの組み込み型から（直接または間接的に）派生した型では、そのデータ項目（自己または継承されたもの）の先頭（オフセット 0 に位置する）に隠しポインタ vptr が追加されます。この vptr は，対象となる型の仮想テーブル vtbl を指します。
- vtbl には、すべての抽象/仮想手続きのアドレスのリストが含まれています（オフセット 0 から）。vtbl はまた、考慮された型の実行時型情報（RTTI）情報ブロックへのポインタを含んでいます（オフセット -1 に位置する）。
- RTTI 情報ブロックは、対象となる型の mangled-typename（アスキー文字）へのポインタを含みます（オフセット +1 に位置する）。RTTI 情報ブロックはまた、その Base の RTTI 情報ブロックへのポインタを含みます（オフセット +2 に位置する）。上の階層の RTTI 情報ブロックはすべてこのように連鎖しています。

- Instance -> Vptr -> Vtbl -> RTTI info diagram:

'                                      vtbl (vtable)
'                                  .-------------------.
'                              [-2]|   reserved (0)    |               RTTI info                Mangled Typename
'                                  |-------------------|       .-----------------------.       .---------------.
'         Instance of UDT      [-1]| Ptr to RTTI info  |--->[0]|     reserved (0)      |       |Typename string|
'      .-------------------.       |-------------------|       |-----------------------|       |     with      |
'   [0]| vptr: Ptr to vtbl |--->[0]|Ptr to virt proc #1|   [+1]|Ptr to Mangled Typename|--->[0]| length (ASCII)|
'      |-------------------|       |-------------------|       |-----------------------|       |       &       |
'      |UDT member field #a|   [+1]|Ptr to virt proc #2|   [+2]| Ptr to Base RTTI info |---.   |  name (ASCII) |
'      |-------------------|       |-------------------|       |_______________________|   |   |      for      |
'      |UDT member field #b|   [+2]|Ptr to virt proc #3|   ________________________________|   |each component |
'      |-------------------|       :- - - - - - - - - -:  |                                    |_______________|
'      |UDT member field #c|       :                   :  |             Base RTTI info
'      :- - - - - - - - - -:       :                   :  |       .----------------------------.
'      :                   :       |___________________|  '--->[0]|        reserved (0)        |
'      :                   :                                      |----------------------------|
'      |___________________|                                  [+1]|Ptr to Mangled Base Typename|--->
'                                                                 |----------------------------|
'                                                             [+2]| Ptr to Base.Base RTTI info |---.
'                                                                 |____________________________|   |
'                                                                                                  |
'                                                                                                  V

このページの頭に戻る

2. 真の動作と忠実なエミュレーションの両方で示される継承多型メカニズム

以下の提案例では、ポリモーフィズムの仕組みに必要なすべての要素をより適切に引き出すために、多型の部分を分解しています。

継承ポリモーフィズムの例、真の操作： '動物型コレクション'

選ばれた一般的な基本型は、任意の 'animal' である（抽象化）。
特化した派生型は 'dog', 'cat', 'bird' である（それぞれ型名を含む非静的な文字列メンバを定義する）。
汎用基本型で宣言され、それぞれの特殊化された派生型で定義する必要がある抽象的な手続きは次のとおりです：

- 'addr_override_fct()': returns the instance address,
- 'speak_override_fct()': returns the way of speaking,
- 'type_override_sub()': prints the type-name (from a string member with initialyzer).

'animal' 型宣言（汎用ベース型）:
- 3つのパブリックな抽象手続き（'addr_override_fct()', 'speak_override_fct()', 'type_override_sub()'）が宣言されています（ただし、それらを定義するボディはない）。
- このベース型は、少なくとも抽象手続きを含んでいるため、実体のないものです。
```
'Base-type animal:
	Type animal Extends Object
		Public:
			Declare Abstract Function addr_override_fct () As animal Ptr
			Declare Abstract Function speak_override_fct () As String
			Declare Abstract Sub type_override_sub ()
	End Type
```

'dog', 'cat', 'bird' 型宣言 (特化型派生型):

- 派生型ごとに、3つの同じパブリック手続き（'addr_override_fct()', 'speak_override_fct()', 'type_override_sub()'）が仮想的に宣言され、その本体は派生型ごとに特化されています。
- 派生型ごとに、その型名で初期化された非静的な文字列メンバー。
- 各派生型は、その基底部で宣言されたすべての抽象手続きを実装しているため、インスタンス化が可能です。

'Derived-type dog:
	Type dog Extends animal
		Public:
			Declare Virtual Function addr_override_fct () As animal Ptr Override
			Declare Virtual Function speak_override_fct () As String Override
			Declare Virtual Sub type_override_sub () Override
		Private:
			Dim As String animal_type = "dog"
	End Type

'Derived-type cat:
	Type cat Extends animal
		Public:
			Declare Virtual Function addr_override_fct () As animal Ptr Override
			Declare Virtual Function speak_override_fct () As String Override
			Declare Virtual Sub type_override_sub () Override
		Private:
			Dim As String animal_type = "cat"
	End Type

'Derived-type bird:
	Type bird Extends animal
		Public:
			Declare Virtual Function addr_override_fct () As animal Ptr Override
			Declare Virtual Function speak_override_fct () As String Override
			Declare Virtual Sub type_override_sub () Override
		Private:
			Dim As String animal_type = "bird"
	End Type

例の全コード:
- ポリモーフィズムを発生させるために、基本型のポインタ配列('animal_list')を宣言し、異なる派生型(犬、猫、鳥)のインスタンスで初期化して、異なる型のオブジェクトのコレクションを構成します(ただし、すべての基本型は共通です)。
- つまり、同じコンパイルされたコード行は、ループ（反復子 'I'）に入れられ、異なる型のすべてのインスタンス（'animal_list(I)->addr_override_fct()', 'animal_list(I)->speak_override_fct()', 'animal_list(I)->type_override_sub()'）を処理します。これはポリモーフィズムの仕組みにより、実行時にそれぞれの特殊化された手続きを呼び出すことができるからです。

'Base-type animal:
Type animal Extends Object
Public:
Declare Abstract Function addr_override_fct () As animal Ptr
Declare Abstract Function speak_override_fct () As String
Declare Abstract Sub type_override_sub ()
End Type

'Derived-type dog:
Type dog Extends animal
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
Private:
Dim As String animal_type = "dog"
End Type

'override_sub procedures for dog object:
Virtual Function dog.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function dog.speak_override_fct () As String
Return "Woof!"
End Function
Virtual Sub dog.type_override_sub ()
Print This.animal_type
End Sub

'Derived-type cat:
Type cat Extends animal
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
Private:
Dim As String animal_type = "cat"
End Type

'override_sub mehods for cat object:
Virtual Function cat.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function cat.speak_override_fct () As String
Return "Meow!"
End Function
Virtual Sub cat.type_override_sub ()
Print This.animal_type
End Sub

'Derived-type bird:
Type bird Extends animal
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
Private:
Dim As String animal_type = "bird"
End Type

'override_sub mehods for bird object:
Virtual Function bird.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function bird.speak_override_fct () As String
Return "Cheep!"
End Function
Virtual Sub bird.type_override_sub ()
Print This.animal_type
End Sub

'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
Dim As dog Ptr p_my_dog = New dog
Dim As cat Ptr p_my_cat = New cat
Dim As bird Ptr p_my_bird = New bird
Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

'Have the animals speak and eat:
Print "INHERITANCE POLYMORPHISM", "@object", "speak", "type"
Print " true operating"
For I As Integer = LBound(animal_list) To UBound(animal_list)
Print " animal #" & I & ":",
Print animal_list(I)->addr_override_fct(), 'real polymorphism
Print animal_list(I)->speak_override_fct(), 'real polymorphism
animal_list(I)->type_override_sub() 'real polymorphism
Next I

Sleep

Delete p_my_dog
Delete p_my_cat
Delete p_my_bird

出力:
INHERITANCE POLYMORPHISM @object speak type true operating animal #1: 11479616 Woof! dog animal #2: 11479688 Meow! cat animal #3: 11479760 Cheep! bird

'動物型コレクション' の実際の動作に非常に近い多相性エミュレーションの例

このサブタイプの多相性のエミュレーションは、実際の動作に非常に近いものです：

- 静的手続きのポインタテーブル 'callback_table()' は、vtbl をエミュレートするために、派生型ごとに定義されています（インスタンス参照は、非静的メンバ手続きに渡される隠れた 'This' 参照をエミュレートするために、各静的手続きの第一パラメータとして渡されます）。

'Derived-type dog:
	Type dog Extends animal
		Private:
			Static As Any Ptr callback_table(0 To 2)
		Public:
			Declare Static Function addr_callback_fct (Byref As dog) As animal Ptr
			Declare Static Function speak_callback_fct (Byref As dog) As String
			Declare Static Sub type_callback_sub (Byref As dog)
			Declare Constructor ()
		Private:
			Dim As String animal_type = "dog"
	End Type
	Static As Any Ptr dog.callback_table(0 To 2) = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}

'Derived-type cat:
	Type cat Extends animal
		Private:
			Static As Any Ptr callback_table(0 To 2)
		Public:
			Declare Static Function addr_callback_fct (Byref As cat) As animal Ptr
			Declare Static Function speak_callback_fct (Byref As cat) As String
			Declare Static Sub type_callback_sub (Byref As cat)
			Declare Constructor ()
		Private:
			Dim As String animal_type = "cat"
	End Type
	Static As Any Ptr cat.callback_table(0 To 2) = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}

'Derived-type bird:
	Type bird Extends animal
		Private:
			Static As Any Ptr callback_table(0 To 2)
		Public:
			Declare Static Function addr_callback_fct (Byref As bird) As animal Ptr
			Declare Static Function speak_callback_fct (Byref As bird) As String
			Declare Static Sub type_callback_sub (Byref As bird)
			Declare Constructor ()
		Private:
			Dim As String animal_type = "bird"
	End Type
	Static As Any Ptr bird.callback_table(0 To 2) = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}

- ベース型レベルでは、非静的ポインタ 'callback_ptr' は、vptr をエミュレートするため、任意の派生型インスタンスに対して、割り当てられます（構築子で初期化されるその値は、どの派生型が構築されたかによって異なります：以下に説明するテーブルのアドレス）。
- ベース型レベルでは、各抽象手続きは、'callback_ptr' / 'callback_table(I)' （'I' はこの手続きに対応するテーブル内のインデックス）を介して適切な派生手続きを呼び出すメンバー手続きで置き換えられます。

'Base-type animal:
	Type animal
		Protected:
			Dim As Any Ptr Ptr callback_ptr
		Public:
			Declare Function addr_callback_fct () As animal Ptr
			Declare Function speak_callback_fct () As String
			Declare Sub type_callback_sub ()
	End Type

	Function animal.addr_callback_fct () As animal Ptr
		Return Cptr(Function (Byref As animal) As animal Ptr, This.callback_ptr[0])(This)
	End Function
	Function animal.speak_callback_fct () As String
		Return Cptr(Function (Byref As animal) As String, This.callback_ptr[1])(This)
	End Function
	Sub animal.type_callback_sub ()
		Cptr(Sub (Byref As animal), This.callback_ptr[2])(This)
	End Sub

エミュレーションの全コード:
' Emulation of polymorphism is very close to the real operating:
' - a non static pointer is allocated for any derived-type instance to emulate the vptr
' (its value will depend on what derived-type is constructed: address of the following table)
' - a static procedure pointer table is defined for each derived type to emulate the vtable
' (an instance reference is passed as first parameter to each static procedure to emulate the hidden 'This' reference passed to any non-static member procedure)

'Base-type animal:
Type animal
Protected:
Dim As Any Ptr Ptr callback_ptr
Public:
Declare Function addr_callback_fct () As animal Ptr
Declare Function speak_callback_fct () As String
Declare Sub type_callback_sub ()
End Type

Function animal.addr_callback_fct () As animal Ptr
Return CPtr(Function (ByRef As animal) As animal Ptr, This.callback_ptr[0])(This)
End Function
Function animal.speak_callback_fct () As String
Return CPtr(Function (ByRef As animal) As String, This.callback_ptr[1])(This)
End Function
Sub animal.type_callback_sub ()
CPtr(Sub (ByRef As animal), This.callback_ptr[2])(This)
End Sub

'Derived-type dog:
Type dog Extends animal
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As dog) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As dog) As String
Declare Static Sub type_callback_sub (ByRef As dog)
Declare Constructor ()
Private:
Dim As String animal_type = "dog"
End Type
Static As Any Ptr dog.callback_table(0 To 2) = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}

'callback_sub methods + constructor for dog object:
Static Function dog.addr_callback_fct (ByRef d As dog) As animal Ptr
Return @d
End Function
Static Function dog.speak_callback_fct (ByRef d As dog) As String
Return "Woof!"
End Function
Static Sub dog.type_callback_sub (ByRef d As dog)
Print d.animal_type
End Sub
Constructor dog ()
This.callback_ptr = @callback_table(0)
End Constructor

'Derived-type cat:
Type cat Extends animal
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As cat) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As cat) As String
Declare Static Sub type_callback_sub (ByRef As cat)
Declare Constructor ()
Private:
Dim As String animal_type = "cat"
End Type
Static As Any Ptr cat.callback_table(0 To 2) = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}

'callback_sub mehods + constructor for cat object:
Static Function cat.addr_callback_fct (ByRef c As cat) As animal Ptr
Return @c
End Function
Static Function cat.speak_callback_fct (ByRef c As cat) As String
Return "Meow!"
End Function
Static Sub cat.type_callback_sub (ByRef c As cat)
Print c.animal_type
End Sub
Constructor cat ()
This.callback_ptr = @callback_table(0)
End Constructor

'Derived-type bird:
Type bird Extends animal
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As bird) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As bird) As String
Declare Static Sub type_callback_sub (ByRef As bird)
Declare Constructor ()
Private:
Dim As String animal_type = "bird"
End Type
Static As Any Ptr bird.callback_table(0 To 2) = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}

'callback_sub mehods + constructor for bird object:
Static Function bird.addr_callback_fct (ByRef b As bird) As animal Ptr
Return @b
End Function
Static Function bird.speak_callback_fct (ByRef b As bird) As String
Return "Cheep!"
End Function
Static Sub bird.type_callback_sub (ByRef b As bird)
Print b.animal_type
End Sub
Constructor bird ()
This.callback_ptr = @callback_table(0)
End Constructor

'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
Dim As dog Ptr p_my_dog = New dog
Dim As cat Ptr p_my_cat = New cat
Dim As bird Ptr p_my_bird = New bird
Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

'Have the animals speak and eat:
Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
Print " by emulation"
For I As Integer = LBound(animal_list) To UBound(animal_list)
Print " animal #" & I & ":",
Print animal_list(I)->addr_callback_fct(), 'emulated polymorphism
Print animal_list(I)->speak_callback_fct(), 'emulated polymorphism
animal_list(I)->type_callback_sub() 'emulated polymorphism
Next I

Sleep

Delete p_my_dog
Delete p_my_cat
Delete p_my_bird

出力:
SUB-TYPE POLYMORPHISM @object speak type by emulation animal #1: 12462656 Woof! dog animal #2: 12462728 Meow! cat animal #3: 12462800 Cheep! bird

同じ例で、'動物型コレクション' の実際のコードとエミュレーションコードの両方がある場合

比較しやすいように、実コードとエミュレーション・コードを、1つのコードに入れ子にしています：

' Emulated polymorphism (with explicit callback member procedures)
' and
' True polymorphism (with abstract/virtual member procedures),
' both in an inheritance structure.

'Base-type animal:
Type animal Extends Object 'Extends Object' useful for true polymorphism only
' for true polymorphism:
Public:
Declare Abstract Function addr_override_fct () As animal Ptr
Declare Abstract Function speak_override_fct () As String
Declare Abstract Sub type_override_sub ()
' for polymorphism emulation:
Protected:
Dim As Any Ptr Ptr callback_ptr
Public:
Declare Function addr_callback_fct () As animal Ptr
Declare Function speak_callback_fct () As String
Declare Sub type_callback_sub ()
End Type

' for polymorphism emulation:
Function animal.addr_callback_fct () As animal Ptr
Return CPtr(Function (ByRef As animal) As animal Ptr, This.callback_ptr[0])(This)
End Function
Function animal.speak_callback_fct () As String
Return CPtr(Function (ByRef As animal) As String, This.callback_ptr[1])(This)
End Function
Sub animal.type_callback_sub ()
CPtr(Sub (ByRef As animal), This.callback_ptr[2])(This)
End Sub

'Derived-type dog:
Type dog Extends animal
' for true polymorphism:
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
' for polymorphism emulation:
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As dog) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As dog) As String
Declare Static Sub type_callback_sub (ByRef As dog)
Declare Constructor ()
' for all:
Private:
Dim As String animal_type = "dog"
End Type

' for true polymorphism:
' override_sub methods for dog object:
Virtual Function dog.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function dog.speak_override_fct () As String
Return "Woof!"
End Function
Virtual Sub dog.type_override_sub ()
Print This.animal_type
End Sub

' for polymorphism emulation:
Static As Any Ptr dog.callback_table(0 To 2) = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}
'callback_sub methods + constructor for dog object:
Static Function dog.addr_callback_fct (ByRef d As dog) As animal Ptr
Return @d
End Function
Static Function dog.speak_callback_fct (ByRef d As dog) As String
Return "Woof!"
End Function
Static Sub dog.type_callback_sub (ByRef d As dog)
Print d.animal_type
End Sub
Constructor dog ()
This.callback_ptr = @callback_table(0)
End Constructor

'Derived-type cat:
Type cat Extends animal
' for true polymorphism:
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
' for polymorphism emulation:
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As cat) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As cat) As String
Declare Static Sub type_callback_sub (ByRef As cat)
Declare Constructor ()
' for all:
Private:
Dim As String animal_type = "cat"
End Type

' for true polymorphism:
' override_sub mehods for cat object:
Virtual Function cat.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function cat.speak_override_fct () As String
Return "Meow!"
End Function
Virtual Sub cat.type_override_sub ()
Print This.animal_type
End Sub

' for polymorphism emulation:
Static As Any Ptr cat.callback_table(0 To 2) = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}
' callback_sub mehods + constructor for cat object:
Static Function cat.addr_callback_fct (ByRef c As cat) As animal Ptr
Return @c
End Function
Static Function cat.speak_callback_fct (ByRef c As cat) As String
Return "Meow!"
End Function
Static Sub cat.type_callback_sub (ByRef c As cat)
Print c.animal_type
End Sub
Constructor cat ()
This.callback_ptr = @callback_table(0)
End Constructor

'Derived-type bird:
Type bird Extends animal
' for true polymorphism:
Public:
Declare Virtual Function addr_override_fct () As animal Ptr Override
Declare Virtual Function speak_override_fct () As String Override
Declare Virtual Sub type_override_sub () Override
' for polymorphism emulation:
Private:
Static As Any Ptr callback_table(0 To 2)
Public:
Declare Static Function addr_callback_fct (ByRef As bird) As animal Ptr
Declare Static Function speak_callback_fct (ByRef As bird) As String
Declare Static Sub type_callback_sub (ByRef As bird)
Declare Constructor ()
' for all:
Private:
Dim As String animal_type = "bird"
End Type

' for true polymorphism:
' override_sub mehods for bird object:
Virtual Function bird.addr_override_fct () As animal Ptr
Return @This
End Function
Virtual Function bird.speak_override_fct () As String
Return "Cheep!"
End Function
Virtual Sub bird.type_override_sub ()
Print This.animal_type
End Sub

' for polymorphism emulation:
Static As Any Ptr bird.callback_table(0 To 2) = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}
' callback_sub mehods + constructor for bird object:
Static Function bird.addr_callback_fct (ByRef b As bird) As animal Ptr
Return @b
End Function
Static Function bird.speak_callback_fct (ByRef b As bird) As String
Return "Cheep!"
End Function
Static Sub bird.type_callback_sub (ByRef b As bird)
Print b.animal_type
End Sub
Constructor bird ()
This.callback_ptr = @callback_table(0)
End Constructor

'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
Dim As dog Ptr p_my_dog = New dog
Dim As cat Ptr p_my_cat = New cat
Dim As bird Ptr p_my_bird = New bird
Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

'Have the animals speak and eat:
Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
For I As Integer = LBound(animal_list) To UBound(animal_list)
Print " animal #" & I & ":"
' for override_sub:
Print " true operating:",
Print animal_list(I)->addr_override_fct(), 'real polymorphism
Print animal_list(I)->speak_override_fct(), 'real polymorphism
animal_list(I)->type_override_sub() 'real polymorphism
' for polymorphism emulation:
Print " by emulation:",
Print animal_list(I)->addr_callback_fct(), 'emulated polymorphism
Print animal_list(I)->speak_callback_fct(), 'emulated polymorphism
animal_list(I)->type_callback_sub() 'emulated polymorphism
Next I

Sleep

Delete p_my_dog
Delete p_my_cat
Delete p_my_bird

出力:

SUB-TYPE POLYMORPHISM       @object       speak         type
   animal #1:
	  true operating:       11217472      Woof!         dog
	  by emulation:         11217472      Woof!         dog
   animal #2:
	  true operating:       11217552      Meow!         cat
	  by emulation:         11217552      Meow!         cat
   animal #3:
	  true operating:       11217632      Cheep!        bird
	  by emulation:         11217632      Cheep!        bird

このページの頭に戻る

3. RTTI 情報から復号化(demangle)された型名を抽出

めった切り(mangle)した型名を RTTI 情報から抽出します：

- インスタンスアドレスから、二重間接参照（オフセット：[0][-1]）でインスタンスの型の RTTI 情報ポインタにアクセスします。
- 上述の RTTI 情報ポインタのチェイニングにより、継承階層で選択された型の RTTI 情報にアクセスすることができます（Object の組み込み型まで）。これは、ポインタ間接参照（オフセット：[+2]）の反復によって行われます。
- その後、選択しためった切り(mangle)された型名にアクセスします (オフセット: [+1] の最終間接参照)。

めった切り(mangle)された型名を抽出するための関数 'mangledTypeNameFromRTTI()'：

Function mangledTypeNameFromRTTI (Byval po As Object Ptr, Byval baseIndex As Integer = 0) As String
	' Function to get any mangled-typename in the inheritance up hierarchy
	' of the type of an instance (address: 'po') compatible with the built-in 'Object'
	'
	' ('baseIndex =  0' to get the mangled-typename of the instance)
	' ('baseIndex = -1' to get the base mangled-typename of the instance, or "" if not existing)
	' ('baseIndex = -2' to get the base.base mangled-typename of the instance, or "" if not existing)
	' (.....)
	'
		Dim As String s
		Dim As Zstring Ptr pz
		Dim As Any Ptr p = Cptr(Any Ptr Ptr Ptr, po)[0][-1]  ' Ptr to RTTI info
		For I As Integer = baseIndex To -1
			p = Cptr(Any Ptr Ptr, p)[2]                  ' Ptr to Base RTTI info of previous RTTI info
			If p = 0 Then Return s
		Next I
		pz = Cptr(Any Ptr Ptr, p)[1]                         ' Ptr to mangled-typename
		s = *pz
		Return s
End Function

名前空間ブロック内で宣言された継承構造（3つの派生レベル）の、RTTI 情報からのマングルされた型名の抽出例：

出力:

Mangled typenames list, from RTTI info:
  N3OOP10GRANDCHILDE
  N3OOP5CHILDE
  N3OOP6PARENTE
  6OBJECT

マングリングされた型名の実装

上記の出力から、型名のマングリング処理は、以下のような形式で強調表示できます：

N3OOP10GRANDCHILDE
(for 'oop.grandchild')

N3OOP5CHILDE
(for 'oop.child')

N3OOP6PARENTE
(for 'oop.parent')

6OBJECT
(for 'Object')

RTTI 情報の型名のマングル処理の詳細:

- マングルされた型名は Zstring です（最後は null 文字で終わる）。
- 完全な型名（大文字に変換）の各構成要素（区切り文字としての 1つのドット）の前には、ASCII自体でエンコードされた文字数が（長さを固定した文字列に基づいて）付けられます。
- 型が少なくとも 1つの名前空間の中にある場合、マングルされた型名の文字列は追加の "N" で始まり、追加の "E" で終わります。

(Nested-name ... Ending から接頭辞 "N "と接尾辞 "E")

RTTI 情報から型名を抽出（デマンリング）する

前述の関数('mangledTypeNameFromRTTI()')は、デマンリング処理で完成させることができます。

デマングルされた型名を抽出する関数 'typeNameFromRTTI()'：

Function typeNameFromRTTI (Byval po As Object Ptr, Byval baseIndex As Integer = 0) As String
	' Function to get any typename in the inheritance up hierarchy
	' of the type of an instance (address: 'po') compatible with the built-in 'Object'
	'
	' ('baseIndex =  0' to get the typename of the instance)
	' ('baseIndex = -1' to get the base.typename of the instance, or "" if not existing)
	' ('baseIndex = -2' to get the base.base.typename of the instance, or "" if not existing)
	' (.....)
	'
		Dim As String s
		Dim As Zstring Ptr pz
		Dim As Any Ptr p = Cptr(Any Ptr Ptr Ptr, po)[0][-1]     ' Ptr to RTTI info
		For I As Integer = baseIndex To -1
			p = Cptr(Any Ptr Ptr, p)[2]                     ' Ptr to Base RTTI info of previous RTTI info
			If p = 0 Then Return s
		Next I
		pz = Cptr(Any Ptr Ptr, p)[1]                            ' Ptr to mangled-typename
		Do
			Do While (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
				If (*pz)[0] = 0 Then Return s
				pz += 1
			Loop
			Dim As Integer N = Val(*pz)
			Do
				pz += 1
			Loop Until (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
			If s <> "" Then s &= "."
			s &= Left(*pz, N)
			pz += N
		Loop
End Function

先の例は、上の関数を使って完成します：

出力:

Mangled typenames list, from RTTI info:
  N3OOP10GRANDCHILDE
  N3OOP5CHILDE
  N3OOP6PARENTE
  6OBJECT

Typenames (demangled) list, from RTTI info:
  OOP.GRANDCHILD
  OOP.CHILD
  OOP.PARENT
  OBJECT

RTTI 情報から型名(demangled)とそのベース型階層のすべてを一度に抽出します

減少するパラメーター 'baseIndex' を（値 0 から）使ってループ内の前の関数を呼び出し、空の文字列が返されるとすぐに停止するだけです。最後に、異なる型名を階層的に区切った文字列を返します。

関数 'typeNameHierarchyFromRTTI()' は、分割された型名とそのベース型の階層のすべてを抽出します：

Function typeNameHierarchyFromRTTI (Byval po As Object Ptr) As String
	' Function to get the typename inheritance up hierarchy
	' of the type of an instance (address: po) compatible with the built-in 'Object'
	'
		Dim As String s = TypeNameFromRTTI(po)
		Dim As Integer i = -1
		Do
			Dim As String s0 = typeNameFromRTTI(po, i)
			If s0 = "" Then Exit Do
			s &= "->" & s0
			i -= 1
		Loop
		Return s
End Function

上の関数を使って、前の例を再び完成させました：

Namespace oop
Type parent Extends Object
End Type

Type child Extends parent
End Type

Type grandchild Extends child
End Type
End Namespace

Function mangledTypeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
' Function to get any mangled-typename in the inheritance up hierarchy
' of the type of an instance (address: 'po') compatible with the built-in 'Object'
'
' ('baseIndex = 0' to get the mangled-typename of the instance)
' ('baseIndex = -1' to get the base mangled-typename of the instance, or "" if not existing)
' ('baseIndex = -2' to get the base.base mangled-typename of the instance, or "" if not existing)
' (.....)
'
Dim As String s
Dim As ZString Ptr pz
Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1] ' Ptr to RTTI info
For I As Integer = baseIndex To -1
p = CPtr(Any Ptr Ptr, p)[2] ' Ptr to Base RTTI info of previous RTTI info
If p = 0 Then Return s
Next I
pz = CPtr(Any Ptr Ptr, p)[1] ' Ptr to mangled-typename
s = *pz
Return s
End Function

Function typeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
' Function to get any typename in the inheritance up hierarchy
' of the type of an instance (address: 'po') compatible with the built-in 'Object'
'
' ('baseIndex = 0' to get the typename of the instance)
' ('baseIndex = -1' to get the base.typename of the instance, or "" if not existing)
' ('baseIndex = -2' to get the base.base.typename of the instance, or "" if not existing)
' (.....)
'
Dim As String s
Dim As ZString Ptr pz
Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1] ' Ptr to RTTI info
For I As Integer = baseIndex To -1
p = CPtr(Any Ptr Ptr, p)[2] ' Ptr to Base RTTI info of previous RTTI info
If p = 0 Then Return s
Next I
pz = CPtr(Any Ptr Ptr, p)[1] ' Ptr to mangled-typename
Do
Do While (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If (*pz)[0] = 0 Then Return s
pz += 1
Loop
Dim As Integer N = Val(*pz)
Do
pz += 1
Loop Until (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If s <> "" Then s &= "."
s &= Left(*pz, N)
pz += N
Loop
End Function

Function typeNameHierarchyFromRTTI (ByVal po As Object Ptr) As String
' Function to get the typename inheritance up hierarchy
' of the type of an instance (address: po) compatible with the built-in 'Object'
'
Dim As String s = TypeNameFromRTTI(po)
Dim As Integer i = -1
Do
Dim As String s0 = typeNameFromRTTI(po, i)
If s0 = "" Then Exit Do
s &= "->" & s0
i -= 1
Loop
Return s
End Function

Dim As Object Ptr p = New oop.grandchild

Print "Mangled typenames list, from RTTI info:"
Print " " & mangledTypeNameFromRTTI(p, 0)
Print " " & mangledTypeNameFromRTTI(p, -1)
Print " " & mangledTypeNameFromRTTI(p, -2)
Print " " & mangledTypeNameFromRTTI(p, -3)
Print
Print "Typenames (demangled) list, from RTTI info:"
Print " " & typeNameFromRTTI(p, 0)
Print " " & typeNameFromRTTI(p, -1)
Print " " & typeNameFromRTTI(p, -2)
Print " " & typeNameFromRTTI(p, -3)
Print
Print "Typename (demangled) and all those of its base-types hierarchy, from RTTI info:"
Print " " & typeNameHierarchyFromRTTI(p)
Delete p

Sleep

出力:

Mangled typenames list, from RTTI info:
  N3OOP10GRANDCHILDE
  N3OOP5CHILDE
  N3OOP6PARENTE
  6OBJECT

Typenames (demangled) list, from RTTI info:
  OOP.GRANDCHILD
  OOP.CHILD
  OOP.PARENT
  OBJECT

Typename (demangled) and all those of its base-types hierarchy, from RTTI info:
  OOP.GRANDCHILD->OOP.CHILD->OOP.PARENT->OBJECT

RTTI 情報から抽出された型名（demangled）を文字列変数と比較する

デマンリングの様々なステップとして、RTTI 情報から抽出された型名の連続した要素は、提供されたチェーンの要素と比較されます（要素が異なるとすぐに "false" が返されます）。

RTTI 情報から抽出された型名(demangled)と文字列変数を比較する関数 'typeNameEqualFromRTTI()'：

Function typeNameEqualFromRTTI (Byval po As Object Ptr, Byref typeName As String) As Boolean
	' Function to get true if the instance typename (address: po) is the same than the passed string
	'
		Dim As String t = Ucase(typeName)
		Dim As ZString Ptr pz = Cptr(Any Ptr Ptr Ptr Ptr, po)[0][-1][1] ' Ptr to Mangled Typename
		Dim As Integer i = 1
		Do
			Do While (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
				If (*pz)[0] = 0 Then Return True
				pz += 1
			Loop
			Dim As Integer N = Val(*pz)
			Do
				pz += 1
			Loop Until (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
			If i > 1 Then
				If Mid(t, i, 1) <> "." Then Return False Else i += 1
			End If
			If Mid(t, i, N) <> Left(*pz, N) Then Return False Else pz += N : i += N
		Loop
End Function

上の関数で、前の例は、最終的に完成しました：

Namespace oop
Type parent Extends Object
End Type

Type child Extends parent
End Type

Type grandchild Extends child
End Type
End Namespace

Function mangledTypeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
' Function to get any mangled-typename in the inheritance up hierarchy
' of the type of an instance (address: 'po') compatible with the built-in 'Object'
'
' ('baseIndex = 0' to get the mangled-typename of the instance)
' ('baseIndex = -1' to get the base mangled-typename of the instance, or "" if not existing)
' ('baseIndex = -2' to get the base.base mangled-typename of the instance, or "" if not existing)
' (.....)
'
Dim As String s
Dim As ZString Ptr pz
Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1] ' Ptr to RTTI info
For I As Integer = baseIndex To -1
p = CPtr(Any Ptr Ptr, p)[2] ' Ptr to Base RTTI info of previous RTTI info
If p = 0 Then Return s
Next I
pz = CPtr(Any Ptr Ptr, p)[1] ' Ptr to mangled-typename
s = *pz
Return s
End Function

Function typeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
' Function to get any typename in the inheritance up hierarchy
' of the type of an instance (address: 'po') compatible with the built-in 'Object'
'
' ('baseIndex = 0' to get the typename of the instance)
' ('baseIndex = -1' to get the base.typename of the instance, or "" if not existing)
' ('baseIndex = -2' to get the base.base.typename of the instance, or "" if not existing)
' (.....)
'
Dim As String s
Dim As ZString Ptr pz
Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1] ' Ptr to RTTI info
For I As Integer = baseIndex To -1
p = CPtr(Any Ptr Ptr, p)[2] ' Ptr to Base RTTI info of previous RTTI info
If p = 0 Then Return s
Next I
pz = CPtr(Any Ptr Ptr, p)[1] ' Ptr to mangled-typename
Do
Do While (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If (*pz)[0] = 0 Then Return s
pz += 1
Loop
Dim As Integer N = Val(*pz)
Do
pz += 1
Loop Until (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If s <> "" Then s &= "."
s &= Left(*pz, N)
pz += N
Loop
End Function

Function typeNameHierarchyFromRTTI (ByVal po As Object Ptr) As String
' Function to get the typename inheritance up hierarchy
' of the type of an instance (address: po) compatible with the built-in 'Object'
'
Dim As String s = TypeNameFromRTTI(po)
Dim As Integer i = -1
Do
Dim As String s0 = typeNameFromRTTI(po, i)
If s0 = "" Then Exit Do
s &= "->" & s0
i -= 1
Loop
Return s
End Function

Function typeNameEqualFromRTTI (ByVal po As Object Ptr, ByRef typeName As String) As Boolean
' Function to get true if the instance typename (address: po) is the same than the passed string
'
Dim As String t = UCase(typeName)
Dim As ZString Ptr pz = CPtr(Any Ptr Ptr Ptr Ptr, po)[0][-1][1] ' Ptr to Mangled Typename
Dim As Integer i = 1
Do
Do While (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If (*pz)[0] = 0 Then Return True
pz += 1
Loop
Dim As Integer N = Val(*pz)
Do
pz += 1
Loop Until (*pz)[0] > Asc("9") Orelse (*pz)[0] < Asc("0")
If i > 1 Then
If Mid(t, i, 1) <> "." Then Return False Else i += 1
End If
If Mid(t, i, N) <> Left(*pz, N) Then Return False Else pz += N : i += N
Loop
End Function

Dim As Object Ptr p = New oop.grandchild

Print "Mangled typenames list, from RTTI info:"
Print " " & mangledTypeNameFromRTTI(p, 0)
Print " " & mangledTypeNameFromRTTI(p, -1)
Print " " & mangledTypeNameFromRTTI(p, -2)
Print " " & mangledTypeNameFromRTTI(p, -3)
Print
Print "Typenames (demangled) list, from RTTI info:"
Print " " & typeNameFromRTTI(p, 0)
Print " " & typeNameFromRTTI(p, -1)
Print " " & typeNameFromRTTI(p, -2)
Print " " & typeNameFromRTTI(p, -3)
Print
Print "Typename (demangled) and all those of its base-types hierarchy, from RTTI info:"
Print " " & typeNameHierarchyFromRTTI(p)
Delete p
Print
p = New oop.child
Print "Is the typename of an oop.child instance the same as ""child""?"
Print " " & typeNameEqualFromRTTI(p, "child")
Print "Is the typename of an oop.child instance the same as ""oop.child""?"
Print " " & typeNameEqualFromRTTI(p, "oop.child")
Print "Is the typename of an oop.child instance the same as ""oop.grandchild""?"
Print " " & typeNameEqualFromRTTI(p, "oop.grandchild")
Print "Is the typename of an oop.child instance the same as ""oop.parent""?"
Print " " & typeNameEqualFromRTTI(p, "oop.parent")
Delete p

Sleep

出力:

Mangled typenames list, from RTTI info:
  N3OOP10GRANDCHILDE
  N3OOP5CHILDE
  N3OOP6PARENTE
  6OBJECT

Typenames (demangled) list, from RTTI info:
  OOP.GRANDCHILD
  OOP.CHILD
  OOP.PARENT
  OBJECT

Typename (demangled) and all those of its base-types hierarchy, from RTTI info:
  OOP.GRANDCHILD->OOP.CHILD->OOP.PARENT->OBJECT

Is the typename of an oop.child instance the same as "child"?
  false
Is the typename of an oop.child instance the same as "oop.child"?
  true
Is the typename of an oop.child instance the same as "oop.grandchild"?
  false
Is the typename of an oop.child instance the same as "oop.parent"?
  false

このページの頭に戻る

参照:

プログラマーのための案内に戻る

目次に戻る

FreeBASIC ProPgObjectRtti

OBJECT 組み込みと RTTI 情報 左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

OBJECT 組み込みと RTTI 情報　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい