• Welcome to Jose's Read Only Forum 2023.
 

OOP-Precompiler für PureBasic

Started by Theo Gottwald, July 18, 2020, 10:00:04 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

Theo Gottwald

The only way to implement something like OOP in Purebasic is currently using an Pre-Compiler.
Doing so so, you can also add own features to the language with no problems.
This is a working Sample that compiles with PureBasic 5.72.


;-TOP
; Kommentar     : OOP-PreCompiler mit Klassenvererbung
; Author        : mk-soft
; Second Author :
; Datei         : OOP-PreCompilerX64.pb
; Version       : 0.46
; Erstellt      : 25.12.2007
; Geändert      : 21.04.2010
;
; Compilermode  :
;
; ***************************************************************************************

EnableExplicit

;- Konstanten
#File = 0
#Zeichen = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"

; ***************************************************************************************

#PROGRAM = "OOP-PreCompiler X32/64 Version 0.47"
#REVISION = "Rev. "
#COPYRIGHT = "©2007-2010 by Michael Kastner (mk-soft)"

Global ABOUT.s
ABOUT = #PROGRAM + #LF$ + #REVISION + Str(#PB_Compiler_Date/86400) + #LF$ + #LF$ + #COPYRIGHT

; ***************************************************************************************
;- Strukturen
Structure udtClass
  ClassName.s
  Extends.s
  UIID.s
EndStructure

Structure udtMethod
  ClassName.s
  MethodName.s
  Type.s
  Key.s
  Param.s
EndStructure

; ***************************************************************************************

;- Globale Variablen und Listen
Global filename.s, pathname.s
Global filetype.l
Global firstline.l


Global NewList IncludeFiles.s()
Global NewList Lines.s()
Global NewList AllLines.s()
Global NewList ListClass.udtClass()
Global NewList ListMethod.s()
Global NewList ListDetailMethod.udtMethod()
Global NewList TopLines.s()
Global NewList BottomLines.s()
Global NewList InterfaceLines.s()
Global NewList DeclareClass.s()

; ***************************************************************************************

Procedure msg(Text.s)
  MessageRequester("Debug", text)
EndProcedure


; ***************************************************************************************

Procedure FindStringRight(String.s, StringToFind.s, Startposition.l = 0)

  Protected len, len2, index
 
  len = Len(String)
  len2 = Len(StringToFind)
  If Startposition = 0
    Startposition = len
  EndIf
  For index = Startposition To 1 Step - 1
    If Mid(String, index, len2) = StringToFind
      ProcedureReturn index
    EndIf
  Next
  ProcedureReturn 0
 
EndProcedure

; ***************************************************************************************

Procedure.s ParseIncludePath(line.s,pos)
 
  Protected temp.s, part.s, pos2, i
  NewList List.s()
 
  pos2 = FindString(line, " ", pos) + 1
  temp = Mid(line, pos2, Len(line))
  temp = Trim(temp)
  Repeat
    i + 1
    part = Trim(StringField(temp, i, "+"))
    If part = ""
      Break
    EndIf
    AddElement(List())
    List() = part
  ForEver
 
  temp = ""
  ForEach List()
    Select List()
      Case "#PB_Compiler_Home"
        temp + #PB_Compiler_Home
      Default
        If Left(List(),1) = #DQUOTE$
          temp + Mid(List(), 2, Len(List()) - 2)
        Else
          temp + ""
        EndIf
    EndSelect
  Next
  ProcedureReturn temp 

EndProcedure

; ***************************************************************************************

Procedure.s LoadIncludeFileList(FileName.s)

  Static File, Include.s
 
  Protected FF, Path.s, IFile.s, Path2.s, Line.s, Pos, PosB, PosE, temp.s, IsLoad
 
  File + 1
  If ReadFile(File, FileName) = 0
    File - 1
    ProcedureReturn ""
  EndIf
 
  While Eof(File) = 0
    IFile = ""

    Line = ReadString(File)
   
    ; check IncludePath
    Pos = FindString(Line, "IncludePath", 1)
    If FindStringRight(Line, ";", Pos) Or FindStringRight(Line, #DQUOTE$, Pos)
      Pos = 0
    EndIf
    If pos
      include = ParseIncludePath(Line, Pos)
      If include
        CompilerIf #PB_Compiler_OS = #PB_OS_Linux
          If Right(include, 1) <> "/" : include + "/": EndIf
        CompilerElse
          If Right(include, 1) <> "\" : include + "\": EndIf
        CompilerEndIf
      EndIf
    EndIf
   
    Pos = FindString(Line, "IncludeFile", 1)
    If FindStringRight(Line, ";", Pos) Or FindStringRight(Line, #DQUOTE$, Pos)
      Pos = 0
    EndIf
    If pos
      temp = include + ParseIncludePath(Line, Pos)
      IsLoad = #False
      ForEach IncludeFiles()
        If UCase(IncludeFiles()) = UCase(temp)
          IsLoad = #True
          Break
        EndIf
      Next
      If Not IsLoad
        AddElement(IncludeFiles())
        IncludeFiles() = temp
        LoadIncludeFileList(temp)
      EndIf
    EndIf
  Wend
  CloseFile(File)
  File - 1
 
EndProcedure

; ***************************************************************************************

Procedure LoadFile()

  Protected line.s, valid, ft
 
  ; Dateiname holen
  filename = ProgramParameter()
  If filename = ""
    MessageRequester("About", about)
    ProcedureReturn #False
  EndIf
  ; Path lesen
  pathname = GetPathPart(filename)
 
  ; Datei öffnen zu lesen
  If ReadFile(#File, filename) = 0
    ProcedureReturn #False
  EndIf
 
  ; Type ermitteln
  filetype = ReadStringFormat(#File)
 
  ; Datei einlesen
  While Eof(#File) = 0
    line = ReadString(#File, filetype)
    AddElement(Lines())
    Lines() = line
  Wend
  CloseFile(#File)
 
  ; Alle Include Dateien einlesen
  LoadIncludeFileList(FileName)
  ForEach IncludeFiles()
    ; Datei öffnen zu lesen
    If ReadFile(#File, IncludeFiles()) = 0
      ProcedureReturn #False
    EndIf
   
    ; Type ermitteln
    ft = ReadStringFormat(#File)
   
    ; Datei einlesen
    While Eof(#File) = 0
      line = ReadString(#File, ft)
      AddElement(AllLines())
      AllLines() = line
    Wend
    CloseFile(#File)
  Next
 
  ProcedureReturn #True
 
EndProcedure

; ***************************************************************************************

Procedure SaveFile()

  Protected path.s, topfile.s, bottomfile.s, interfacefile.s
 
  path = GetPathPart(FileName)
  topfile = path + "topfile.oop"
  bottomfile = path + "bottomfile.oop"
  interfacefile = path + "interfacefile.oop"
 
  ; Speicher TopFile
  If CreateFile(#File, topfile)
    ForEach TopLines()
      WriteStringN(#File, TopLines())
    Next
    CloseFile(#File)
  EndIf
 
  ; Speicher BottomFile
  If CreateFile(#File, bottomfile)
    ForEach BottomLines()
      WriteStringN(#File, BottomLines())
    Next
    CloseFile(#File)
  EndIf
 
  ; Include TopFile
  FirstElement(Lines())
  Lines() = "Includefile " + #DQUOTE$ + topfile + #DQUOTE$ + " : " + Lines()
 
  ; letzte Zeile suchen
  LastElement(Lines())
  While Left(Lines(), 1) = ";"
    PreviousElement(Lines())
  Wend
 
  ; Include BottomFile
  AddElement(Lines())
  Lines() = "Includefile " + #DQUOTE$ + bottomfile + #DQUOTE$
 
  If CreateFile(#File, FileName) = 0
    ProcedureReturn #False
  EndIf
  ForEach Lines()
    WriteStringN(#File, Lines(), filetype)
  Next
  CloseFile(#File)
 
EndProcedure

; ***************************************************************************************

Procedure FindAllClass(List List.s())

  Protected line.s, ClassName.s, ExtendsName.s, ch.s, temp.s
  Protected pos1, pos2, len, IsClass
  ForEach List()
    line = UCase(List())
    pos1 = FindString(line, "CLASS(", 1)
    If pos1
      IsClass = #True
      len = pos1 - 1
      For pos1 = 1 To len
        If Mid(Line, pos1, 1) <> " "
          IsClass = #False
          Break
        EndIf
      Next
      If IsClass
        ; Parameter filtern
        pos1 = FindString(line, "(", pos1) + 1
        pos2 = FindString(line, ")", pos1)
        temp = Mid(List(), pos1, pos2 - pos1)
       
        ; ClassName filtern
        ClassName = StringField(temp, 1, ",")
        ClassName = Trim(ClassName)
       
        ; ExtendsName filtern
        ExtendsName = StringField(temp, 2, ",")
        ExtendsName = Trim(ExtendsName)
        If ExtendsName = ""
          ExtendsName = "BaseClass"
        EndIf
        ; Hinzufügen
        AddElement(ListClass())
        ListClass()\ClassName = Trim(ClassName)
        ListClass()\Extends = Trim(ExtendsName)
      EndIf
    EndIf
  Next
 
  ProcedureReturn #True
 
EndProcedure

; ***************************************************************************************

Procedure FindAllMethod(List List.s())

  Protected line.s, Methode.s
  Protected pos1, pos2, len, IsMethode
 
  ForEach List()
    line = UCase(List())
    pos1 = 0
    If FindString(line, "ENDMETHOD", 1) = 0
      pos1 = FindString(line, "METHOD", 1)
    EndIf
    If pos1
      IsMethode = #True
      len = pos1 - 1
      For pos1 = 1 To len
        If Mid(Line, pos1, 1) <> " "
          IsMethode = #False
          Break
        EndIf
      Next
      If IsMethode
        Methode = Mid(List(), pos1, Len(line))
        Methode = Trim(Methode)
        If UCase(Left(Methode,1)) >= "A" And UCase(Left(Methode,1)) <= "Z"
          AddElement(ListMethod())
          ListMethod() = Methode
        EndIf
      EndIf
    EndIf
  Next
 
  ProcedureReturn #True
 
EndProcedure

; ***************************************************************************************

Procedure FindUIID(List List.s())

  Protected line.s, UIID.s, find.s
  Protected pos1, pos2, len, IsUIID
 
  ForEach ListClass()
    find = UCase("UIID_" + ListClass()\ClassName + ":")
    ForEach List()
      line = UCase(List())
      pos1 = FindString(line, find, 1)
      If pos1
        IsUIID = #True
        len = pos1 - 1
        For pos2 = 1 To len
          If Mid(Line, pos2, 1) <> " "
            IsUIID = #False
            Break
          EndIf
        Next
        If IsUIID
          pos2 = FindString(line, ":", pos1) + 1
          len = pos2 - pos1 - 1
          UIID = Mid(List(), pos1, len)
          UIID = Trim(UIID)
          ListClass()\UIID = UIID
        EndIf
      EndIf
    Next
  Next
   
  ProcedureReturn #True
 
EndProcedure

; ***************************************************************************************

; ***************************************************************************************

Procedure SplitListMethod()

  Protected line.s, uline.s, Methoden.s, ExtendsName.s, type.s, result.s, len, pos1, pos2, pos3
 
  ForEach ListMethod()
    AddElement(ListDetailMethod())
    line = ListMethod()
    line = ReplaceString(line, "(", " (")
    uline = UCase(ListMethod())
    uline = ReplaceString(uline, "(", " (")
    ; Part 1 Type Methode
    pos1 = 1
    result = StringField(line, pos1, " ")
    If Len(result) > 6
      type = StringField(result, 2, ".")
      ListDetailMethod()\Type = type
    EndIf
    pos1 + 1
    ; Part 2 Methode key Overwrite
    result = StringField(uline, pos1, " ")
    If FindString(result, "OVERWRITE", 1)
      ListDetailMethod()\Key = "OVERWRITE"
      pos1 + 1
    EndIf
    result = StringField(line, pos1, " ")
    ; Part 3 ClassName
    ListDetailMethod()\ClassName = Trim(StringField(result, 1, "_"))
    ; Part 4 MethodName
    ListDetailMethod()\MethodName = Trim(StringField(result, 2, "_"))
    ; Part 4 - ersten Parameter entfernen
    pos1 = FindString(line, "(", 1)
    pos2 = FindString(line, ",", pos1)
    If pos2
      pos2 + 1
      result = "(" + Mid(line, pos2, Len(line))
      result = RemoveString(result, " ")
      pos3 = FindString(result, ";", 1)
      If pos3
        pos3 - 1
        result = Left(result, pos3)
      EndIf
      ListDetailMethod()\Param = result
    Else
      ListDetailMethod()\Param = "()"
    EndIf
  Next
 
EndProcedure

; ***************************************************************************************

Procedure CreateUnknown(*Class.udtClass, List List.s())
 
  Protected line.s, UIID.s, parameters.s
 
  UIID = " Or CompareMemory(*UIID, ?"
 
  ; Parameters InitObject finden
  parameters = "()"
  ForEach ListDetailMethod()
    If UCase(ListDetailMethod()\ClassName) = UCase(*Class\ClassName)
      If UCase(ListDetailMethod()\MethodName) = "INITOBJECT"
        parameters = ListDetailMethod()\param
        Break
      EndIf
    EndIf
  Next
 
  Restore IUnknown
  Repeat
    Read.s line
    If line = "EEEE"
      Break
    EndIf
    ;line = ReplaceString(line, "<Parent>", *Class\Extends)
    line = ReplaceString(line, "(__parameters__)", parameters)
    line = ReplaceString(line, "<Class>", *Class\ClassName)
    If FindString(line, "__UIID__", 1)
      If *Class\UIID
        UIID = " Or CompareMemory(*UIID, ?" + *Class\UIID + ", 16)"
        line = ReplaceString(line, "__UIID__", UIID)
      Else
        line = RemoveString(line, "__UIID__")
      EndIf
    EndIf
    AddElement(List())
    List() = Line
  ForEver
 
  ; Create Declare Class
  AddElement(DeclareClass())
  DeclareClass() = "Declare New" + *Class\ClassName + parameters
 
EndProcedure

; ***************************************************************************************

Procedure CreateMacros(List List.s())
 
  Protected line.s, path.s
 
  Restore Macros
  Repeat
    Read.s line
    If line = "EEEE"
      Break
    EndIf
    AddElement(List())
    List() = line
  ForEver
 
EndProcedure

; ***************************************************************************************

Procedure CreateUIID(List List.s())
 
  Protected line.s
 
  Restore IID_IUnknown
  Repeat
    Read.s line
    If line = "EEEE"
      Break
    EndIf
    AddElement(List())
    List() = line
  ForEver
 
EndProcedure

; ***************************************************************************************

Global ParentClass.s

Procedure CreateInterface(*Class.udtClass, List List.s())

  Protected line.s, Methoden.s, ExtendsName.s, type.s, result.s, len, pos1, pos2
   
    ; Kopfzeile
    AddElement(List())
    If UCase(*Class\Extends) = "BASECLASS"
      List() = "Interface I" + *Class\ClassName + " Extends IUnknown"
    Else
      List() = "Interface I" + *Class\ClassName + " Extends I" + *Class\Extends
    EndIf
   
      ; Eigene Classe einbinden
      Methoden = UCase(*Class\ClassName)
      ForEach ListDetailMethod()
        line = UCase(ListDetailMethod()\ClassName)
        pos1 = FindString(line, Methoden, 1)
        If pos1
          If ListDetailMethod()\key = ""
            result = "  " + ListDetailMethod()\MethodName
            If ListDetailMethod()\type
              result + "." + ListDetailMethod()\Type
            EndIf
            result + ListDetailMethod()\Param
            AddElement(List())
            List() = result
          EndIf
        EndIf
      Next
       
    ; Fusszeile
    AddElement(List())
    List() = "EndInterface; I" + *Class\ClassName
   
EndProcedure

; ***************************************************************************************

Procedure CreateDataSection(*Class.udtClass, List List.s())

  Protected line.s, Methoden.s, ExtendsName.s, len, pos1, pos2, Isfind
  Protected temp1.s, temp2.s
  Protected NewList ExtMethod.s()
  Protected NewList InternMethod.s()
 
    ; Kopfzeile
    AddElement(List())
    List() = "DataSection; I" + *Class\ClassName
    ; Adress Pointer
    AddElement(List())
    List() = "  __" + *Class\ClassName + "_Method:"
   
      ; Vererbte Classen suchen
      ExtendsName = UCase(*Class\Extends)
      Repeat
        If ExtendsName = "BASECLASS"
          Break
        EndIf
        ResetList(ExtMethod())
        IsFind = #False
        ForEach ListClass()
          If UCase(ListClass()\ClassName) = ExtendsName
            ExtendsName = UCase(ListClass()\Extends)
            IsFind = #True
            Break
          EndIf
        Next
        Methoden = UCase(ListClass()\ClassName)
        ForEach ListDetailMethod()
          pos1 = FindString(UCase(ListDetailMethod()\ClassName), Methoden, 1)
          If pos1
            AddElement(ExtMethod())
            ExtMethod() = "  Data.i @" + ListDetailMethod()\ClassName + "_" + ListDetailMethod()\MethodName + "()"
          EndIf
        Next
      Until Not IsFind
     
      ; Methoden IUnknown einbinden
      ResetList(ExtMethod())
      AddElement(ExtMethod())
      ExtMethod() = "  Data.i @" + *Class\ClassName + "_QueryInterface()"
      AddElement(ExtMethod())
      ExtMethod() = "  Data.i @" + *Class\ClassName + "_AddRef()"
      AddElement(ExtMethod())
      ExtMethod() = "  Data.i @" + *Class\ClassName + "_Release()"
     
      ; Eigene Classe suchen
      Methoden = UCase(*Class\ClassName)
      ForEach ListDetailMethod()
        line = UCase(ListDetailMethod()\ClassName)
        pos1 = FindString(line, Methoden, 1)
        If pos1
          If ListDetailMethod()\Key = "OVERWRITE"
            IsFind = #False
            ForEach ExtMethod()
              temp1 = UCase(ExtMethod())
              temp2 = UCase(ListDetailMethod()\MethodName)
              If FindString(temp1, temp2, 1)
                DeleteElement(ExtMethod())
                AddElement(ExtMethod())
                ExtMethod() = "  Data.i @" + ListDetailMethod()\ClassName + "_" + ListDetailMethod()\MethodName + "()"
                IsFind = #True
                Break
              EndIf
            Next
            If Not Isfind
              AddElement(InternMethod())
              InternMethod() = "  Data.i @" + ListDetailMethod()\ClassName + "_" + ListDetailMethod()\MethodName + "()"
              ListDetailMethod()\Key = ""
            EndIf
          Else
            AddElement(InternMethod())
            InternMethod() = "  Data.i @" + ListDetailMethod()\ClassName + "_" + ListDetailMethod()\MethodName + "()"
          EndIf
        EndIf
      Next
     
      ; Vererbete Classen einbinden
      ForEach ExtMethod()
        AddElement(List())
        List() = ExtMethod()
      Next
     
      ; Eigene Classen einbinden
      ForEach InternMethod()
        AddElement(List())
        List() = InternMethod()
      Next
     
    ; Fusszeile
    AddElement(List())
    List() = "EndDataSection; I" + *Class\ClassName
       
EndProcedure

; ***************************************************************************************

Procedure Main()

  Protected count, max, interfacefile.s
 
  ; Quell-Datei und Include-Dateien laden
  If LoadFile() = 0
    ProcedureReturn 0
  EndIf
 
  ; Quell-Datei vor Include-Dateien setzen
  ResetList(AllLines())
  ForEach Lines()
    AddElement(AllLines())
    AllLines() = Lines()
  Next
 
  ; Classen suchen
  If FindAllClass(AllLines()) = 0
    ProcedureReturn 0
  EndIf
 
  ; Irgendwelche Klassen programmiert
  If ListSize(ListClass()) <= 0
    ProcedureReturn 0
  EndIf
 
  ; UIID suchen
  If FindUIID(AllLines()) = 0
    ProcedureReturn 0
  EndIf
 
  ; Methoden suchen
  If FindAllMethod(AllLines()) = 0
    ProcedureReturn 0
  EndIf
 
  SplitListMethod()
 
  max = ListSize(ListClass()) - 1
 
  ;- BottomFile
 
  ; Methoden einbinden
  AddElement(BottomLines())
  BottomLines() = "; --- OOP - Create Control Object and IUnknown "
  For count = 0 To max
    SelectElement(ListClass(), count)
    CreateUnknown(ListClass(), BottomLines())
  Next
  AddElement(BottomLines())
  BottomLines() = "; --- EndOOP - Create Control Object and IUnknown "
 
  ; DataSection einbinden
  AddElement(BottomLines())
  BottomLines() = "; --- OOP - Create DataSection "
  For count = 0 To max
    SelectElement(ListClass(), count)
    CreateDataSection(ListClass(), BottomLines())
  Next
  AddElement(BottomLines())
  BottomLines() = "; --- EndOOP - Create DataSection"
 
  ; UIID IUnknown erzeugen
  AddElement(BottomLines())
  BottomLines() = "; --- OOP - Create UIID IUnknown"
  CreateUIID(BottomLines())
  AddElement(BottomLines())
  BottomLines() = "; --- EndOOP - Create UIID IUnknown"
 
  ;- TopFile
  ; Konstanten erzeugen
  AddElement(TopLines())
  TopLines() = "; --- OOP - Create Includes"
  For count = 0 To max
    SelectElement(ListClass(), count)
    AddElement(TopLines())
    TopLines() = "#__Interface" + ListClass()\ClassName + " = " + #DQUOTE$ + pathname + "Interface" + ListClass()\ClassName + ".oop" + #DQUOTE$
  Next
  AddElement(TopLines())
  TopLines() = "; --- EndOOP - Create Includes"
 
  ; Macros erzeugen
  AddElement(TopLines())
  TopLines() = "; --- OOP - Create Macros"
  CreateMacros(TopLines())
  AddElement(TopLines())
  TopLines() = "; --- EndOOP - Create Macros"
 
  ; Declare Methoden Control Object
  max = ListSize(ListClass()) - 1
  AddElement(TopLines())
  TopLines() = "; --- OOP - Declare Control Object"
  ForEach DeclareClass()
    AddElement(TopLines())
    TopLines() = DeclareClass()
  Next
  AddElement(TopLines())
  TopLines() = "; --- EndOOP - Declare Control Object"
 
  ; Interface erzeugen
  For count = 0 To max
    ClearList(InterfaceLines())
    AddElement(InterfaceLines())
    InterfaceLines() = "; --- OOP - Create Interface"
      SelectElement(ListClass(), count)
      CreateInterface(ListClass(), InterfaceLines())
    AddElement(InterfaceLines())
    InterfaceLines() = "; --- EndOOP - Create Interface"
    ; Speicher InterfaceFile
    interfacefile = pathname + "Interface" + ListClass()\ClassName + ".oop"
    If CreateFile(#File, interfacefile)
      ForEach InterfaceLines()
        WriteStringN(#File, InterfaceLines())
      Next
      CloseFile(#File)
    EndIf
  Next
 
  ; Quell-Datei speichern
  SaveFile()
 
EndProcedure

; ***************************************************************************************

;-Main
Main()
End
; ***************************************************************************************

DataSection
  IUnknown:
  Data.s "Procedure __Manage<Class>(*this)"
  Data.s "  Static NewList __List_<Class>.<Class>()"
  Data.s "  If *this"
  Data.s "    ChangeCurrentElement(__List_<Class>(), *this)"
  Data.s "    DeleteElement(__List_<Class>())"
  Data.s "    ProcedureReturn 0"
  Data.s "  Else"
  Data.s "    If AddElement(__List_<Class>()) = 0"
  Data.s "      ProcedureReturn 0"
  Data.s "    Else"
  Data.s "      ProcedureReturn @__List_<Class>()"
  Data.s "    EndIf"
  Data.s "  EndIf"
  Data.s "EndProcedure"
  Data.s "; -----------------------------------------------------------------------------"
  Data.s "Procedure New<Class>(__parameters__)"
  Data.s "  Protected *this.<Class>, *self.I<Class>"
  Data.s "  *this = __Manage<Class>(0)"
  Data.s "  If *this = 0"
  Data.s "    ProcedureReturn 0"
  Data.s "  Else"
  Data.s "    With *this"
  Data.s "      \__VTable = ?__<Class>_Method"
  Data.s "      \__Ref = 1"
  Data.s "    EndWith"
  Data.s "    CompilerIf Defined(<Class>_InitObject, #PB_Procedure) = #True"
  Data.s "      *self = *this"
  Data.s "      *self\InitObject(__parameters__)"
  Data.s "    CompilerEndIf"
  Data.s "    ProcedureReturn *this"
  Data.s "  EndIf"
  Data.s "EndProcedure"
  Data.s "; -----------------------------------------------------------------------------"
  Data.s "CompilerIf Defined(<Class>_QueryInterface, #PB_Procedure) = #False"
  Data.s "  Procedure <Class>_QueryInterface(*this.<Class>, *UIID, *ppv.integer)"
  Data.s "    "
  Data.s "    If (*ppv = #Null)"
  Data.s "      ProcedureReturn #E_INVALIDARG;"
  Data.s "    EndIf"
  Data.s "    "
  Data.s "    *ppv\i = #Null;"
  Data.s "    "
  Data.s "    If CompareMemory(*UIID, ?__IID_IUnknown, 16)__UIID__"
  Data.s "      *ppv\i = *this"
  Data.s "    Else"
  Data.s "      ProcedureReturn #E_NOINTERFACE"
  Data.s "    EndIf"
  Data.s "    "
  Data.s "    *this\__Ref + 1"
  Data.s "    ProcedureReturn #NOERROR"
  Data.s "    "
  Data.s "  EndProcedure"
  Data.s "CompilerEndIf"
  Data.s "; -----------------------------------------------------------------------------"
  Data.s "CompilerIf Defined(<Class>_AddRef, #PB_Procedure) = #False"
  Data.s "  Procedure <Class>_AddRef(*this.<Class>)"
  Data.s "    *this\__Ref + 1"
  Data.s "    ProcedureReturn *this\__Ref"
  Data.s "  EndProcedure"
  Data.s "CompilerEndIf"
  Data.s "; -----------------------------------------------------------------------------"
  Data.s "CompilerIf Defined(<Class>_Release, #PB_Procedure) = #False"
  Data.s "  Procedure <Class>_Release(*this.<Class>)"
  Data.s "    Protected *self.I<Class>"
  Data.s "    If *this = 0"
  Data.s "      ProcedureReturn 0"
  Data.s "    ElseIf *this\__Ref = 0"
  Data.s "      ProcedureReturn 0"
  Data.s "    ElseIf *this\__Ref = 1"
  Data.s "      CompilerIf Defined(<Class>_DestroyObject, #PB_Procedure) = #True"
  Data.s "        *self = *this"
  Data.s "        *self\DestroyObject()"
  Data.s "      CompilerEndIf"
  Data.s "      *this\__Ref = 0"
  Data.s "      __Manage<Class>(*this)"
  Data.s "      ProcedureReturn 0"
  Data.s "    Else"
  Data.s "      *this\__Ref - 1"
  Data.s "      ProcedureReturn *this\__Ref"
  Data.s "    EndIf"
  Data.s "  EndProcedure"
  Data.s "CompilerEndIf"
  Data.s "; -----------------------------------------------------------------------------"
  Data.s "EEEE"
  Macros:
  Data.s "Define *this"
  Data.s ""
  Data.s "Structure __BaseClass"
  Data.s "  *__VTable.void"
  Data.s "  __Ref.l"
  Data.s "EndStructure"
  Data.s ""
  Data.s "Macro Class(Name, Exts=__BaseClass)"
  Data.s "  IncludeFile #__Interface#Name"
  Data.s "  Structure Name Extends Exts"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro EndClass"
  Data.s "  EndStructure"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro Method"
  Data.s "  Procedure"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro MethodReturn"
  Data.s "  ProcedureReturn"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro EndMethod"
  Data.s "  EndProcedure"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro Overwrite"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro NewObject(Name)"
  Data.s "    New#Name()"
  Data.s "EndMacro"
  Data.s ""
  Data.s "Macro DeleteObject(object)"
  Data.s "  object#\Release()"
  Data.s "EndMacro"
  Data.s ""
 
  CompilerIf #PB_Compiler_OS <> #PB_OS_Windows
    Data.s "; Constance"
    Data.s "#E_INVALIDARG = $80070057"
    Data.s "#E_NOINTERFACE = $80004002"
    Data.s "#NOERROR = $0"
    Data.s "; Interfaces"
    Data.s "Interface IUnknown"
    Data.s "  QueryInterface(a, b)"
    Data.s "  AddRef()"
    Data.s "  Release()"
    Data.s "EndInterface"
    Data.s "; ----------"
  CompilerEndIf
 
  Data.s "EEEE"
  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}'
  Data.s "DataSection"
  Data.s "  __IID_IUnknown : ; {00000000-0000-0000-C000-000000000046}'"
  Data.s "  Data.l $00000000"
  Data.s "  Data.w $0000, $0000"
  Data.s "  Data.b $C0, $00, $00 , $00 , $00, $00 , $00 , $46"
  Data.s "EndDataSection"
  Data.s "EEEE"
EndDataSection

; ***************************************************************************************