FreeBASIC Documents

中文

English

中文

English

Appearance

OBJECT 内置类型与 RTTI 信息 ​

OBJECT 内置类型如何实现继承多态性的能力以及用于识别的运行时类型信息。

前言：

Object 内置类型为所有使用 Extends 声明派生的类型提供：

  • 在派生类型（子类型）中重新定义方法的能力（使用 Abstract/Virtual 关键字），该子类型继承自基础类型（超类型）。这样就可以调用对象的方法而不用关心其固有类型：这就是继承多态性（子类型多态性）。

  • 在运行时确定对象的实际类型的能力，该实际类型可能与编译时不同。Is（运行时类型信息）运算符使用它来检查对象是否与从其编译时类型派生的类型兼容，因为 RTTI 不仅提供对象的运行时类型名称，还提供其所有不同基类型的名称，直到 Object 内置类型。

目录

1. 继承多态性和 RTTI 信息的底层机制

2. 通过真实运行和忠实模拟演示继承多态性机制

3. 从 RTTI 信息中解码类型名称

1. 继承多态性和 RTTI 信息的底层机制 ​

抽象/虚拟成员过程是使用虚拟过程表（vtbl）实现的。简单地说，vtbl 是一个静态过程指针表。

编译器为每个多态类型填充一个 vtbl，即为定义了至少一个抽象/虚拟过程的类型，或从前者派生的类型。

vtbl 包含该类型中所有可用的抽象/虚拟过程的条目，包括在继承层次结构上层定义的抽象/虚拟过程（对于尚未实现的抽象过程，vtbl 中设置空指针）。

每个 vtbl 为相应类型中的每个抽象/虚拟过程包含正确的过程地址。这里"正确"是指定义/覆盖该过程的最派生类型的对应过程的地址：

  • 当类型被实例化时，实例将包含一个指向实例化类型的虚拟过程表（vtbl）的指针（vptr）。

  • 当派生类型的对象通过基类型的指针/引用被引用时，抽象/虚拟过程功能才真正发挥作用。调用抽象/虚拟过程在运行时以某种方式被转换，从底层对象类型（而非指针/引用类型）的虚拟过程表中选择对应的过程。

  • 因此，调用哪个过程取决于指针/引用指向的对象的实际类型，而这在编译时无法知晓，这就是为什么抽象/虚拟过程调用是在运行时决定的。

因此，抽象/虚拟过程调用（通过指针或引用）不是普通调用，有轻微的性能开销，如果调用次数众多，这种开销可能会变得很大。

编译器通过使用 vptr 值（位于实例数据的偏移量 0 处）寻址的适当 vtbl，将抽象/虚拟过程调用转换为其他形式：

设 method1()、method2()、method3() 为在继承类型结构中声明的前三个抽象或虚拟成员过程，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 的地址。

  • 第二次间接访问 [0] 或 [1] 或 [2] 允许在 vtbl 中访问虚拟过程 method1() 或 method2() 或 method3() 的静态地址（按照 Type 结构中抽象或虚拟过程的声明顺序）。

对于 vptr 值的设置：

  • 编译器在每个类型（从基类型到实例化类型）的构造函数中生成一些额外代码，这些代码被添加在用户代码之前。即使用户没有定义构造函数，编译器也会生成一个默认的构造函数，vptr 的初始化就在其中（从基类型的 vtbl 地址到实例化类型的 vtbl 地址）。因此，每次创建多态类型的对象时，vptr 都会被正确初始化，并最终指向该实例化类型的 vtbl。

  • 最后，当对象被销毁时，析构函数按相反顺序调用（从实例化类型到基类型）。编译器也在每个类型的析构函数中生成一些额外代码，这些代码被添加在用户代码之前。即使用户没有定义析构函数，编译器也会生成一个默认的析构函数，vptr 的反初始化就在其中（从实例化类型的 vtbl 地址到基类型的 vtbl 地址）。

  • vptr 值的这种逐步初始化/反初始化是必要的，这样在构造/析构的连续步骤中，每个构造函数/析构函数中的用户代码可以在正确的类型级别调用多态过程。

内置 Object 类型也为所有使用 Extends 声明从其派生的类型提供 RTTI（运行时类型信息）能力：

  • RTTI 能力允许在运行时确定对象的实际类型，该类型可能与编译时不同。

  • Is (rtti) 运算符使用它来检查对象是否与从其编译时类型派生的类型兼容，因为 RTTI 不仅提供对象的真实运行时类型名称，还提供其所有基类型的类型名称，直到 Object 内置类型。

  • 然而，RTTI 存储的这些类型名称（由 vtbl 中的特定指针引用）是经过修饰的名称，无法直接从 FreeBASIC 关键字访问。

实体链接方式：对象实例、vptr、vtbl（虚函数表）和 RTTI 信息：

  • 实例 -> Vptr -> Vtbl -> RTTI 信息链：

  • 对于任何从 Object 内置类型直接或间接派生的类型，在其数据字段（自有或继承）的开头（位于偏移量 0 处）添加了一个隐藏指针 vptr。该 vptr 指向所考虑类型的虚拟表 vtbl。

  • vtbl 从偏移量 0 开始包含所有抽象/虚拟过程的地址列表。vtbl 还包含（位于偏移量 -1 处）一个指向所考虑类型的运行时类型信息（RTTI）信息块的指针。

  • RTTI 信息块包含（位于偏移量 +1 处）一个指向所考虑类型的修饰类型名称（ASCII 字符）的指针。RTTI 信息块还包含（位于偏移量 +2 处）一个指向其基类型的 RTTI 信息块的指针。所有上层继承的 RTTI 信息块如此链接。

  • 实例 -> Vptr -> Vtbl -> RTTI 信息图：

vb
'                                      vtbl (虚函数表)
'                                  .-------------------.
'                              [-2]|     预留 (0)       |               RTTI 信息                Mangled 类型名
'                                  |-------------------|       .-----------------------.       .---------------.
'           UDT 实例           [-1]| RTTI 信息指针      |--->[0]|       预留 (0)        |       |   类型名字符串  |
'      .-------------------.       |-------------------|       |-----------------------|       |     包含      |
'   [0]| vptr: vtbl 指针    |--->[0]|  虚函数指针 #1     |   [+1]| Mangled 类型名指针    |--->[0]| 长度 (ASCII)  |
'      |-------------------|       |-------------------|       |-----------------------|       |       &       |
'      |  UDT 成员字段 #a   |   [+1]|  虚函数指针 #2     |   [+2]| 基类 RTTI 信息指针    |---.   |  名称 (ASCII) |
'      |-------------------|       |-------------------|       |_______________________|   |   |     各组件     |
'      |  UDT 成员字段 #b   |   [+2]|  虚函数指针 #3     |   ________________________________|   |_______________|
'      |-------------------|       :- - - - - - - - - -:  |                                    
'      |  UDT 成员字段 #c   |       :                   :  |          基类 RTTI 信息
'      :- - - - - - - - - -:       :                   :  |       .----------------------------.
'      :                   :       |___________________|  '--->[0]|          预留 (0)           |
'      :                   :                                      |----------------------------|
'      |___________________|                                  [+1]| Mangled 基类型名指针        |--->
'                                                                 |----------------------------|
'                                                             [+2]| Base.Base RTTI 信息指针     |---.
'                                                                 |____________________________|   |
'                                                                                                  |
'                                                                                                  V

返回顶部

2. 通过真实运行和忠实模拟演示继承多态性机制 ​

在下面提出的示例中，多态部分被分解，以便更好地展现多态机制所必需的所有元素。

继承多态性示例，真实运行：'动物类型集合'

选择的通用基类型是任何 '动物'（抽象）。

专门的派生类型是 '狗'、'猫' 和 '鸟'（每个都定义了一个包含其类型名称的非静态字符串成员）。

在通用基类型中声明的抽象过程，必须在每个专门的派生类型中定义，这些过程是：

  • addr_override_fct()：返回实例地址，

  • speak_override_fct()：返回说话方式，

  • type_override_sub()：打印类型名称（来自带初始化器的字符串成员）。

  • animal 类型声明（通用基类型）：

  • dog、cat、bird 类型声明（专门的派生类型）：

  • 示例的完整代码：

非常接近实际运行的多态性模拟示例 '动物类型集合'

以下子类型多态性的模拟非常接近真实运行：

  • 为每个派生类型定义一个静态过程指针表 callback_table() 来模拟 vtbl（实例引用将作为第一个参数传递给每个静态过程，以模拟传递给任何非静态成员过程的隐藏 This 引用）。
vb
'派生类型 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}
vb
'派生类型 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}
vb
'派生类型 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 是该过程在表中对应的索引）调用适当的派生过程。

vb
'基类型 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
  • 模拟的完整代码：

相同示例，包含 '动物类型集合' 的真实代码和模拟代码

真实代码和模拟代码嵌套在一个代码中，便于比较：

start GeSHi

vb
' 模拟多态（使用显式回调成员过程）
' 与
' 真正多态（使用抽象/虚成员过程），
' 均在继承结构中实现。

'基类型 animal：
    Type animal Extends Object  'Extends Object' useful for true polymorphism only
    ' 用于真正多态：
        Public:
            Declare Abstract Function addr_override_fct () As animal Ptr
            Declare Abstract Function speak_override_fct () As String
            Declare Abstract Sub type_override_sub ()
    ' 用于模拟多态：
        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

'派生类型 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:
            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

    ' 用于真正多态：
        ' dog 对象的 override_sub 方法：
            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

    ' 用于模拟多态：
        Static As Any Ptr dog.callback_table(0 To 2) = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}
        ' dog 对象的 callback_sub 方法和构造函数：
            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

'派生类型 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:
            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

    ' 用于真正多态：
        ' cat 对象的 override_sub 方法：
            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

    ' 用于模拟多态：
        Static As Any Ptr cat.callback_table(0 To 2) = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}
        ' cat 对象的 callback_sub 方法和构造函数：
            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

'派生类型 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:
            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

    ' 用于真正多态：
        ' bird 对象的 override_sub 方法：
            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

    ' 用于模拟多态：
        Static As Any Ptr bird.callback_table(0 To 2) = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}
        ' bird 对象的 callback_sub 方法和构造函数：
            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

'创建 dog、cat 和 bird 的动态实例，通过 animal 指针列表引用：
    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}

'让动物们说话和进食：
    Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
    For I As Integer = LBound(animal_list) To UBound(animal_list)
        Print "   animal #" & I & ":"
        ' 对于 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
        ' 用于模拟多态：
            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

end GeSHi

输出：

vb
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 信息中解码类型名称 ​

从 RTTI 信息中提取修饰类型名称：

  • 从实例地址，通过双重间接访问（偏移量：[0][-1]）访问实例类型的 RTTI 信息指针。

  • 上述 RTTI 信息指针链允许访问继承层次结构中所选类型的 RTTI 信息（直到 Object 内置类型）。这是通过对指针间接访问进行迭代（偏移量：[+2]）来完成的。

  • 然后访问所选的修饰类型名称（最终间接访问，偏移量：[+1]）

函数 mangledTypeNameFromRTTI() 用于提取修饰类型名称：

vb
Function mangledTypeNameFromRTTI (Byval po As Object Ptr, Byval baseIndex As Integer = 0) As String
' 用于获取与内置 'Object' 兼容的实例（地址：'po'）类型的
' 继承上层结构中任何修饰类型名称的函数
'
' ('baseIndex =  0' 获取实例的修饰类型名称)
' ('baseIndex = -1' 获取实例的基类修饰类型名称，不存在则返回 "")
' ('baseIndex = -2' 获取实例的基类.基类修饰类型名称，不存在则返回 "")
' (.....)
'
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

从 RTTI 信息提取修饰类型名称的示例，用于在命名空间块内声明的继承结构（三个派生级别）：

start GeSHi

vb
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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意修饰类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的修饰类型名）
    ' （'baseIndex = -1'：获取实例的基类修饰类型名，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base 修饰类型名，若不存在则返回 ""）
    ' (.....)
    '
        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

end GeSHi

输出：

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

修饰类型名称的实现

从上面的输出中，可以用以下格式突出显示类型名称的修饰过程：

N3OOP10GRANDCHILDE

（对于 oop.grandchild）

N3OOP5CHILDE

（对于 oop.child）

N3OOP6PARENTE

（对于 oop.parent）

6OBJECT

（对于 Object）

RTTI 信息中类型名称修饰过程的详细说明：

  • 修饰类型名称是 Zstring（以空字符结尾）。

  • 完整类型名称（转换为大写）的每个组成部分（以点作为分隔符）前面都有其字符数，以 ASCII 编码（基于长度前缀字符串）。

  • 当类型至少在一个命名空间内时，修饰类型名称字符串以额外的 "N" 开头，以额外的 "E" 结尾。

（前缀 "N" 和后缀 "E" 来自 Nested-name ... Ending）

从 RTTI 信息中提取类型名称（解码）

前面的函数（mangledTypeNameFromRTTI()）现在可以通过解码过程来补充。

函数 typeNameFromRTTI() 用于提取解码后的类型名称：

vb
Function typeNameFromRTTI (Byval po As Object Ptr, Byval baseIndex As Integer = 0) As String
' 用于获取与内置 'Object' 兼容的实例（地址：'po'）类型的
' 继承上层结构中任何类型名称的函数
'
' ('baseIndex =  0' 获取实例的类型名称)
' ('baseIndex = -1' 获取实例的基类类型名称，不存在则返回 "")
' ('baseIndex = -2' 获取实例的基类.基类类型名称，不存在则返回 "")
' (.....)
'
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

加入上述函数后的前例补充版本：

start GeSHi

vb
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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意修饰类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的修饰类型名）
    ' （'baseIndex = -1'：获取实例的基类修饰类型名，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base 修饰类型名，若不存在则返回 ""）
    ' (.....)
    '
        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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的类型名）
    ' （'baseIndex = -1'：获取实例的 base.typename，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base.typename，若不存在则返回 ""）
    ' (.....)
    '
        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

end GeSHi

输出：

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

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

一次性提取类型名称（解码）及其所有基类型层次结构，来自 RTTI 信息

只需在一个循环中用递减参数 baseIndex（从值 0 开始）调用前面的函数，并在返回空字符串时立即停止。最后返回一个字符串，其中包含不同类型名称，每个名称之间用层次分隔符分隔。

函数 typeNameHierarchyFromRTTI() 用于提取类型名称（解码）及其所有基类型层次结构：

vb
Function typeNameHierarchyFromRTTI (Byval po As Object Ptr) As String
' 用于获取与内置 'Object' 兼容的实例（地址：po）类型的
' 类型名称继承上层结构的函数
'
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

加入上述函数后的前例再次补充版本：

start GeSHi

vb
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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意修饰类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的修饰类型名）
    ' （'baseIndex = -1'：获取实例的基类修饰类型名，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base 修饰类型名，若不存在则返回 ""）
    ' (.....)
    '
        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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的类型名）
    ' （'baseIndex = -1'：获取实例的 base.typename，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base.typename，若不存在则返回 ""）
    ' (.....)
    '
        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
    ' 获取与内置 'Object' 兼容的实例（地址 po）在继承层次中
    ' 类型名继承链的函数
    '
        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

end GeSHi

输出：

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 信息提取的类型名称（解码）与字符串变量进行比较

作为解码过程的各个步骤，从 RTTI 信息提取的类型名称的连续元素与提供的链中的元素进行比较（只要有一个元素不同，立即返回 "false"）。

函数 typeNameEqualFromRTTI() 用于将从 RTTI 信息提取的类型名称（解码）与字符串变量进行比较：

vb
Function typeNameEqualFromRTTI (Byval po As Object Ptr, Byref typeName As String) As Boolean
' 用于检查实例类型名称（地址：po）是否与传入字符串相同的函数
'
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

加入上述函数后的最终示例：

start GeSHi

vb
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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意修饰类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的修饰类型名）
    ' （'baseIndex = -1'：获取实例的基类修饰类型名，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base 修饰类型名，若不存在则返回 ""）
    ' (.....)
    '
        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
    ' 获取与内置 'Object' 兼容的实例（地址 'po'）在继承层次中
    ' 任意类型名的函数
    '
    ' （'baseIndex =  0'：获取实例的类型名）
    ' （'baseIndex = -1'：获取实例的 base.typename，若不存在则返回 ""）
    ' （'baseIndex = -2'：获取实例的 base.base.typename，若不存在则返回 ""）
    ' (.....)
    '
        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
    ' 获取与内置 'Object' 兼容的实例（地址 po）在继承层次中
    ' 类型名继承链的函数
    '
        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
    ' 判断实例（地址 po）的类型名是否与传入字符串相同的函数
    '
        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

end GeSHi

输出：

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 官方文档翻译 如有侵权请联系我们删除
FreeBASIC 是开源项目，与微软公司无隶属关系

文档维护 © 2019-2026 FreeBASIC 中文社区