How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Forum for discussion about the documentation project.
fxm
Posts: 9013
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Postby fxm » May 17, 2019 13:33

The ability to redefine a method in a derived-type (sub-type) inheriting from a base-type (super-type) is called specialization. It is then possible to call the method of an object without worrying about its intrinsic type: it is the inheritance polymorphism (sub-type polymorphism).
This makes it possible to abstract the details of the specialized types of an object family, by masking them by a common interface which is the base-type.
For example a method 'moving()' will perform the appropriate movement according to the real derived-type of the instance referenced at the time of the call. This will allow the program to say 'instance.moving()' without having to worry about the real derived-type of 'instance'.

1) Let's remember sub-type polymorphism, true operating
    Sub-type polymorphism is the concept of providing a single interface to entities that can have different types (abstraction). More precisely, a same interface is implemented by a member routine having the same identifier in each type belonging to the same inheritance hierarchy.
    Thanks to the abstract/virtual procedures, one can write a code using only the base-type that will automatically call the derived-type procedures.
    By using the same procedure name for several different types, the polymorphism allows a much more generic programming (abstraction). The coder does not have to know, when calling a base procedure, the precise type of object on which the procedure will apply. He just needs to know that this type will implement the procedure.

    - Designation of an object using a pointer or reference of more abstract type:
      Considering a collection of objects whose instantiate types are derived-types from a base-type, then all these objects can be manipulated in an uniform way by considering them as objects of the base-type.
      Better, certain behaviors can be specialized according to the instantiate type of each object. In other words, the use of distinct objects of the same inheritance hierarchy is homogeneous even if the behavior of these objects remains specific.

      Thus, a base-type pointer or reference, pointing to an instance of a derived-type, can be use to manipulate such an object.
    - Overriding the abstract/virtual procedures in the base-type by specialized procedures in derived-types:
      To can declare abstract/virtual procedures in a type, this type must extends (directly or indirectly) the built-in Object type.

      A derived-type can override an abstract/virtual procedure declared in its base-type, by declaring a procedure with the same identifier and signature, meaning same number and type of parameters, same calling convention, and if any, same return type (or a return of a derived-type for return by reference or by pointer):
      • Normally a base-type reference/pointer can access only a procedure in the same type or in a type upper in hierarchy (static binding at compile-time), even if this reference/pointer refers to an object of instantiate type derived from the base-type.
      • But when the base-type procedure is abstract/virtual, this tells the running program to resolve the override procedure the most derived relating to the real object type (dynamic binding at run-time).
2) Example of sub-type polymorphism, true operating
    In the proposed example, the polymorphic part is simple to better bring out all the elements necessary for the mechanics of polymorphism.
    The generic (base) type chosen is any 'animal' (abstraction).
    The specialized (derived) types are a 'dog', a 'cat', and a 'bird' (each defining a non-static string member containing its type-name)
    The abstract methods declared in the generic (base) type, and which must be defined in each specialized (derived) type, are:
      - 'addr_override_fct()': returns the instance address,
      - 'speak_override_fct()': returns the way of speaking,
      - 'type_override_sub()': prints the type-name (from a string member with initialyser).
  • 'animal' type declaration (generic/base-type):
    • Three public abstract methods ('addr_override_fct()', 'speak_override_fct()', 'type_override_sub()') are declared (but without any body defining them).
    • This base-type is non-instantiable, because containing a abstract method at least.

      Code: Select all

      'Base-type animal:
        Type animal Extends Object
          Public:
            Declare Abstract Function addr_override_fct () As animal Ptr
            Declare Abstract Function speak_override_fct () As String
            Declare Abstract Sub type_override_sub ()
        End Type
  • 'dog', 'cat', 'bird' types declarations (specialized/derived-types):
    • For each derived-type, the three same public method ('addr_override_fct()', 'speak_override_fct()', 'type_override_sub()') are declared virtual, and their bodies are specialized for each derived-type.
    • For each derived-type, a non-static string member initialized with its type-name.
    • Each derived-type is instantiable, because implementing all abstract methods declared in its base.

      Code: Select all

      'Derived-type 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:
            Dim As String animal_type = "dog"
        End Type

      Code: Select all

      'Derived-type 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:
            Dim As String animal_type = "cat"
        End Type

      Code: Select all

      'Derived-type 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:
            Dim As String animal_type = "bird"
        End Type
  • Full code of example:
    • To be able to trigger polymorphism, a base-type pointer array ('animal_list') is declared then initialized with instances of different derived-types (a dog, a cat, a bird), in order to constitute a collection of objects from different types (but all having a common base-type).
    • So, the same compiled code line, put in a loop (iterator 'I'), processes all instances from different types ('animal_list(I)->addr_override_fct()', 'animal_list(I)->speak_override_fct()', 'animal_list(I)->type_override_sub()'), because the polymorphism mechanic allows to call each specialized procedure at run-time.

      Code: Select all

      'Base-type animal:
        Type animal Extends Object
          Public:
            Declare Abstract Function addr_override_fct () As animal Ptr
            Declare Abstract Function speak_override_fct () As String
            Declare Abstract Sub type_override_sub ()
        End Type
         
      'Derived-type 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:
            Dim As String animal_type = "dog"
        End Type
         
        'override_sub methods for dog object:
          Virtual Function dog.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function dog.speak_override_fct () As String
            Return "Woof!"
          End Function
          Virtual Sub dog.type_override_sub ()
            Print This.animal_type
          End Sub

      'Derived-type 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:
            Dim As String animal_type = "cat"
        End Type
         
        'override_sub mehods for cat object:
          Virtual Function cat.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function cat.speak_override_fct () As String
            Return "Meow!"
          End Function
          Virtual Sub cat.type_override_sub ()
            Print This.animal_type
          End Sub

      'Derived-type 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:
            Dim As String animal_type = "bird"
        End Type
         
        'override_sub mehods for bird object:
          Virtual Function bird.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function bird.speak_override_fct () As String
            Return "Cheep!"
          End Function
          Virtual Sub bird.type_override_sub ()
            Print This.animal_type
          End Sub

      'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
        Dim As dog Ptr p_my_dog = New dog
        Dim As cat Ptr p_my_cat = New cat
        Dim As bird Ptr p_my_bird = New bird
        Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

      'Have the animals speak and eat:
        Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
        Print "   true operating"
        For I As Integer = lBound(animal_list) To Ubound(animal_list)
          Print "      animal #" & I & ":",
          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
        Next I

      Sleep

      Delete p_my_dog
      Delete p_my_cat
      Delete p_my_bird

      Code: Select all

      SUB-TYPE POLYMORPHISM       @object       speak         type
         true operating
            animal #1:            2042528       Woof!         dog
            animal #2:            2042600       Meow!         cat
            animal #3:            2042672       Cheep!        bird
3) Mechanism under the hood for sub-type polymorphism, true operating
    The abstract/virtual member procedures are implemented using virtual procedure tables (vtbl or vtable). vtbl is, simply explained, a table of static procedures pointers. The compiler fills a vtbl for each polymorphic type, i.e. a type defining at least an abstract/virtual procedure or a type derived from the former.
    vtbl contains entries for all abstract/virtual procedures available in the type, including the abstract/virtual procedures defined in upper level of inheritance hierarchy (for abstract procedure not still implemented, a null pointer is set in the type vtbl).

    Each vtbl contains the correct addresses of procedures for each abstract/virtual procedure in corresponding type. Here correct means the address of the corresponding procedure of the most derived-type that defines/overrides that procedure.
    When the type is instantiated, the instance will contain a pointer (vptr) to the virtual procedure table (vtbl) of the instantiated type.
    When an object of a derived class is referenced within a pointer/reference to a base class, then abstract/virtual procedure feature really performs. The call of a abstract/virtual procedure is somehow translated at run-time and the corresponding procedure from the virtual procedure table of the type of underlying object (not the pointer/reference type) is chosen.
    Thus, what procedure is called depends on what type of object the pointer/reference points to, which can't be known at compile-time, that is why the abstract/virtual procedure call is decided at run-time.

    Therfore, the abstract/virtual procedure call (by means of a pointer or a reference) is not an ordinary call and has a little performance overhead, which may turn into a huge if we have numerous calls.
    The abstract/virtual procedure call is converted by compiler to something else by using the proper vtbl addressed by the vptr value (located at offset 0 in the instance data):
      In the above example, the three calls:
      animal_list(I)->addr_override_fct()
      animal_list(I)->speak_override_fct()
      animal_list(I)->type_override_sub()
      are about translated by the compiler into respectively:
      Cptr(Function (Byref As animal) As animal Ptr, Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][0])(*animal_list(I))
      Cptr(Function (Byref As animal) As String, Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][1])(*animal_list(I))
      Cptr(Sub (Byref As animal), Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][2])(*animal_list(I))
    For vptr, the compiler generates some extra code in the constructor of the type, which it usually adds before the user code. Even if the user does not define a constructor, the compiler generates a default one, and the initialization of vptr is there. So each time an object of a polymorphic type is created, vptr is correctly initialized and points to the vtbl of that type.
4) Sub-type polymorphism mechanism demonstrated by emulation very close to real operating
    This following emulation of sub-type polymorphism is very close to the real operating:
    • a static procedure pointer table 'callback_table()' is defined for each derived-type to emulate the vtbl (an instance reference will be passed as first parameter to each static procedure to emulate the hidden 'This' reference passed to any non-static member procedure),

      Code: Select all

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

      Code: Select all

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

      Code: Select all

      '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}
    • at the base-type level, a non static pointer 'callback_ptr' is allocated for any derived-type instance to emulate the vptr (its value, initialized by the constructor, will depend on what derived-type is constructed: address of the following described table),
    • at the base-type level, each abstract procedure is replaced by a member procedure calling the proper derived procedure through the 'callback_ptr'/'callback_table(I)' ('I' being the index inside the table corresponding to this procedure).

      Code: Select all

      '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
  • Full code of emulation:

    Code: Select all

    ' Emulation of polymorphism is very close to the real operating:
    ' - a non static pointer is allocated for any derived-type instance to emulate the vptr
    '   (its value will depend on what derived-type is constructed: address of the following table)
    ' - a static procedure pointer table is defined for each derived type to emulate the vtable
    '   (an instance reference is passed as first parameter to each static procedure to emulate the hidden 'This' reference passed to any non-static member procedure)


    '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

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

    'callback_sub methods + constructor for dog object:
        Static Function dog.addr_callback_fct (Byref d As dog) As animal Ptr
          Return @d
        End Function
        Static Function dog.speak_callback_fct (Byref d As dog) As String
          Return "Woof!"
        End Function
        Static Sub dog.type_callback_sub (Byref d As dog)
          Print d.animal_type
        End Sub
        Constructor dog ()
          This.callback_ptr = @callback_table(0)
        End Constructor

    'Derived-type cat:
      Type cat Extends animal
        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}

    'callback_sub mehods + constructor for cat object:
        Static Function cat.addr_callback_fct (Byref c As cat) As animal Ptr
          Return @c
        End Function
        Static Function cat.speak_callback_fct (Byref c As cat) As String
          Return "Meow!"
        End Function
        Static Sub cat.type_callback_sub (Byref c As cat)
          Print c.animal_type
        End Sub
        Constructor cat ()
          This.callback_ptr = @callback_table(0)
        End Constructor

    'Derived-type bird:
      Type bird Extends animal
        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_sub mehods + constructor for bird object:
        Static Function bird.addr_callback_fct (Byref b As bird) As animal Ptr
          Return @b
        End Function
        Static Function bird.speak_callback_fct (Byref b As bird) As String
          Return "Cheep!"
        End Function
        Static Sub bird.type_callback_sub (Byref b As bird)
          Print b.animal_type
        End Sub
        Constructor bird ()
          This.callback_ptr = @callback_table(0)
        End Constructor

    'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
      Dim As dog Ptr p_my_dog = New dog
      Dim As cat Ptr p_my_cat = New cat
      Dim As bird Ptr p_my_bird = New bird
      Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

    'Have the animals speak and eat:
      Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
      Print "   by emulation"
      For I As Integer = lBound(animal_list) To Ubound(animal_list)
        Print "      animal #" & I & ":",
        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

    Code: Select all

    SUB-TYPE POLYMORPHISM       @object       speak         type
       by emulation
          animal #1:            9841312       Woof!         dog
          animal #2:            9841384       Meow!         cat
          animal #3:            9841456       Cheep!        bird
5) Same sub-type polymorphism example, with the true code and emulation code, but both nested in a single code for easier comparison

    Code: Select all

    ' Emulated polymorphism (with explicit callback member procedures)
    ' and
    ' True polymorphism (with abstract/virtual member procedures),
    ' both in an inheritance structure.


    'Base-type animal:
      Type animal Extends Object  'Extends Object' useful for true polymorphism only
        ' for true polymorphism:
          Public:
            Declare Abstract Function addr_override_fct () As animal Ptr
            Declare Abstract Function speak_override_fct () As String
            Declare Abstract Sub type_override_sub ()
        ' for polymorphism emulation:
          Protected:
            Dim As Any Ptr Ptr callback_ptr
          Public:
            Declare Function addr_callback_fct () As animal Ptr
            Declare Function speak_callback_fct () As String
            Declare Sub type_callback_sub ()
      End Type
       
      ' for polymorphism emulation:
        Function animal.addr_callback_fct () As animal Ptr
          Return Cptr(Function (Byref As animal) As animal Ptr, This.callback_ptr[0])(This)
        End Function
        Function animal.speak_callback_fct () As String
          Return Cptr(Function (Byref As animal) As String, This.callback_ptr[1])(This)
        End Function
        Sub animal.type_callback_sub ()
          Cptr(Sub (Byref As animal), This.callback_ptr[2])(This)
        End Sub

    'Derived-type dog:
      Type dog Extends animal
        ' for true polymorphism:
          Public:
            Declare Virtual Function addr_override_fct () As animal Ptr Override
            Declare Virtual Function speak_override_fct () As String Override
            Declare Virtual Sub type_override_sub () Override
        ' for polymorphism emulation:
          Private:
            Static As Any Ptr callback_table(0 To 2)
          Public:
            Declare Static Function addr_callback_fct (Byref As dog) As animal Ptr
            Declare Static Function speak_callback_fct (Byref As dog) As String
            Declare Static Sub type_callback_sub (Byref As dog)
            Declare Constructor ()
        ' for all:
          Private:
            Dim As String animal_type = "dog"
      End Type
       
      ' for true polymorphism:
        'override_sub methods for dog object:
          Virtual Function dog.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function dog.speak_override_fct () As String
            Return "Woof!"
          End Function
          Virtual Sub dog.type_override_sub ()
            Print This.animal_type
          End Sub
       
      ' for polymorphism emulation:
        Static As Any Ptr dog.callback_table(0 To 2) _
          = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}
        'callback_sub methods + constructor for dog object:
          Static Function dog.addr_callback_fct (Byref d As dog) As animal Ptr
            Return @d
          End Function
          Static Function dog.speak_callback_fct (Byref d As dog) As String
            Return "Woof!"
          End Function
          Static Sub dog.type_callback_sub (Byref d As dog)
            Print d.animal_type
          End Sub
          Constructor dog ()
            This.callback_ptr = @callback_table(0)
          End Constructor

    'Derived-type cat:
      Type cat Extends animal
       ' for true polymorphism:
          Public:
            Declare Virtual Function addr_override_fct () As animal Ptr Override
            Declare Virtual Function speak_override_fct () As String Override
            Declare Virtual Sub type_override_sub () Override
       ' for polymorphism emulation:
          Private:
            Static As Any Ptr callback_table(0 To 2)
          Public:
            Declare Static Function addr_callback_fct (Byref As cat) As animal Ptr
            Declare Static Function speak_callback_fct (Byref As cat) As String
            Declare Static Sub type_callback_sub (Byref As cat)
            Declare Constructor ()
        ' for all:
          Private:
            Dim As String animal_type = "cat"
      End Type
       
      ' for true polymorphism:
        'override_sub mehods for cat object:
          Virtual Function cat.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function cat.speak_override_fct () As String
            Return "Meow!"
          End Function
          Virtual Sub cat.type_override_sub ()
            Print This.animal_type
          End Sub
       
      ' for polymorphism emulation:
        Static As Any Ptr cat.callback_table(0 To 2) _
          = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}
        'callback_sub mehods + constructor for cat object:
          Static Function cat.addr_callback_fct (Byref c As cat) As animal Ptr
            Return @c
          End Function
          Static Function cat.speak_callback_fct (Byref c As cat) As String
            Return "Meow!"
          End Function
          Static Sub cat.type_callback_sub (Byref c As cat)
            Print c.animal_type
          End Sub
          Constructor cat ()
            This.callback_ptr = @callback_table(0)
          End Constructor

    'Derived-type bird:
      Type bird Extends animal
       ' for true polymorphism:
          Public:
            Declare Virtual Function addr_override_fct () As animal Ptr Override
            Declare Virtual Function speak_override_fct () As String Override
            Declare Virtual Sub type_override_sub () Override
       ' for polymorphism emulation:
          Private:
            Static As Any Ptr callback_table(0 To 2)
          Public:
            Declare Static Function addr_callback_fct (Byref As bird) As animal Ptr
            Declare Static Function speak_callback_fct (Byref As bird) As String
            Declare Static Sub type_callback_sub (Byref As bird)
            Declare Constructor ()
        ' for all:
          Private:
            Dim As String animal_type = "bird"
      End Type
       
      ' for true polymorphism:
        'override_sub mehods for bird object:
          Virtual Function bird.addr_override_fct () As animal Ptr
            Return @This
          End Function
          Virtual Function bird.speak_override_fct () As String
            Return "Cheep!"
          End Function
          Virtual Sub bird.type_override_sub ()
            Print This.animal_type
          End Sub
       
      ' for polymorphism emulation:
        Static As Any Ptr bird.callback_table(0 To 2) _
          = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}
        'callback_sub mehods + constructor for bird object:
          Static Function bird.addr_callback_fct (Byref b As bird) As animal Ptr
            Return @b
          End Function
          Static Function bird.speak_callback_fct (Byref b As bird) As String
            Return "Cheep!"
          End Function
          Static Sub bird.type_callback_sub (Byref b As bird)
            Print b.animal_type
          End Sub
          Constructor bird ()
            This.callback_ptr = @callback_table(0)
          End Constructor

    'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
      Dim As dog Ptr p_my_dog = New dog
      Dim As cat Ptr p_my_cat = New cat
      Dim As bird Ptr p_my_bird = New bird
      Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird}

    'Have the animals speak and eat:
      Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
      For I As Integer = lBound(animal_list) To Ubound(animal_list)
        Print "   animal #" & I & ":"
        ' for override_sub:
          Print "      true operating:",
          Print animal_list(I)->addr_override_fct(),   'real polymorphism
          Print animal_list(I)->speak_override_fct(),  'real polymorphism
          animal_list(I)->type_override_sub()          'real polymorphism
        ' for polymorphism emulation:
          Print "      by emulation:",
          Print animal_list(I)->addr_callback_fct(),   'emulated polymorphism
          Print animal_list(I)->speak_callback_fct(),  'emulated polymorphism
          animal_list(I)->type_callback_sub()          'emulated polymorphism
      Next I

    Sleep

    Delete p_my_dog
    Delete p_my_cat
    Delete p_my_bird

    Code: Select all

    SUB-TYPE POLYMORPHISM       @object       speak         type
       animal #1:
          true operating:       4663968       Woof!         dog
          by emulation:         4663968       Woof!         dog
       animal #2:
          true operating:       4664048       Meow!         cat
          by emulation:         4664048       Meow!         cat
       animal #3:
          true operating:       4664128       Cheep!        bird
          by emulation:         4664128       Cheep!        bird

See also:
- How and Why to make Abstraction by Subtype Polymorphism, with FB Syntax in UDTs (advanced)
Tourist Trap
Posts: 2756
Joined: Jun 02, 2015 16:24

Re: How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Postby Tourist Trap » May 17, 2019 15:19

Thanks fxm!

It reminds me of the tutorial by rdc or maybe someone else that was precisely introducing OOP by emulation from a procedural code (in the documentation's tutorials). I used to love this approach. I will try to run your examples and study this great work you did.
dodicat
Posts: 5816
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Postby dodicat » May 17, 2019 17:04

Just one complaint.
A bird cheeps (if it is happy).
Sheep is another animal.(Can supply wool if clipped)

For oop the test must be how easy it is to extend the animal family (with sheep).
luckily fxm's code is robust.

Code: Select all

' Emulated polymorphism (with explicit callback member procedures)
' and
' True polymorphism (with abstract/virtual member procedures),
' both in an inheritance structure.


'Base-type animal:
  Type animal Extends Object  'Extends Object' useful for true polymorphism only
    ' for true polymorphism:
      Public:
        Declare Abstract Function addr_override_fct () As animal Ptr
        Declare Abstract Function speak_override_fct () As String
        Declare Abstract Sub type_override_sub ()
    ' for polymorphism emulation:
      Protected:
        Dim As Any Ptr Ptr callback_ptr
      Public:
        Declare Function addr_callback_fct () As animal Ptr
        Declare Function speak_callback_fct () As String
        Declare Sub type_callback_sub ()
  End Type
   
  ' for polymorphism emulation:
    Function animal.addr_callback_fct () As animal Ptr
      Return Cptr(Function (Byref As animal) As animal Ptr, This.callback_ptr[0])(This)
    End Function
    Function animal.speak_callback_fct () As String
      Return Cptr(Function (Byref As animal) As String, This.callback_ptr[1])(This)
    End Function
    Sub animal.type_callback_sub ()
      Cptr(Sub (Byref As animal), This.callback_ptr[2])(This)
    End Sub

'Derived-type dog:
  Type dog Extends animal
    ' for true polymorphism:
      Public:
        Declare Virtual Function addr_override_fct () As animal Ptr Override
        Declare Virtual Function speak_override_fct () As String Override
        Declare Virtual Sub type_override_sub () Override
    ' for polymorphism emulation:
      Private:
        Static As Any Ptr callback_table(0 To 2)
      Public:
        Declare Static Function addr_callback_fct (Byref As dog) As animal Ptr
        Declare Static Function speak_callback_fct (Byref As dog) As String
        Declare Static Sub type_callback_sub (Byref As dog)
        Declare Constructor ()
    ' for all:
      Private:
        Dim As String animal_type = "dog"
  End Type
   
  ' for true polymorphism:
    'override_sub methods for dog object:
      Virtual Function dog.addr_override_fct () As animal Ptr
        Return @This
      End Function
      Virtual Function dog.speak_override_fct () As String
        Return "Woof!"
      End Function
      Virtual Sub dog.type_override_sub ()
        Print This.animal_type
      End Sub
   
  ' for polymorphism emulation:
    Static As Any Ptr dog.callback_table(0 To 2) _
      = {@dog.addr_callback_fct, @dog.speak_callback_fct, @dog.type_callback_sub}
    'callback_sub methods + constructor for dog object:
      Static Function dog.addr_callback_fct (Byref d As dog) As animal Ptr
        Return @d
      End Function
      Static Function dog.speak_callback_fct (Byref d As dog) As String
        Return "Woof!"
      End Function
      Static Sub dog.type_callback_sub (Byref d As dog)
        Print d.animal_type
      End Sub
      Constructor dog ()
        This.callback_ptr = @callback_table(0)
      End Constructor

'Derived-type cat:
  Type cat Extends animal
   ' for true polymorphism:
      Public:
        Declare Virtual Function addr_override_fct () As animal Ptr Override
        Declare Virtual Function speak_override_fct () As String Override
        Declare Virtual Sub type_override_sub () Override
   ' for polymorphism emulation:
      Private:
        Static As Any Ptr callback_table(0 To 2)
      Public:
        Declare Static Function addr_callback_fct (Byref As cat) As animal Ptr
        Declare Static Function speak_callback_fct (Byref As cat) As String
        Declare Static Sub type_callback_sub (Byref As cat)
        Declare Constructor ()
    ' for all:
      Private:
        Dim As String animal_type = "cat"
  End Type
   
  ' for true polymorphism:
    'override_sub mehods for cat object:
      Virtual Function cat.addr_override_fct () As animal Ptr
        Return @This
      End Function
      Virtual Function cat.speak_override_fct () As String
        Return "Meow!"
      End Function
      Virtual Sub cat.type_override_sub ()
        Print This.animal_type
      End Sub
   
  ' for polymorphism emulation:
    Static As Any Ptr cat.callback_table(0 To 2) _
      = {@cat.addr_callback_fct, @cat.speak_callback_fct, @cat.type_callback_sub}
    'callback_sub mehods + constructor for cat object:
      Static Function cat.addr_callback_fct (Byref c As cat) As animal Ptr
        Return @c
      End Function
      Static Function cat.speak_callback_fct (Byref c As cat) As String
        Return "Meow!"
      End Function
      Static Sub cat.type_callback_sub (Byref c As cat)
        Print c.animal_type
      End Sub
      Constructor cat ()
        This.callback_ptr = @callback_table(0)
      End Constructor

'Derived-type bird:
  Type bird Extends animal
   ' for true polymorphism:
      Public:
        Declare Virtual Function addr_override_fct () As animal Ptr Override
        Declare Virtual Function speak_override_fct () As String Override
        Declare Virtual Sub type_override_sub () Override
   ' for polymorphism emulation:
      Private:
        Static As Any Ptr callback_table(0 To 2)
      Public:
        Declare Static Function addr_callback_fct (Byref As bird) As animal Ptr
        Declare Static Function speak_callback_fct (Byref As bird) As String
        Declare Static Sub type_callback_sub (Byref As bird)
        Declare Constructor ()
    ' for all:
      Private:
        Dim As String animal_type = "bird"
  End Type
 
   
   
  ' for true polymorphism:
    'override_sub mehods for bird object:
      Virtual Function bird.addr_override_fct () As animal Ptr
        Return @This
      End Function
      Virtual Function bird.speak_override_fct () As String
        Return "Cheep!"
      End Function
      Virtual Sub bird.type_override_sub ()
        Print This.animal_type
      End Sub
      ' for polymorphism emulation:
    Static As Any Ptr bird.callback_table(0 To 2) _
      = {@bird.addr_callback_fct, @bird.speak_callback_fct, @bird.type_callback_sub}
    'callback_sub mehods + constructor for bird object:
      Static Function bird.addr_callback_fct (Byref b As bird) As animal Ptr
        Return @b
      End Function
      Static Function bird.speak_callback_fct (Byref b As bird) As String
        Return "Cheep!"
      End Function
      Static Sub bird.type_callback_sub (Byref b As bird)
        Print b.animal_type
      End Sub
      Constructor bird ()
        This.callback_ptr = @callback_table(0)
      End Constructor
     
      Type sheep Extends animal
   ' for true polymorphism:
      Public:
        Declare Virtual Function addr_override_fct () As animal Ptr Override
        Declare Virtual Function speak_override_fct () As String Override
        Declare Virtual Sub type_override_sub () Override
   ' for polymorphism emulation:
      Private:
        Static As Any Ptr callback_table(0 To 2)
      Public:
        Declare Static Function addr_callback_fct (Byref As sheep) As animal Ptr
        Declare Static Function speak_callback_fct (Byref As sheep) As String
        Declare Static Sub type_callback_sub (Byref As sheep)
        Declare Constructor ()
    ' for all:
      Private:
        Dim As String animal_type = "sheep"
  End Type
      'override_sub mehods for sheep object:
      Virtual Function sheep.addr_override_fct () As animal Ptr
        Return @This
      End Function
      Virtual Function sheep.speak_override_fct () As String
        Return "Baa Baa!"
      End Function
      Virtual Sub sheep.type_override_sub ()
        Print This.animal_type
      End Sub
      ' for polymorphism emulation:
    Static As Any Ptr sheep.callback_table(0 To 2) _
      = {@sheep.addr_callback_fct, @sheep.speak_callback_fct, @sheep.type_callback_sub}
    'callback_sub mehods + constructor for sheep object:
      Static Function sheep.addr_callback_fct (Byref b As sheep) As animal Ptr
        Return @b
      End Function
      Static Function sheep.speak_callback_fct (Byref b As sheep) As String
        Return "Baa Baa!"
      End Function
      Static Sub sheep.type_callback_sub (Byref b As sheep)
        Print b.animal_type
      End Sub
      Constructor sheep ()
        This.callback_ptr = @callback_table(0)
      End Constructor
     
   
 

'Create a dog and cat and bird dynamic instances referred through an animal pointer list:
  Dim As dog Ptr p_my_dog = New dog
  Dim As cat Ptr p_my_cat = New cat
  Dim As bird Ptr p_my_bird = New bird
  Dim As sheep Ptr p_my_sheep = New sheep
  Dim As animal Ptr animal_list (1 To ...) = {p_my_dog, p_my_cat, p_my_bird,p_my_sheep}

'Have the animals speak and eat:
  Print "SUB-TYPE POLYMORPHISM", "@object", "speak", "type"
  For I As Integer = lBound(animal_list) To Ubound(animal_list)
    Print "   animal #" & I & ":"
    ' for override_sub:
      Print "      true operating:",
      Print animal_list(I)->addr_override_fct(),   'real polymorphism
      Print animal_list(I)->speak_override_fct(),  'real polymorphism
      animal_list(I)->type_override_sub()          'real polymorphism
    ' for polymorphism emulation:
      Print "      by emulation:",
      Print animal_list(I)->addr_callback_fct(),   'emulated polymorphism
      Print animal_list(I)->speak_callback_fct(),  'emulated polymorphism
      animal_list(I)->type_callback_sub()          'emulated polymorphism
  Next I

Sleep

Delete p_my_dog
Delete p_my_cat
Delete p_my_bird
Delete p_my_sheep
fxm
Posts: 9013
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Postby fxm » May 17, 2019 17:51

dodicat wrote:Just one complaint.
A bird cheeps (if it is happy).
Sheep is another animal.(Can supply wool if clipped)

Corrected now.
Thanks.
fxm
Posts: 9013
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How FB supports Sub-Type Polymorphism, demonstrated by Emulation very Close to Real Operating

Postby fxm » May 17, 2019 18:29

I added the following within paragraph 3:
fxm wrote:.....
The abstract/virtual procedure call is converted by compiler to something else by using the proper vtbl addressed by the vptr value (located at offset 0 in the instance data):
    In the above example, the three calls:
    animal_list(I)->addr_override_fct()
    animal_list(I)->speak_override_fct()
    animal_list(I)->type_override_sub()
    are about translated by the compiler into respectively:
    Cptr(Function (Byref As animal) As animal Ptr, Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][0])(*animal_list(I))
    Cptr(Function (Byref As animal) As String, Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][1])(*animal_list(I))
    Cptr(Sub (Byref As animal), Cptr(Any Ptr Ptr Ptr, animal_list(I))[0][2])(*animal_list(I))
.....

Return to “Documentation”

Who is online

Users browsing this forum: No registered users and 1 guest