FreeBASIC マニュアルのトップに戻る

FreeBASIC ProPgObjectRtti

目次→教本→プログラマーのための案内ProPgObjectRtti←オリジナル・サイト

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

←リンク元に戻る プログラム開発関連に戻る

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

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

目次



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).

'動物型コレクション' の実際の動作に非常に近い多相性エミュレーションの例
このサブタイプの多相性のエミュレーションは、実際の動作に非常に近いものです:
- 静的手続きのポインタテーブル '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
同じ例で、'動物型コレクション' の実際のコードとエミュレーションコードの両方がある場合
比較しやすいように、実コードとエミュレーション・コードを、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 情報からのマングルされた型名の抽出例:
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

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)
Delete p

Sleep


出力:
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
先の例は、上の関数を使って完成します:
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

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)
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
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
このページの頭に戻る

参照:
プログラマーのための案内に戻る
目次に戻る
←リンク元に戻る プログラム開発関連に戻る

ページ歴史:2020-08-16 13:44:04
日本語翻訳:WATANABE Makoto、原文著作者:fxm

ホームページのトップに戻る

表示-非営利-継承