This is actually not the right way.
There should be the GetName and SetName methods.
The vTable should not be passed as a parameter, but should be set internally.
Modules are very useful here to create the classes.
Do not create the methods in the DataSetion either, but use the memory for them when creating the class. This means that you can also overwrite methods during inheritance without overwriting the original method.
Multiple inheritance is also possible. However, the base class must always contain the vTable
I have created an example based on your model.
I'm a little behind with the description.
Update Example With Description v1.03
- Added a macro to set methods
Code: Select all
;-TOP OOP-Example by mk-soft, v1.03, 22.12.2024 ;)
; Link: https://www.purebasic.fr/english/viewtopic.php?p=632409#p632409
EnableExplicit
DeclareModule ClassCommon
Structure sMethod
*Index[0]
EndStructure
Structure sClass
ClassName.s ; Name of class
Size.i ; Size of interface in bytes
*Methods.sMethod ; Pointer to method table
EndStructure
Global NewMap Classes.sClass()
Declare NewClass(ClassName.s, SizeOfInterface, ClassExtends.s = "")
Macro SetMethod(Method)
*Class\Methods\Index[OffsetOf(iMethods\Method()) / SizeOf(Integer)] = @Method()
EndMacro
EndDeclareModule
Module ClassCommon
Procedure NewClass(ClassName.s, SizeOfInterface, ClassExtends.s = "")
Protected *Class.sClass, *ClassExtends.sClass
With Classes()
; Check class is always exists
If FindMapElement(Classes(), ClassName)
Debug "ClassCommon Error: Class always exists: " + ClassName
ProcedureReturn 0
EndIf
; If use extends, check exists extends class
If ClassExtends
*ClassExtends = FindMapElement(Classes(), ClassExtends)
If Not *ClassExtends
Debug "ClassCommon Error: Extends class not exists: " + ClassExtends
ProcedureReturn 0
EndIf
EndIf
; Create new class
*Class = AddMapElement(Classes(), ClassName)
If *Class
; Store class name
\ClassName = ClassName
; Store byte size of method table
\Size = SizeOfInterface
; Allocate memory for method table
\Methods = AllocateMemory(SizeOfInterface)
If Not \Methods
Debug "ClassCommon Error: Out Of Memory:" + ClassName
DeleteMapElement(Classes())
ProcedureReturn 0
EndIf
; If use extends, copy extends methods to new method table
If *ClassExtends
CopyMemory(*ClassExtends\Methods, *Class\Methods, *ClassExtends\Size)
EndIf
ProcedureReturn *Class
Else
Debug "ClassCommon Error: Out Of Memory:" + ClassName
ProcedureReturn 0
EndIf
EndWith
EndProcedure
EndModule
; ****
;- AppletBase
DeclareModule AppletBase
Interface iAppletBase
Show()
Destroy()
EndInterface
Structure sAppletBase
*vTable
EndStructure
Declare New()
EndDeclareModule
Module AppletBase
EnableExplicit
UseModule ClassCommon
; Static pointer to class
Global *Class.sClass
; Macro Interface Helper
Interface iMethods Extends iAppletBase
EndInterface
Procedure New()
Protected *This.sAppletBase
If *Class
*This = AllocateStructure(sAppletBase)
If *This
*This\vTable = *Class\Methods
EndIf
EndIf
ProcedureReturn *This
EndProcedure
Procedure Show(*This.sAppletBase)
Debug *Class\ClassName + ": Show was called"
EndProcedure
Procedure Destroy(*This.sAppletBase)
Debug *Class\ClassName + ": Destroy was called"
; Free all resources here:
; - Do not forget to delete fonts, images, files, etc.
FreeStructure(*This)
EndProcedure
Procedure InitClass()
; Create new class
*Class = NewClass("AppletBase", SizeOf(iAppletBase))
If *Class
With *Class
; Poke method address into method table
; - OffsetOf get the byte address of interface method
; Set methods
SetMethod(Show) ; Macro -> *Class\Methods\Index[OffsetOf(iMethods\Show()) / SizeOf(Integer)] = @Show()
; Write direct method address
PokeI(\Methods + OffsetOf(iAppletBase\Destroy()), @Destroy())
EndWith
Else
Debug "Error: NewClass AppletBase"
CallDebugger
EndIf
EndProcedure : InitClass()
EndModule
; ----
;- Applet
DeclareModule Applet
Interface iApplet Extends AppletBase::iAppletBase
SetName(Name.s)
GetName.s()
EndInterface
Structure sApplet Extends AppletBase::sAppletBase
Name.s
EndStructure
Declare New()
EndDeclareModule
Module Applet
EnableExplicit
UseModule ClassCommon
; Static pointer to class
Global *Class.sClass
; Macro Interface Helper
Interface iMethods Extends iApplet
EndInterface
Procedure New()
Protected *This.sApplet
If *Class
*This = AllocateStructure(sApplet)
If *This
*This\vTable = *Class\Methods
EndIf
EndIf
ProcedureReturn *This
EndProcedure
Procedure Destroy(*This.sApplet)
Debug *Class\ClassName + ": Destroy was called"
; Free all resources here:
; - Do not forget to delete fonts, images, files, etc.
FreeStructure(*This)
EndProcedure
Procedure SetName(*This.sApplet, Name.s)
Debug *Class\ClassName + ": Set name: " + Name
*This\Name = Name
EndProcedure
Procedure.s GetName(*This.sApplet)
Debug *Class\ClassName + ": Get name: " + *This\Name
ProcedureReturn *This\Name
EndProcedure
Procedure InitClass()
; Create new class
*Class = NewClass("Applet", SizeOf(iApplet), "AppletBase")
If *Class
With *Class
; Overwrite Method Destroy
SetMethod(Destroy)
; *Class\Methods\Index[OffsetOf(iMethods\Destroy()) / SizeOf(Integer)] = @Destroy()
; PokeI(\Methods + OffsetOf(iApplet\Destroy()), @Destroy())
; Set new methods
SetMethod(SetName)
SetMethod(GetName)
EndWith
Else
Debug "Error: NewClass Applet"
CallDebugger
EndIf
EndProcedure : InitClass()
EndModule
; ----
;- AppletEx
DeclareModule AppletEx
Interface iAppletEx Extends Applet::iApplet
SetValue(Value)
GetValue()
EndInterface
Structure sAppletEx Extends Applet::sApplet
Value.i
EndStructure
Declare New()
EndDeclareModule
Module AppletEx
EnableExplicit
UseModule ClassCommon
; Static pointer to class
Global *Class.sClass
; Macro Interface Helper
Interface iMethods Extends iAppletEx
EndInterface
Procedure New()
Protected *This.sAppletEx
If *Class
*This = AllocateStructure(sAppletEx)
If *This
*This\vTable = *Class\Methods
EndIf
EndIf
ProcedureReturn *This
EndProcedure
Procedure Show(*This.sAppletEx)
Debug *Class\ClassName + ": Show was called"
EndProcedure
Procedure Destroy(*This.sAppletEx)
Debug *Class\ClassName + ": Destroy was called"
; Free all resources here:
; - Do not forget to delete fonts, images, files, etc.
FreeStructure(*This)
EndProcedure
Procedure.s GetName(*This.sAppletEx)
Debug *Class\ClassName + ": Get name: " + *This\Name + " = " + *This\Value
ProcedureReturn *This\Name + " = " + *This\Value
EndProcedure
Procedure SetValue(*This.sAppletEx, Value)
Debug *Class\ClassName + ": Set value: " + value
*This\Value = Value
EndProcedure
Procedure GetValue(*This.sAppletEx)
Debug *Class\ClassName + ": Get value: " + *This\Value
ProcedureReturn *This\Value
EndProcedure
Procedure InitClass()
*Class = NewClass("AppletEx", SizeOf(iAppletEx), "Applet")
If *Class
With *Class
; Overwrite methods
SetMethod(Show)
SetMethod(Destroy)
SetMethod(GetName)
; Set new methods
SetMethod(SetValue)
SetMethod(GetValue)
EndWith
Else
Debug "Error: NewClass AppletEx"
CallDebugger
EndIf
EndProcedure : InitClass()
EndModule
; ----
;-Test
Define *Obj1.AppletBase::iAppletBase = AppletBase::New()
*Obj1\Show()
Define *Obj2.Applet::iApplet = Applet::New()
*Obj2\Show()
*Obj2\SetName("Hello World")
Debug *Obj2\GetName()
Define *Obj3.AppletEx::iAppletEx = AppletEx::New()
*Obj3\Show()
*Obj3\SetName("Result")
*obj3\SetValue(0815)
Debug *Obj3\GetName()
*Obj3\Destroy() : *Obj3 = 0
*Obj2\Destroy() : *Obj2 = 0
*Obj1\Destroy() : *Obj1 = 0
