OBJECT built-in and RTTI info - FreeBASIC Wiki Manual | FBWiki

'                                      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

'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}

'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

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

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