Questions on inheritance in FreeBASIC

[fxm]

dodicat, about your above program:

When you use 'Type<circumference>(56.548)' or 'Type<area>(254.46)', there is no matching constructors. Consequently, a 'circumference' object or a 'area' object is constructed by using the defaut constructor. Then the first member data 'this.radius' is set to the passed value '56.548' or '254.46'!
It is why you are obliged to implement an very ugly code in the two constructors of 'circle':
- 'this.radius=d.radius/(2*d.pi) .....' inside 'Constructor Circle(d As circumference)'
- 'this.area=d.radius .....' inside 'Constructor Circle(d As area)'
(remark: in these two constructors, 'Cast(radius,d)' is useless!)

IMHO, it is preferable to add the two missing constructors 'Constructor circumference(c As Double)' and 'Constructor area(a As Double)' in order to remove this very ugly code:

Code: Select all

Type pi Extends Object
    Const pi=Acos(-1)
End Type

Type radius Extends pi
    As Double radius
    Declare Constructor
    Declare Constructor(As Double)
End Type

Constructor radius:End Constructor

Constructor radius(r As Double)
this.radius=r
End Constructor


Type circumference Extends radius
    As Double circumference
    Declare Constructor
    Declare Constructor(As radius)
    Declare Constructor(As Double)
End Type

Constructor circumference:End Constructor

Constructor circumference(r As radius)
Base(r.radius)
this.circumference=2*this.pi*r.radius
End Constructor

Constructor circumference(c As Double)
Base(c/2/this.pi)
this.circumference = c
End Constructor


Type area Extends circumference
    As Double area
    Declare Constructor
    Declare Constructor(As circumference)
    Declare Constructor(As radius)
    Declare Constructor(As Double)
End Type

Constructor area:End Constructor

Constructor area(r As radius)
Base(r)
this.area=this.pi*r.radius*r.radius
End Constructor

Constructor area(c As circumference)
Base(c.circumference)
this.area=this.pi*c.radius*c.radius
End Constructor

Constructor area(a As Double)
Base(Sqr(a/this.pi)*2*this.pi)
This.area = a
End Constructor

'=========  Interface =======================
Type Circle Extends area
    Declare Constructor
    Declare Constructor(As radius)
    Declare Constructor(As circumference)
    Declare Constructor(As area)
    Declare Sub Draw(As Integer,As Integer,As Uinteger)
End Type

Constructor Circle:End Constructor

Constructor Circle(r As radius)
Base(r)
End Constructor

Constructor Circle(c As circumference)
Base(c)
End Constructor

Constructor Circle(a As area)
Base(a.area)
End Constructor

Sub circle.draw(x As Integer,y As Integer,c As Uinteger)
    Circle(x,y),this.radius,c,,,,f
End Sub

'=============== EXAMPLE =========================

Print
Dim As Circle g=Type<radius>(9)
print "General type CIRCLE"
print
Print "type<radius>=9"
Print "radius ";g.radius
Print "circumference ";g.circumference
Print "area ";g.area

Dim As Circle h=Type<circumference>(56.548)
Print
Print "type<circumference>=56.548"

Print "radius ";h.radius
Print "circumference ";h.circumference
Print "area ";h.area
Print

Dim As Circle i=Type<area>(254.46)
Print "type<area>=254.46"
Print "radius ";i.radius
Print "circumference ";i.circumference
Print "area ";i.area
Print
Print "press a key"


Sleep
Screen 19,32
Dim As Circle c1,c2,c3
c1=Type<radius>(10)
c2=Type<circumference>(10)
c3=Type<area>(10)
Do
    c1.radius=c1.radius+.1
    c1=Type<radius>(c1.radius)
    c2.circumference=c2.circumference+.1
    c2=Type<circumference>(c2.circumference)
    c3.area=c3.area+.1
    c3=Type<area>(c3.area)
    Screenlock
    Cls
    Draw String(250,20),"INCREMENT-(By equal amounts)"
    Draw String(100,40),"Radius"
    Draw String(350,40),"circumference"
    Draw String(700,40),"Area"
    c1.draw(100,300,Rgb(200,0,0))
    c2.draw(400,300,Rgb(0,200,0))
    c3.draw(700,300,Rgb(0,0,2000))
    Screenunlock
    Sleep 1,1
Loop Until Len(Inkey)
Sleep

[dodicat]

Yes fxm.
I knew my code was a bit forced, it's the use of BASE I was interested in.
I've been doing a bit of C++ which re-interested me in the whole idea of object coding.

Need to do a bit more of this stuff in Freebasic, practice makes perfect, thanks for the assistance.

[fxm]

Simulating of multiple interfaces:

A procedure body is added in the 'A' and 'B' types, to simulate the 'A' and 'B' interfaces at runtime:
- Just by casting the interface pointer to the real type of the object if this object implements the interface.

Code: Select all

Type Parent Extends Object
  Declare Abstract Sub PrintP ()
  Declare Abstract Function ReturnP () As string
End Type

'--------------------------------------------------------------------------------------------------------

Type A Extends Object '' Interface A
  Declare Sub PrintA ()
End Type '' End Interface

Type B Extends Object '' Interface B
  Declare Function ReturnB () As String
End Type '' End Interface

'--------------------------------------------------------------------------------------------------------

Type Derived1 Extends Parent '' Type Derived1 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Sub PrintA ()
  Declare Function ReturnB () As String
End Type
Virtual Sub Derived1.PrintP ()
  Print "Derived1.PrintP()"
End Sub
Virtual Function Derived1.ReturnP () As String
  Return "Derived1.ReturnP()"
End Function
Sub Derived1.PrintA ()
  Print "Derived1.PrintA()"
End Sub
Function Derived1.ReturnB () As String
  Return "Derived1.ReturnB()"
End Function

Type Derived2 Extends Parent '' Type Derived2 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Sub PrintA ()
  Declare Function ReturnB () As String
End Type
Virtual Sub Derived2.PrintP ()
  Print "Derived2.PrintP()"
End Sub
Virtual Function Derived2.ReturnP () As String
  Return "Derived2.ReturnP()"
End Function
Sub Derived2.PrintA ()
  Print "Derived2.PrintA()"
End Sub
Function Derived2.ReturnB () As String
  Return "Derived2.ReturnB()"
End Function

'--------------------------------------------------------------------------------------------------------

Sub A.PrintA ()
  If Cast(Object, This) Is Derived1 Then
    Cast(Derived1 Ptr, Cast(Any Ptr, @This))->PrintA()
  Elseif Cast(Object, This) Is Derived2 Then
    Cast(Derived2 Ptr, Cast(Any Ptr, @This))->PrintA()
  End If
End Sub

Function B.ReturnB () As String
  If Cast(Object, This) Is Derived1 Then
    Return Cast(Derived1 Ptr, Cast(Any Ptr, @This))->ReturnB()
  Elseif Cast(Object, This) Is Derived2 Then
    Return Cast(Derived2 Ptr, Cast(Any Ptr, @This))->ReturnB()
  End If
End Function

'--------------------------------------------------------------------------------------------------------

Print "- From Parent (type) Ptr:"
Dim As Parent Ptr Ptr ppP = New Parent Ptr [2]
ppP[0] = New Derived1
ppP[1] = New Derived2
ppP[0]->PrintP()
ppP[1]->PrintP()
Print ppP[0]->ReturnP()
Print ppP[1]->ReturnP()
Print
Print "- From A (interface) Ptr:"
Dim As A Ptr Ptr ppA = New A Ptr [2]
ppA[0] = New Derived1
ppA[1] = New Derived2
ppA[0]->PrintA()
ppA[1]->PrintA()
Print
Print "- From B (interface) Ptr:"
Dim As B Ptr Ptr ppB = New B Ptr [2]
ppB[0] = New Derived1
ppB[1] = New Derived2
Print ppB[0]->ReturnB()
Print ppB[1]->ReturnB()
Sleep

Delete ppP[0]
Delete ppP[1]
Delete ppP
Delete ppA[0]
Delete ppA[1]
Delete ppA
Delete ppB[0]
Delete ppB[1]
Delete ppB

Code: Select all

- From Parent (type) Ptr:
Derived1.PrintP()
Derived2.PrintP()
Derived1.ReturnP()
Derived2.ReturnP()

- From A (interface) Ptr:
Derived1.PrintA()
Derived2.PrintA()

- From B (interface) Ptr:
Derived1.ReturnB()
Derived2.ReturnB()

Remark:
Besides an interface (C) should be also able to inherit from other interfaces (B, ...).
(Interface C Extends B, ...)

Code: Select all

Type Parent Extends Object
  Declare Abstract Sub PrintP ()
  Declare Abstract Function ReturnP () As string
End Type

'--------------------------------------------------------------------------------------------------------

Type A Extends Object '' Interface A
  Declare Sub PrintA ()
End Type '' End Interface

Type B Extends Object '' Interface B
  Declare Function ReturnB () As String
End Type '' End Interface

Type C Extends B '' Interface C Extends B
  Declare Sub PrintC ()
  Declare Function ReturnC () As String
End Type

'--------------------------------------------------------------------------------------------------------

Type Derived1 Extends Parent '' Type Derived1 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Sub PrintA ()
  Declare Function ReturnB () As String
End Type
Virtual Sub Derived1.PrintP ()
  Print "Derived1.PrintP()"
End Sub
Virtual Function Derived1.ReturnP () As String
  Return "Derived1.ReturnP()"
End Function
Sub Derived1.PrintA ()
  Print "Derived1.PrintA()"
End Sub
Function Derived1.ReturnB () As String
  Return "Derived1.ReturnB()"
End Function

Type Derived2 Extends Parent '' Type Derived2 Extends Parent Implements A, C
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Sub PrintA ()
  Declare Function ReturnB () As String
  Declare Sub PrintC ()
  Declare Function ReturnC () As String
End Type
Virtual Sub Derived2.PrintP ()
  Print "Derived2.PrintP()"
End Sub
Virtual Function Derived2.ReturnP () As String
  Return "Derived2.ReturnP()"
End Function
Sub Derived2.PrintA ()
  Print "Derived2.PrintA()"
End Sub
Function Derived2.ReturnB () As String
  Return "Derived2.ReturnB()"
End Function
Sub Derived2.PrintC ()
  Print "Derived2.PrintC()"
End Sub
Function Derived2.ReturnC () As String
  Return "Derived2.ReturnC()"
End Function

'--------------------------------------------------------------------------------------------------------

Sub A.PrintA ()
  If Cast(Object, This) Is Derived1 Then
    Cast(Derived1 Ptr, Cast(Any Ptr, @This))->PrintA()
  Elseif Cast(Object, This) Is Derived2 Then
    Cast(Derived2 Ptr, Cast(Any Ptr, @This))->PrintA()
  End If
End Sub

Function B.ReturnB () As String
  If Cast(Object, This) Is Derived1 Then
    Return Cast(Derived1 Ptr, Cast(Any Ptr, @This))->ReturnB()
  Elseif Cast(Object, This) Is Derived2 Then
    Return Cast(Derived2 Ptr, Cast(Any Ptr, @This))->ReturnB()
  End If
End Function

Sub C.Printc ()
  If Cast(Object, This) Is Derived2 Then
    Cast(Derived2 Ptr, Cast(Any Ptr, @This))->PrintC()
  End If
End Sub

Function C.ReturnC () As String
  If Cast(Object, This) Is Derived2 Then
    Return Cast(Derived2 Ptr, Cast(Any Ptr, @This))->ReturnC()
  End If
End Function

'--------------------------------------------------------------------------------------------------------

Print "- From Parent (type) Ptr:"
Dim As Parent Ptr Ptr ppP = New Parent Ptr [2]
ppP[0] = New Derived1
ppP[1] = New Derived2
ppP[0]->PrintP()
ppP[1]->PrintP()
Print ppP[0]->ReturnP()
Print ppP[1]->ReturnP()
Print
Print "- From A (interface) Ptr:"
Dim As A Ptr Ptr ppA = New A Ptr [2]
ppA[0] = New Derived1
ppA[1] = New Derived2
ppA[0]->PrintA()
ppA[1]->PrintA()
Print
Print "- From B (interface) Ptr:"
Dim As B Ptr Ptr ppB = New B Ptr [2]
ppB[0] = New Derived1
ppB[1] = New Derived2
Print ppB[0]->ReturnB()
Print ppB[1]->ReturnB()
Print
Print "- From C (interface) Ptr:"
Dim As C Ptr Ptr ppC = New C Ptr [1]
ppC[0] = New Derived2
Print ppC[0]->ReturnB()
ppC[0]->PrintC()
Print ppC[0]->ReturnC()
Sleep

Delete ppP[0]
Delete ppP[1]
Delete ppP
Delete ppA[0]
Delete ppA[1]
Delete ppA
Delete ppB[0]
Delete ppB[1]
Delete ppB
Delete ppc[0]
Delete ppC

Code: Select all

- From Parent (type) Ptr:
Derived1.PrintP()
Derived2.PrintP()
Derived1.ReturnP()
Derived2.ReturnP()

- From A (interface) Ptr:
Derived1.PrintA()
Derived2.PrintA()

- From B (interface) Ptr:
Derived1.ReturnB()
Derived2.ReturnB()

- From C (interface) Ptr:
Derived2.ReturnB()
Derived2.PrintC()
Derived2.ReturnC()

[stylin]

You could skip the run-time type checks by using some helper classes:

Code: Select all

' two interfaces
type Source extends Object
    declare abstract function ReadByte () as byte
end type
type Sink extends Object
    declare abstract sub WriteByte ( byval x as byte )
end type

' forward declaration
type StringStream_ as StringStream

' two adapters, one for each interface
type SourceAdapter extends Source
    declare virtual function ReadByte () as byte
    dim realObj as StringStream_ ptr
end type
type SinkAdapter extends Sink
    declare virtual sub WriteByte ( byval x as byte )
    dim realObj as StringStream_ ptr
end type

' implements Source & Sink interfaces
type StringStream extends Object
    declare constructor ()
    declare virtual function ReadByte () as byte
    declare virtual sub WriteByte ( byval x as byte )
    
    dim src as SourceAdapter
    dim snk as SinkAdapter
    dim theString as string
    
    ' some sugar, optional
    declare operator cast () byref as Source
    declare operator cast () byref as Sink
end type

' the adapters delegate to this object
constructor StringStream ()
    src.realObj = @this
    snk.realObj = @this
end constructor
virtual function SourceAdapter.ReadByte () as byte
    return realObj->ReadByte()
end function
virtual sub SinkAdapter.WriteByte ( byval x as byte )
    realObj->WriteByte( x )
end sub

' bytes written to the end and read from the front
virtual function StringStream.ReadByte () as byte
    ReadByte = theString[0]
    theString = Mid$( theString, 2 )
end function
virtual sub StringStream.WriteByte ( byval x as byte )
    theString &= Chr$( x )
end sub

operator StringStream.cast () byref as Source
    return src
end operator
operator StringStream.cast () byref as Sink
    return snk
end operator

' ---------------------------------------------------------
' ---------------------------------------------------------

sub WriteToSink ( byref snk as Sink )
    snk.WriteByte( 97 )
    snk.WriteByte( 98 )
    snk.WriteByte( 99 )
end sub
sub ReadFromSource ( byref src as Source )
    Print Chr$( src.ReadByte() ) ;
    Print Chr$( src.ReadByte() ) ;
    Print Chr$( src.ReadByte() )
end sub

dim ss as StringStream

WriteToSink( ss )
Print ss.theString

ss.theString = "123"
ReadFromSource( ss )

[fxm]

You could skip the run-time type checks by using some helper classes.....

Simulating of multiple interfaces (continued):

With respect to my previous post, at run-time we can avoid different explicit casting codes depending on the result of the 'Is' operator.
Instead, we can call the right procedures by using the vtable pointers of the objects, provided that such procedures are virtual and that their declarations respect a consistent order in derived types.

A procedure body is added in the 'A' and 'B' types, to simulate the 'A' and 'B' interfaces at runtime:
- Just by extracting the correct vtable pointer of the object.

Code: Select all

Type Parent Extends Object
  Declare Abstract Sub PrintP ()
  Declare Abstract Function ReturnP () As string
End Type

'--------------------------------------------------------------------------------------------------------

Type A Extends Object '' Interface A
  Declare Sub PrintA ()
End Type '' End Interface

Type B Extends Object '' Interface B
  Declare Function ReturnB () As String
End Type '' End Interface

'--------------------------------------------------------------------------------------------------------

Type Derived1 Extends Parent '' Type Derived1 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Virtual Sub PrintA ()
  Declare Virtual Function ReturnB () As String
End Type
Virtual Sub Derived1.PrintP ()
  Print "Derived1.PrintP()"
End Sub
Virtual Function Derived1.ReturnP () As String
  Return "Derived1.ReturnP()"
End Function
Virtual Sub Derived1.PrintA ()
  Print "Derived1.PrintA()"
End Sub
Virtual Function Derived1.ReturnB () As String
  Return "Derived1.ReturnB()"
End Function

Type Derived2 Extends Parent '' Type Derived2 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Virtual Sub PrintA ()
  Declare Virtual Function ReturnB () As String
End Type
Virtual Sub Derived2.PrintP ()
  Print "Derived2.PrintP()"
End Sub
Virtual Function Derived2.ReturnP () As String
  Return "Derived2.ReturnP()"
End Function
Virtual Sub Derived2.PrintA ()
  Print "Derived2.PrintA()"
End Sub
Virtual Function Derived2.ReturnB () As String
  Return "Derived2.ReturnB()"
End Function

'--------------------------------------------------------------------------------------------------------

Sub A.PrintA ()
  If Cast(Object, This) Is Derived1 Or Cast(Object, This) Is Derived2 Then
    Cast(Sub (Byref As A), Cast(Any Ptr Ptr Ptr, @This)[0][2])(This)
  End If
End Sub

Function B.ReturnB () As String
  If Cast(Object, This) Is Derived1 Or Cast(Object, This) Is Derived2 Then
    Return Cast(Function (Byref As B) As String, Cast(Any Ptr Ptr Ptr, @This)[0][3])(This)
  End If
End Function

'--------------------------------------------------------------------------------------------------------

Print "- From Parent (type) Ptr:"
Dim As Parent Ptr Ptr ppP = New Parent Ptr [2]
ppP[0] = New Derived1
ppP[1] = New Derived2
ppP[0]->PrintP()
ppP[1]->PrintP()
Print ppP[0]->ReturnP()
Print ppP[1]->ReturnP()
Print
Print "- From A (interface) Ptr:"
Dim As A Ptr Ptr ppA = New A Ptr [2]
ppA[0] = New Derived1
ppA[1] = New Derived2
ppA[0]->PrintA()
ppA[1]->PrintA()
Print
Print "- From B (interface) Ptr:"
Dim As B Ptr Ptr ppB = New B Ptr [2]
ppB[0] = New Derived1
ppB[1] = New Derived2
Print ppB[0]->ReturnB()
Print ppB[1]->ReturnB()
Sleep

Delete ppP[0]
Delete ppP[1]
Delete ppP
Delete ppA[0]
Delete ppA[1]
Delete ppA
Delete ppB[0]
Delete ppB[1]
Delete ppB

Code: Select all

- From Parent (type) Ptr:
Derived1.PrintP()
Derived2.PrintP()
Derived1.ReturnP()
Derived2.ReturnP()

- From A (interface) Ptr:
Derived1.PrintA()
Derived2.PrintA()

- From B (interface) Ptr:
Derived1.ReturnB()
Derived2.ReturnB()

Remark:
Besides an interface (C) should be also able to inherit from other interfaces (B, ...).
(Interface C Extends B, ...)

Code: Select all

Type Parent Extends Object
  Declare Abstract Sub PrintP ()
  Declare Abstract Function ReturnP () As string
End Type

'--------------------------------------------------------------------------------------------------------

Type A Extends Object '' Interface A
  Declare Sub PrintA ()
End Type '' End Interface

Type B Extends Object '' Interface B
  Declare Function ReturnB () As String
End Type '' End Interface

Type C Extends B '' Interface C Extends B
  Declare Sub PrintC ()
  Declare Function ReturnC () As String
End Type

'--------------------------------------------------------------------------------------------------------

Type Derived1 Extends Parent '' Type Derived1 Extends Parent Implements A, B
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Virtual Sub PrintA ()
  Declare Virtual Function ReturnB () As String
End Type
Virtual Sub Derived1.PrintP ()
  Print "Derived1.PrintP()"
End Sub
Virtual Function Derived1.ReturnP () As String
  Return "Derived1.ReturnP()"
End Function
Virtual Sub Derived1.PrintA ()
  Print "Derived1.PrintA()"
End Sub
Virtual Function Derived1.ReturnB () As String
  Return "Derived1.ReturnB()"
End Function

Type Derived2 Extends Parent '' Type Derived2 Extends Parent Implements A, C
  Declare Virtual Sub PrintP () Override
  Declare Virtual Function ReturnP () As string Override
  Declare Virtual Sub PrintA ()
  Declare Virtual Function ReturnB () As String
  Declare Virtual Sub PrintC ()
  Declare Virtual Function ReturnC () As String
End Type
Virtual Sub Derived2.PrintP ()
  Print "Derived2.PrintP()"
End Sub
Virtual Function Derived2.ReturnP () As String
  Return "Derived2.ReturnP()"
End Function
Virtual Sub Derived2.PrintA ()
  Print "Derived2.PrintA()"
End Sub
Virtual Function Derived2.ReturnB () As String
  Return "Derived2.ReturnB()"
End Function
Virtual Sub Derived2.PrintC ()
  Print "Derived2.PrintC()"
End Sub
Virtual Function Derived2.ReturnC () As String
  Return "Derived2.ReturnC()"
End Function

'--------------------------------------------------------------------------------------------------------

Sub A.PrintA ()
  If Cast(Object, This) Is Derived1 Or Cast(Object, This) Is Derived2 Then
    Cast(Sub (Byref As A), Cast(Any Ptr Ptr Ptr, @This)[0][2])(This)
  End If
End Sub

Function B.ReturnB () As String
  If Cast(Object, This) Is Derived1 Or Cast(Object, This) Is Derived2 Then
    Return Cast(Function (Byref As B) As String, Cast(Any Ptr Ptr Ptr, @This)[0][3])(This)
  End If
End Function

Sub C.PrintC ()
  If Cast(Object, This) Is Derived2 Then
    Cast(Sub (Byref As C), Cast(Any Ptr Ptr Ptr, @This)[0][4])(This)
  End If
End Sub

Function C.ReturnC () As String
  If Cast(Object, This) Is Derived2 Then
    Return Cast(Function (Byref As C) As String, Cast(Any Ptr Ptr Ptr, @This)[0][5])(This)
  End If
End Function

'--------------------------------------------------------------------------------------------------------

Print "- From Parent (type) Ptr:"
Dim As Parent Ptr Ptr ppP = New Parent Ptr [2]
ppP[0] = New Derived1
ppP[1] = New Derived2
ppP[0]->PrintP()
ppP[1]->PrintP()
Print ppP[0]->ReturnP()
Print ppP[1]->ReturnP()
Print
Print "- From A (interface) Ptr:"
Dim As A Ptr Ptr ppA = New A Ptr [2]
ppA[0] = New Derived1
ppA[1] = New Derived2
ppA[0]->PrintA()
ppA[1]->PrintA()
Print
Print "- From B (interface) Ptr:"
Dim As B Ptr Ptr ppB = New B Ptr [2]
ppB[0] = New Derived1
ppB[1] = New Derived2
Print ppB[0]->ReturnB()
Print ppB[1]->ReturnB()
Print
Print "- From C (interface) Ptr:"
Dim As C Ptr Ptr ppC = New C Ptr [1]
ppC[0] = New Derived2
Print ppC[0]->ReturnB()
ppC[0]->PrintC()
Print ppC[0]->ReturnC()
Sleep

Delete ppP[0]
Delete ppP[1]
Delete ppP
Delete ppA[0]
Delete ppA[1]
Delete ppA
Delete ppB[0]
Delete ppB[1]
Delete ppB
Delete ppc[0]
Delete ppC

Code: Select all

- From Parent (type) Ptr:
Derived1.PrintP()
Derived2.PrintP()
Derived1.ReturnP()
Derived2.ReturnP()

- From A (interface) Ptr:
Derived1.PrintA()
Derived2.PrintA()

- From B (interface) Ptr:
Derived1.ReturnB()
Derived2.ReturnB()

- From C (interface) Ptr:
Derived2.ReturnB()
Derived2.PrintC()
Derived2.ReturnC()

[fxm]

Monitoring Vptr/Vtable/RTTIinfo during derived object construction:

During the construction of a derived object, this following code monitors the initialization of the Vptrs/Vtables/RTTIinfos through the inheritance hierarchy from the most base-type to the current derived-type.

When the most-base constructor is called, it initializes its Vptr to the Vtable of that base-type. If a more-derived constructor is called afterwards, this constructor sets the Vptr to its Vtable, and so on, until the last constructor.
The final state of the Vptr is determined by the constructor that is called last (this is another reason why the constructors are called in order from most-base up to most-derived).

As shows the header diagram of the code:
- The Vtable contains (from address 0) all the static pointers to the virtual procedures, in the order of their first declarations (including the virtual destructor) from most-base up to most-derived. Each pointer value matches to the most-derived overriding compatible procedure (in case of abstract procedure found, the pointer is null). As these procedure pointers are static, the caller must provide a reference to the object as first parameter, then the normal parameters of the procedure.
- Just above (at address -1), there is a pointer to the RTTI info block which contains itself at address +1 a pointer to the mangled typename (the first ASCII characters giving the length of the typename string before the string character data), and at address +2 a pointer to the RTTI info block of its base.

[code]' Vptr/Vtable/RTTIinfo diagram
' Vtable
' .---------------------.
' (-2)| reserved (0) | RTTIinfo
' |---------------------| .-----------------------. Mangled Typename
' Instance (-1)| Ptr to RTTIinfo |--->(0)| reserved (0) | .--------.
' .-------------------. |---------------------| |-----------------------| | Length |
' |Vptr: Ptr to Vtable|--->(0)|Ptr to virt. proc. #1| (+1)|Ptr to Mangled Typename|--->(0)| (ASCII)|
' |-------------------| |---------------------| |-----------------------| | & |
' : Member field #1 : (+1)|Ptr to virt. proc. #2| (+2)| Ptr to Base RTTIinfo |---. |Typename|
' : Member field #2 : |---------------------| |_______________________| | | (ASCII)|
' : Member field #3 : (+2):Ptr to virt. proc. #3: | |________|
' : : :- - - - - - - - - - -: V
' : : : : RTTIinfo
' |___________________| |_____________________| of Base

'--------------------------------------------------------------------------------------------------------

Declare Sub show_rtti (Byref o As Object)

'--------------------------------------------------------------------------------------------------------

Type Parent Extends Object
Declare Constructor ()
Declare Virtual Function foo1 () As String
Declare Virtual Function foo2 () As String
End Type
Constructor Parent ()
Print "Parent constructor : @This = @Vptr",, @This
show_rtti(This)
End Constructor
Virtual Function Parent.foo1 () As string
Return "Parent.foo1()"
End function
Virtual Function Parent.foo2 () As string
Return "Parent.foo2()"
End function

Type Child Extends Parent
Declare Constructor ()
Declare Virtual Function foo1 () As String Override
Declare Virtual Function foo2 () As String Override
End Type
Constructor Child ()
Print "Child constructor : @This = @Vptr",, @This
show_rtti(This)
End Constructor
Virtual Function Child.foo1 () As string
Return "Child.foo1()"
End function
Virtual Function Child.foo2 () As string
Return "Child.foo2()"
End function

Type GrandChild Extends Child
Declare Constructor ()
Declare Virtual Function foo1 () As String Override
Declare Virtual Function foo2 () As String Override
End Type
Constructor GrandChild ()
Print "GrandChild constructor : @This = @Vptr",, @This
show_rtti(This)
End Constructor
Virtual Function GrandChild.foo1 () As string
Return "GrandChild.foo1()"
End function
Virtual Function GrandChild.foo2 () As string
Return "GrandChild.foo2()"
End function

'--------------------------------------------------------------------------------------------------------

Sub show_rtti (Byref o As Object)
Dim as Any Ptr Ptr Ptr Ptr vptr = Cast(Any Ptr Ptr Ptr Ptr, @o)[0]
Print " Vptr = @Vtable",,, " " & vptr
Print " | @Vtable[-1] = @RTTIinfo",,, " | " & vptr[-1]
Print " | | @RTTIinfo[0] = reserved",, " | | " & vptr[-1][0]
Print " | | @RTTIinfo[1] = @MangledTypename",, " | | " & vptr[-1][1]
Dim As Zstring Ptr pz = vptr[-1][1]
Print " | | | MangledTypename (Length/Typename)",, " | | | ";
While (*pz)[0] <= Asc("9") Andalso (*pz)[0] >= Asc("0")
Print Chr((*pz)[0]);
pz += 1
Wend
Print "/"; *pz
Print " | | @RTTIinfo[2] = @RTTIinfoBase",, " | | " & vptr[-1][2]
Print " | | | @RTTIinfoBase[1] = @MangledTypenameBase", " | | | " & vptr[-1][2][1]
Dim As Zstring Ptr bpz = vptr[-1][2][1]
Print " | | | | MangledTypenameBase (Length/Typename)", " | | | | ";
While (*bpz)[0] <= Asc("9") Andalso (*bpz)[0] >= Asc("0")
Print Chr((*bpz)[0]);
bpz += 1
Wend
Print "/"; *bpz
Print " | @Vtable[0] = @foo1 (function (as object) as string)", " | " & vptr[0]
Print " | | foo1(This)",,, " | | " & Cast(Function (Byref As Object) As String, vptr[0])(o)
Print " | @Vtable[1] = @foo2 (function (as object) as string)", " | " & vptr[1]
Print " | | foo2(This)",,, " | | " & Cast(Function (Byref As Object) As String, vptr[1])(o)
Print
End Sub

'--------------------------------------------------------------------------------------------------------

Dim As GrandChild gc
Sleep[/code]

Code: Select all

'Parent constructor : @This = @Vptr                      1244912
'  Vptr = @Vtable                                          4227156
'  | @Vtable[-1] = @RTTIinfo                               | 4227128
'  | | @RTTIinfo[0] = reserved                             | | 0
'  | | @RTTIinfo[1] = @MangledTypename                     | | 4227140
'  | | | MangledTypename (Length/Typename)                 | | | 6/PARENT
'  | | @RTTIinfo[2] = @RTTIinfoBase                        | | 4232648
'  | | | @RTTIinfoBase[1] = @MangledTypenameBase           | | | 4235300
'  | | | | MangledTypenameBase (Length/Typename)           | | | | 6/OBJECT
'  | @Vtable[0] = @foo1 (function (as object) as string)   | 4199856
'  | | foo1(This)                                          | | Parent.foo1()
'  | @Vtable[1] = @foo2 (function (as object) as string)   | 4199968
'  | | foo2(This)                                          | | Parent.foo2()
'
'Child constructor : @This = @Vptr                       1244912
'  Vptr = @Vtable                                          4227716
'  | @Vtable[-1] = @RTTIinfo                               | 4227688
'  | | @RTTIinfo[0] = reserved                             | | 0
'  | | @RTTIinfo[1] = @MangledTypename                     | | 4227700
'  | | | MangledTypename (Length/Typename)                 | | | 5/CHILD
'  | | @RTTIinfo[2] = @RTTIinfoBase                        | | 4227128
'  | | | @RTTIinfoBase[1] = @MangledTypenameBase           | | | 4227140
'  | | | | MangledTypenameBase (Length/Typename)           | | | | 6/PARENT
'  | @Vtable[0] = @foo1 (function (as object) as string)   | 4200224
'  | | foo1(This)                                          | | Child.foo1()
'  | @Vtable[1] = @foo2 (function (as object) as string)   | 4200336
'  | | foo2(This)                                          | | Child.foo2()
'
'GrandChild constructor : @This = @Vptr                  1244912
'  Vptr = @Vtable                                          4228268
'  | @Vtable[-1] = @RTTIinfo                               | 4228232
'  | | @RTTIinfo[0] = reserved                             | | 0
'  | | @RTTIinfo[1] = @MangledTypename                     | | 4228244
'  | | | MangledTypename (Length/Typename)                 | | | 10/GRANDCHILD
'  | | @RTTIinfo[2] = @RTTIinfoBase                        | | 4227688
'  | | | @RTTIinfoBase[1] = @MangledTypenameBase           | | | 4227700
'  | | | | MangledTypenameBase (Length/Typename)           | | | | 5/CHILD
'  | @Vtable[0] = @foo1 (function (as object) as string)   | 4200592
'  | | foo1(This)                                          | | GrandChild.foo1()
'  | @Vtable[1] = @foo2 (function (as object) as string)   | 4200704
'  | | foo2(This)                                          | | GrandChild.foo2()

[fxm]

dkl,

Perhaps (more likely) the question below interests me alone, but if you could answer! :-)

Referring to my post just above (http://www.freebasic.net/forum/viewtopi ... 48#p189448):
- Why the first integer of the RTTI info block (above the pointer to type-name string) could be used or reserved, because presently its value is always set to 0?
- Why the value (coded in ASCCI) of the string length preceeds the type-name character data? What may be its use (except a little complicate decoding!)?

[dkl]

Check out the Itanium C++ ABI specification.

If I remember correctly, the first field in the vtable is there to hold an offset to be used with multiple inheritance. It indicates the offset from the base structure to the beginning of the derived structure, and will be non-zero for additional bases in case of multiple inheritance (which fbc doesn't support yet).

The encoding of UDT names, <length> <identifier>, is simply the C++ name mangling. The length is needed in mangled symbol names to be able to demangle them without amgiuity, since the original identifier is included aswell and could otherwise be confused with characters that are given special meaning in the name mangling scheme. This doesn't really matter for the identifiers stored in the rtti tables, it's just that GCC stores the mangled name, so I did the same for fbc to be compatible. But there's no rule about that, I think. Using the mangled name is good though because it means that namespaces will automatically be handled and encoded too, so structures with the same identifier but from different namespaces won't be treated as equal by the Is operator which is based around comparing these type identifiers from the RTTI tables. (However, currently that part is broken in fbc, it doesn't encode namespaces into UDT mangled names yet, but gcc does)

[fxm]

Thank you very much dkl.
Itanium C++ ABI specification is interesting, but very dense because very general (a careful study should occupy many evenings!).

[fxm]

In using preprocessor commands, I wrote a program that highlights the execution times between seven different types of polymorphic code, from (1st) a manual static casting up to (7th) the dynamic cast by advanced virtuality, and through different codes of polymorphism emulation.
All these forms of polymorphism are applied to one method (function) and more the destructor.

By defining the identifier "prog" among seven available values from "prog1" to "prog7" (by un-commenting one line), running the so generated program allows to determine the execution time corresponding to this polymorphic code.
I have adjusted the program loop (compiling without option "-exx") in order to obtain on my PC the execution time of 1.00 (second) for the first code (static casting) that corresponds to the reference time (the faster).

Speed comparison for different implementations of polymorphism (static or dynamic cast) for one member procedure + the destructor:
1) Static polymorphism (static cast) without RTTI neither dynamic polymorphism, for time reference program (the fastest).
=> execution time factor = 1.00 on my PC
2) Dynamic polymorphism (dynamic cast) without use RTTI or virtuality, but with dynamic member string of real typename (emulation of RTTI info).
=> execution time factor = 1.69 on my PC
3) Dynamic polymorphism (dynamic cast) using only RTTI without 'Is' operator, but by getting real typename from RTTI info block (emulation of 'Is' operator).
=> execution time factor = 1.46 on my PC
4) Dynamic polymorphism (dynamic cast) without use RTTI or virtuality, but with dynamic pointer to 'launcher' static procedure passing 'This' instance.
=> execution time factor = 1.24 on my PC
5) Dynamic polymorphism (dynamic cast) using only RTTI ('Is' operator).
=> execution time factor = 1.22 on my PC
6) Dynamic polymorphism (dynamic cast) using only RTTI without virtual calling, but by getting overriding member procedure pointer from Vtable.
=> execution time factor = 1.17 on my PC
7) Dynamic polymorphism (dynamic cast) using RTTI and virtuality.
=> execution time factor = 1.05 on my PC

Code: Select all

'#define prog prog1  ' Static polymorphism (static cast) without RTTI neither dynamic polymorphism,
                     ' for time reference program (the fastest).
                     ' ( => execution time factor = 1.00 on my PC )

'#define prog prog2  ' Dynamic polymorphism (dynamic cast) without use RTTI or virtuality,
                     ' but with dynamic member string of real typename (emulation of RTTI info).
                     ' ( => execution time factor = 1.69 on my PC )

'#define prog prog3  ' Dynamic polymorphism (dynamic cast) using only RTTI without 'Is' operator,
                     ' but by getting real typename from RTTI info block (emulation of 'Is' operator).
                     ' ( => execution time factor = 1.46 on my PC )

'#define prog prog4  ' Dynamic polymorphism (dynamic cast) without use RTTI or virtuality,
                     ' but with dynamic pointer to 'launcher' static procedure passing 'This' instance.
                     ' ( => execution time factor = 1.24 on my PC )

'#define prog prog5  ' Dynamic polymorphism (dynamic cast) using only RTTI ('Is' operator).
                     ' ( => execution time factor = 1.22 on my PC )

'#define prog prog6  ' Dynamic polymorphism (dynamic cast) using only RTTI without virtual calling,
                     ' but by getting overriding member procedure pointer from Vtable.
                     ' ( => execution time factor = 1.17 on my PC )

'#define prog prog7  ' Dynamic polymorphism (dynamic cast) using RTTI and virtuality.
                     ' ( => execution time factor = 1.05 on my PC )

'Remark: compiling without option "-exx"

'--------------------------------------------------------------------------------------------------------

#ifdef prog

'--------------------------------------------------------------------------------------------------------

  #if prog = prog1 or prog = prog2 or prog = prog4
    Type Parent
  #elseif prog = prog3 or prog = prog5 or prog = prog6 or prog = prog7
    Type Parent Extends Object
  #endif
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Function infoType () As String
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Function infoType () As String
    #endif
    #if prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5 or prog = prog6
      Declare Function _infoType () As String
      Declare Sub _delete ()
    #endif
    #if prog = prog2 or prog = prog4
      Declare Constructor ()
    #endif
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Destructor ()
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Destructor ()
    #endif
    #if prog = prog1
      Private:
        Dim dummy As Integer
    #endif
    #if prog = prog2
      Protected:
        Dim As String id
    #endif
    #if prog = prog3
      Protected:
        Declare Function typename () As Const ZString Ptr
    #endif
    #if prog = prog4
      Protected:
        Dim As Function (Byref As Parent) As String p_infoType
        Dim As Sub (Byref As Parent) p_delete
      Private:
        Declare Static Function launcher_infoType (Byref This As Parent) As String
        Declare static Sub launcher_delete (Byref This As Parent)
    #endif
  End Type

  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Function Parent.infoType () As String
      Return @This & ":Parent"
    End Function
  #elseif prog = prog6 or prog = prog7
    Virtual Function Parent.infoType () As String
      Return @This & ":Parent"
    End Function
  #endif
  #if prog = prog2
    Constructor Parent ()
      This.id = "Parent"
    End Constructor
  #endif
  #if prog = prog3
    Function Parent.typename () As Const ZString Ptr
      Dim As Zstring Ptr pz = Cast(Any Ptr Ptr Ptr Ptr, @This)[0][-1][1]
      While (*pz)[0] >= Asc("0") And (*pz)[0] <= Asc("9")
        pz += 1
      Wend
      Return pz
    End Function
  #endif
  #if prog = prog4
    Function Parent._infoType () As String
      Return This.p_infoType(This)
    End Function
    Static Function Parent.launcher_infoType (Byref This As Parent) As String
      Return Cast(Parent ptr, @This)->infoType()
    End Function
    Sub Parent._delete ()
      This.p_delete(This)
    End Sub
    Static Sub Parent.launcher_delete (Byref This As Parent)
      Delete Cast(Parent ptr, @This)
    End Sub
    Constructor Parent ()
      This.p_infoType = @Parent.launcher_infotype
      This.p_delete = @Parent.launcher_delete
    End Constructor
  #endif
  #if prog = prog6
    Function Parent._infoType () As String
      Return Cast(Function (Byref As Parent) As String, Cast(Any Ptr Ptr Ptr, @This)[0][0])(This)
    End Function
    Sub Parent._delete ()
      Cast(Sub (Byref As Parent), Cast(Any Ptr Ptr Ptr, @This)[0][1])(This)
    End Sub
  #endif
  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Destructor Parent ()
    End Destructor
  #elseif prog = prog6 or prog = prog7
    Virtual Destructor Parent ()
    End Destructor
  #endif

  '------------------------------------------------------------------------------------------------------

  Type Child Extends Parent
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Function infoType () As String
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Function infoType () As String Override
    #endif
    #if prog = prog2 or prog = prog4
      Declare Constructor ()
    #endif
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Destructor ()
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Destructor () Override
    #endif
    #if prog = prog4
      Private:
        Declare Static Function launcher_infoType (Byref This As Parent) As String
        Declare Static Sub launcher_delete (Byref This As Parent)
    #endif
  End Type

  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Function Child.InfoType () As String
      Return @This & ":Child"
    End Function
  #endif
  #if prog = prog6 or prog = prog7
    Virtual Function Child.InfoType () As String
      Return @This & ":Child"
    End Function
  #endif
  #if prog = prog2
    Constructor Child ()
      This.id = "Child"
    End Constructor
  #endif
  #if prog = prog4
    Constructor Child ()
      This.p_infoType = @Child.launcher_infoType
      This.p_delete = @Child.launcher_delete
    End Constructor
    Static Function Child.launcher_infoType (Byref This As Parent) As String
      Return Cast(Child ptr, @This)->infoType()
    End Function
    Static Sub Child.launcher_delete (Byref This As Parent)
      Delete Cast(Child ptr, @This)
    End Sub
  #endif
  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Destructor Child ()
    End Destructor
  #elseif prog = prog6 or prog = prog7
    Virtual Destructor Child ()
    End Destructor
  #endif

  '------------------------------------------------------------------------------------------------------

  Type GrandChild Extends Child
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Function infoType () As String
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Function infoType () As String Override
    #endif
    #if prog = prog2 or prog = prog4
      Declare Constructor ()
    #endif
    #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
      Declare Destructor ()
    #elseif prog = prog6 or prog = prog7
      Declare Virtual Destructor () Override
    #endif
    #if prog = prog4
      Private:
        Declare Static Function launcher_infoType (Byref This As Parent) As String
        Declare Static Sub launcher_delete (Byref This As Parent)
    #endif
  End Type

  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Function GrandChild.infoType () As String
      Return @This & ":GrandChild"
    End Function
  #elseif prog = prog6 or prog = prog7
    Virtual Function GrandChild.infoType () As String
      Return @This & ":GrandChild"
    End Function
  #endif
  #if prog = prog2
    Constructor GrandChild ()
      This.id = "GrandChild"
    End Constructor
  #endif
  #if prog = prog4
    Constructor GrandChild ()
      This.p_infoType = @GrandChild.launcher_infoType
      This.p_delete = @GrandChild.launcher_delete
    End Constructor
    Static Function GrandChild.launcher_infoType (Byref This As Parent) As String
      Return Cast(GrandChild Ptr, @This)->infoType()
    End Function
    Static Sub GrandChild.launcher_delete (Byref This As Parent)
      Delete Cast(GrandChild Ptr, @This)
    End Sub
  #endif
  #if prog = prog1 or prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5
    Destructor GrandChild ()
    End Destructor
  #elseif prog = prog6 or prog = prog7
    Virtual Destructor GrandChild ()
    End Destructor
  #endif

  '------------------------------------------------------------------------------------------------------

  #if prog = prog2
    Function Parent._infoType () As String
      If this.id = "GrandChild" Then
        Return Cast(GrandChild Ptr, @This)->infoType()
      Elseif This.id = "Child" Then
        Return Cast(Child Ptr, @This)->infoType()
      Elseif This.id = "Parent" Then
        Return Cast(Parent Ptr, @This)->infoType()
      End If
    End Function
    Sub Parent._delete ()
      If this.id = "GrandChild" Then
        Delete Cast(GrandChild Ptr, @This)
      Elseif This.id = "Child" Then
        Delete Cast(Child Ptr, @This)
      Elseif This.id = "Parent" Then
        Delete Cast(Parent Ptr, @This)
      End If
    End Sub
  #endif
  #if prog = prog3
    Function Parent._infoType () As String
      Dim As Const Zstring Ptr pz = This.typename()
      If *pz = "GRANDCHILD" Then
        Return Cast(GrandChild Ptr, @This)->infoType()
      Elseif *pz = "CHILD" Then
        Return Cast(Child Ptr, @This)->infoType()
      Elseif *pz = "PARENT" Then
        Return Cast(Parent Ptr, @This)->infoType()
      End If
    End Function
    Sub Parent._delete ()
      Dim As Const Zstring Ptr pz = This.typename()
      If *pz = "GRANDCHILD" Then
        Delete Cast(GrandChild Ptr, @This)
      Elseif *pz = "CHILD" Then
        Delete Cast(Child Ptr, @This)
      Elseif *pz = "PARENT" Then
        Delete Cast(Parent Ptr, @This)
      End If
    End Sub
  #endif
  #if prog = prog5
    Function Parent._infoType () As String
      If Cast(Object, This) Is GrandChild Then
        Return Cast(GrandChild Ptr, @This)->infoType()
      Elseif Cast(Object, This) Is Child Then
        Return Cast(Child Ptr, @This)->infoType()
      Elseif Cast(Object, This) Is Parent Then
        Return Cast(Parent Ptr, @This)->infoType()
      End If
    End Function
    Sub Parent._delete ()
      If Cast(Object, This) Is GrandChild Then
        Delete Cast(GrandChild Ptr, @This)
      Elseif Cast(Object, This) Is Child Then
        Delete Cast(Child Ptr, @This)
      Elseif Cast(Object, This) Is Parent Then
        Delete Cast(Parent Ptr, @This)
      End If
    End Sub
  #endif

  '------------------------------------------------------------------------------------------------------

  Dim As Parent Ptr pp, pc, pg
  Dim As String strpp, strpc, strpg
  Dim As Integer nbLoop = 430000

  '------------------------------------------------------------------------------------------------------

  Sleep 1000
  Dim As Single t = Timer
  For I As Integer = 1 To nbLoop
    pp = New Parent
    pc = New Child
    pg = New GrandChild
    #if prog = prog1
      strpp = Cast(Parent Ptr, pp)->infoType()
      strpc = Cast(Child Ptr, pc)->infoType()
      strpg = Cast(GrandChild Ptr, pg)->infoType()
    #elseif prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5 or prog = prog6
      strpp = pp->_infoType()
      strpc = pc->_infoType()
      strpg = pg->_infoType()
    #elseif prog = prog7
      strpp = pp->infoType()
      strpc = pc->infoType()
      strpg = pg->infoType()
    #endif
    #if prog = prog1
      Delete Cast(Parent Ptr, pp)
      Delete Cast(Child Ptr, pc)
      Delete Cast(GrandChild Ptr, pg)
    #elseif prog = prog2 or prog = prog3 or prog = prog4 or prog = prog5 or prog = prog6
      pp->_delete()
      pc->_delete()
      pg->_delete()
    #elseif prog = prog7
      Delete pp
      Delete pc
      Delete pg
    #endif
  Next I
  t = Timer - t

  #if prog = prog1
    Print "Program 1:"
    Print " Static polymorphism (static cast) without RTTI neither dynamic polymorphism,"
    Print " for time reference program (the fastest)"
  #elseif prog = prog2
    Print "Program 2:"
    Print " Dynamic polymorphism (dynamic cast) without use RTTI or virtuality,"
    Print " but with dynamic member string of real typename (emulation of RTTI info)"
  #elseif prog = prog3
    Print "Program 3:"
    Print " Dynamic polymorphism (dynamic cast) using only RTTI without 'Is' operator,"
    Print " but by getting real typename from RTTI info block (emulation of 'Is' operator)"
  #elseif prog = prog4
    Print "Program 4:"
    Print " Dynamic polymorphism (dynamic cast) without use RTTI or virtuality,"
    Print " but with dynamic pointer to 'launcher' static function passing 'This' instance"
  #elseif prog = prog5
    Print "Program 5:"
    Print " Dynamic polymorphism (dynamic cast) using only RTTI ('Is' operator)"
  #elseif prog = prog6
    Print "Program 6:"
    Print " Dynamic polymorphism (dynamic cast) using only RTTI without virtual calling,"
    Print " but by getting overriding member procedure pointer from Vtable"
  #elseif prog = prog7
    Print "Program 7:"
    Print " Dynamic polymorphism (dynamic cast) using RTTI and virtuality"
  #endif
  Print
  Print "Parent:pointer <- New-type     =>     @this:object"
  Print "------------------------------------------------------"
  Print "Parent:" & pp & " <- Parent       =>   " & strpp
  Print "Parent:" & pc & " <- Child        =>   " & strpc
  Print "Parent:" & pg & " <- GrandChild   =>   " & strpg
  Print
  If strpp = pp & ":Parent" And strpc = pc & ":Child" And strpg = pg & ":GrandChild" Then
    Print " time to execute " & nbLoop & " iterations: " & t & "s"
  Else
    Print " program failed"
  End If

'--------------------------------------------------------------------------------------------------------

#else

  Print "Define one prog value!"

'--------------------------------------------------------------------------------------------------------

#endif

Sleep

On this example, I found a nice surprise with an increase of the execution time of only 5% between "prog1" (static casting: the fastest) and "prog7" (full virtuality code: the most advanced).
The differences are slightly increased when compiling with the "-exx" option (for example, the previous value of 5% increases to 8%).

[fxm]

Let us remember this discusion in April/May/June on bug #614 Operator = (assignment to a derived object) modifies RTTI :

I would consider it desirable that at least the most important and most annoying of the remaining bugs, #614 Operator = (assignment to a derived object) modifies RTTI, should be fixed before the release of the new revision!

One 'Let' operator (empty) added in the 'Object' built-in type?

Otherwise, as described in the bug #614 report, the best user workaround is to defined one empty 'Let' operator in a root-type, for example '_Object', extending the 'Object' built-in type:

Code: Select all

Type _Object Extends Object
  Declare Operator Let (Byref _o As _Object)
End Type
Operator _Object.Let (Byref _o As _Object)
End Operator

Type UDT Extends _Object
.....

Throughout the rest of the user program, '_Object' is then used instead of 'Object'.

An implicit Let operator overload is only generated by the compiler if the UDT has "complex" fields or a "complex" base, such as other "class" UDTs that have constructors, destructors or Let operator overloads themselves, or dynamic strings... but for example if it's just simple integers, then the compiler doesn't add an implicit Let operator overload, because that would just be too slow when all that's needed is a bitwise copy.

(C++ academics would say that the default bitwise copy effectively is the implicit copy operator, even though there may not be a dedicated procedure generated to do the work)

It seems to me that correct is better than fast, as long as there's no risk of breaking future code.
If we went with fxm's suggestion, could any code break if we changed to a more efficient solution later?

... but for example if it's just simple integers, then the compiler doesn't add an implicit Let operator overload, because that would just be too slow when all that's needed is a bitwise copy.

I tested that, but even when the UDT has a large number of numeric data fields (20 bytes, 20 integers, 20 longints, 20 singles, 20 doubles), I have not seen a noticeable difference in execution time between when no Let operator is defined in its base type (which should induce the copy of the UDT memory block in one shot) and when a Let operator is defined in its base type (which should induce an implicit UDT Let operator that copies the UDT memory block, but per data field).

An implicit Let operator overload is only generated by the compiler if the UDT has "complex" fields or a "complex" base, such as other "class" UDTs that have constructors, destructors or Let operator overloads themselves, or dynamic strings...

I thought that when an UDT has a base with constructor (implicit or explicit), an implicit Let operator is also generated by the compiler.
Thats why I thought adding an empty operator Let in the built-in Object type should not impact its derived types.

An implicit Let operator overload is only generated by the compiler if the UDT has "complex" fields or a "complex" base, such as other "class" UDTs that have constructors, destructors or Let operator overloads themselves, or dynamic strings...

I thought that when an UDT has a base with constructor (implicit or explicit), an implicit Let operator is also generated by the compiler.
Thats why I thought adding an empty operator Let in the built-in Object type should not impact its derived types.

1) An example which seems to prove the above behavior that I thought:

Code: Select all

Type UDT0 ''Extends Object
  Dim I0 As Integer ''= 0
  Declare Operator Let (Byref rhs As UDT0)
End Type
Operator UDT0.Let (Byref rhs As UDT0)
  Print "*** empty UDT0.Let() ***"
End Operator

Type UDT Extends UDT0
  Dim I AS Integer
End Type

Dim As UDT i1, i2
i1.I0 = 1234
i1.I = 5678
i2 = i1
Print i2.I0, i2.I
Sleep

Code: Select all

 1234          5678

Only a bitwise copy (the Let operator is not called)!

When uncommenting the initializer block (''= 0) to induce an implicit constructor in UDT0 type, or uncommenting the extending block (''Extends Object), the compiler seems to generate an implicit Let operator in UDT type, which contains an assignment as 'Cast(UDT0, This) = rhs' (this calling the explicit Let operator of the UDT0 type):

Code: Select all

*** empty UDT0.Let() ***
 0             5678

2) Another example which seems to prove the above behavior that I thought:

Code: Select all

Type Test
  Dim I0 As Integer
  Declare Operator Let (Byref rhs As Test)
End Type
Operator Test.Let (Byref rhs As Test)
  Print "*** empty Test.Let() ***"
End Operator

Type UDT ''Extends Object
  Dim T As Test
End Type

Dim As UDT u1, u2
u1.T.I0 = 123456789
u2 = u1
Print u2.T.I0
Sleep

Code: Select all

 123456789

Only a bitwise copy (the Let operator is not called)!

When uncommenting the extending block (''Extends Object), the compiler seems to generate an implicit Let operator in UDT type, which contains an assignment as 'This.T = rhs.T' (this calling the explicit Let operator of the Test type):

Code: Select all

*** empty Test.Let() ***
 0

By dint of questionning about an ideal fix, nothing happened and the big bug is still present!
A fix even rustic/temporary but effective, it's always better than no fix at all !

[counting_pine]

This level of OO gives me a headache so I can't be much help.
I sympathise with your complaints and admire your tenacity, but sometimes I think would be capable of some impressive things if only you were to learn the internals of the compiler!

[fxm]

In the current FreeBASIC version, there are also many cases of restriction when using an named Union in a heritance structure with in addition a non obvious syntax and even dangerous.
So I think the most reasonable should be to forbid it as in C++ (named Union forbidden as base or derived).

(refer to this above post http://www.freebasic.net/forum/viewtopi ... 41#p186641
and see also the previous posts from http://www.freebasic.net/forum/viewtopi ... 05#p186605)

- Indeed, a derived named Union does not support field or base with construction or destruction (explicit or implicit). So, it does not support to inherit from the "Object" built-in type.
Therefore its use is then very limited in an heritance structure.

- In addition, any derived named Union (whatever its position in the hierarchy) always shares the same memory space for its non-static data fields (like from the higher base UDT). For static data fields, there is no difference between Type and Union (static data always allocated in memory in the order).
Therefore its use advantage is also limited and even dangerous.
Example:

Code: Select all

Type T1
  Dim As Integer it1
  Static As Integer it1s
End type
Dim As Integer T1.it1s

Union U1 Extends T1
  Dim As Integer iu1
  Static As Integer iu1s
End Union
Dim As Integer U1.iu1s

Type T2 Extends U1
  Dim As Integer it2
  Static As Integer it2s
End Type
Dim As Integer T2.it2s

Type T3 Extends T2
  Union
    Dim As Integer it3u1
    Dim As Integer it3u2
  End Union
End type

Union U2 Extends T3
  Dim As Integer iu2
  Static As Integer iu2s
End Union
Dim As Integer U2.iu2s

Print "it1 offset:", Offsetof(U2, it1)
Print "it1s offset:", Offsetof(U2, it1s)
Print "iu1 offset:", Offsetof(U2, iu1)
Print "iu1s offset:", Offsetof(U2, iu1s)
Print "it2 offset:", Offsetof(U2, it2)
Print "it2s offset:", Offsetof(U2, it2s)
Print "it3u1 offset:", Offsetof(U2, it3u1)
Print "it3u2 offset:", Offsetof(U2, it3u2)
Print "iu2 offset:", Offsetof(U2, iu2)
Print "iu2s offset:", Offsetof(U2, iu2s)

Code: Select all

it1 offset:    0
it1s offset:   4227104
iu1 offset:    0
iu1s offset:   4227108
it2 offset:    4
it2s offset:   4227112
it3u1 offset:  8
it3u2 offset:  8
iu2 offset:    0
iu2s offset:   4227116

I reiterate my point of view, that is to do like in C++:
Named union should be forbidden as base or derived.
(otherwise, documentation should be complete with this limited usage and this weird behavior!)


[Edit]
Analysis complemented with the behavior of static data fields.

[dkl]

I think Unions in combination with Extends are working as expected, and to me there's no reason to disallow it. (see also: http://www.freebasic.net/forum/viewtopi ... 08#p186608)

Similar for Static member variables in Unions: They behave just like they do inside Types, unaffected by whether the UDT is a Union or Type, and that's what I expect. Unions only affect the storage layout of fields, but not Static member variables, that's perhaps not 100% clear at first but I think it's ok.

[fxm]

OK, but if the documentation has not been yet updated, it is well because that functioning (with "extends") is a little twisted and therefore not easy to explain (in my previous post, I tried to summarize the restriction cases and the mapping in memory).