"Fossies" - the Fresh Open Source Software Archive

Member "FreeBASIC-1.09.0-win64/examples/manual/proguide/all_rtti_info.bas" (1 Jan 2022, 3598 Bytes) of package /windows/misc/FreeBASIC-1.09.0-win64.zip:

    1 '' examples/manual/proguide/all_rtti_info.bas
    2 ''
    3 '' NOTICE: This file is part of the FreeBASIC Compiler package and can't
    4 ''         be included in other distributions without authorization.
    5 ''
    6 '' See Also: https://www.freebasic.net/wiki/wikka.php?wakka=ProPgObjectRtti
    7 '' --------
    8 
    9 Namespace oop
   10     Type parent Extends Object
   11     End Type
   12 
   13     Type child Extends parent
   14     End Type
   15 
   16     Type grandchild Extends child
   17     End Type
   18 End Namespace
   19 
   20 Function mangledTypeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
   21     ' Function to get any mangled-typename in the inheritance up hierarchy
   22     ' of the type of an instance (address: 'po') compatible with the built-in 'Object'
   23     '
   24     ' ('baseIndex =  0' to get the mangled-typename of the instance)
   25     ' ('baseIndex = -1' to get the base mangled-typename of the instance, or "" if not existing)
   26     ' ('baseIndex = -2' to get the base.base mangled-typename of the instance, or "" if not existing)
   27     ' (.....)
   28     '
   29         Dim As String s
   30         Dim As ZString Ptr pz
   31         Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1]  ' Ptr to RTTI info
   32         For I As Integer = baseIndex To -1
   33             p = CPtr(Any Ptr Ptr, p)[2]                      ' Ptr to Base RTTI info of previous RTTI info
   34             If p = 0 Then Return s
   35         Next I
   36         pz = CPtr(Any Ptr Ptr, p)[1]                         ' Ptr to mangled-typename
   37         s = *pz
   38         Return s
   39 End Function
   40 
   41 Function typeNameFromRTTI (ByVal po As Object Ptr, ByVal baseIndex As Integer = 0) As String
   42     ' Function to get any typename in the inheritance up hierarchy
   43     ' of the type of an instance (address: 'po') compatible with the built-in 'Object'
   44     '
   45     ' ('baseIndex =  0' to get the typename of the instance)
   46     ' ('baseIndex = -1' to get the base.typename of the instance, or "" if not existing)
   47     ' ('baseIndex = -2' to get the base.base.typename of the instance, or "" if not existing)
   48     ' (.....)
   49     '
   50         Dim As String s
   51         Dim As ZString Ptr pz
   52         Dim As Any Ptr p = CPtr(Any Ptr Ptr Ptr, po)[0][-1]          ' Ptr to RTTI info
   53         For I As Integer = baseIndex To -1
   54             p = CPtr(Any Ptr Ptr, p)[2]                              ' Ptr to Base RTTI info of previous RTTI info
   55             If p = 0 Then Return s
   56         Next I
   57         pz = CPtr(Any Ptr Ptr, p)[1]                                 ' Ptr to mangled-typename
   58         Do
   59             Do While (*pz)[0] > Asc("9") OrElse (*pz)[0] < Asc("0")
   60                 If (*pz)[0] = 0 Then Return s
   61                 pz += 1
   62             Loop
   63             Dim As Integer N = Val(*pz)
   64             Do
   65                 pz += 1
   66             Loop Until (*pz)[0] > Asc("9") OrElse (*pz)[0] < Asc("0")
   67             If s <> "" Then s &= "."
   68             s &= Left(*pz, N)
   69             pz += N
   70         Loop
   71 End Function
   72 
   73 Function typeNameHierarchyFromRTTI (ByVal po As Object Ptr) As String
   74     ' Function to get the typename inheritance up hierarchy
   75     ' of the type of an instance (address: po) compatible with the built-in 'Object'
   76     '
   77         Dim As String s = TypeNameFromRTTI(po)
   78         Dim As Integer i = -1
   79         Do
   80             Dim As String s0 = typeNameFromRTTI(po, i)
   81             If s0 = "" Then Exit Do
   82             s &= "->" & s0
   83             i -= 1
   84         Loop
   85         Return s
   86 End Function
   87 
   88 Dim As Object Ptr p = New oop.grandchild
   89 
   90 Print "Mangled typenames list, from RTTI info:"
   91 Print "  " & mangledTypeNameFromRTTI(p, 0)
   92 Print "  " & mangledTypeNameFromRTTI(p, -1)
   93 Print "  " & mangledTypeNameFromRTTI(p, -2)
   94 Print "  " & mangledTypeNameFromRTTI(p, -3)
   95 Print
   96 Print "Typenames (demangled) list, from RTTI info:"
   97 Print "  " & typeNameFromRTTI(p, 0)
   98 Print "  " & typeNameFromRTTI(p, -1)
   99 Print "  " & typeNameFromRTTI(p, -2)
  100 Print "  " & typeNameFromRTTI(p, -3)
  101 Print
  102 Print "Typename (demangled) and all those of its base-types hierarchy, from RTTI info:"
  103 Print "  " & typeNameHierarchyFromRTTI(p)
  104 Delete p
  105 
  106 Sleep
  107