Lexer für PB 4

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
Benutzeravatar
edel
Beiträge: 3667
Registriert: 28.07.2005 12:39
Computerausstattung: GameBoy
Kontaktdaten:

Beitrag von edel »

Letzteres duerfte richtig sein, da es sich nicht um eine Konstante handelt,
und das # Zeichen nur zum trennen da ist.
Benutzeravatar
remi_meier
Beiträge: 1078
Registriert: 29.08.2004 20:11
Wohnort: Schweiz

Beitrag von remi_meier »

inc. hat geschrieben:Bug Report:
in der Prozedur "_PBSC_GetIdentifier" , welche die Konstanten & Pointer erkennt fehlen die Identifier "width", "includefile" und "xincludefile".
Stimmt. Sollte nun stimmen.
inc. hat geschrieben: Fehler bei folgendem Code:

Code: Alles auswählen

Macro __VERTEXFLAGS(__Texnum) 
  If(VertexBufferType & #GRAPH_VB_TEXTURE_COORDINATES_#__Texnum) 
    VertexSize + 8 ;2*FLOAT 
  EndIf 
EndMacro
Hier wird

"#GRAPH_VB_TEXTURE_COORDINATES_#__Texnum"

in ...

"#GRAPH_VB_TEXTURE_COORDINATES_"
"#"
"__Texnum"

aufgeteilt.
Wie edel schrieb, ist das gewollt. Ich hoffe nur, es wird überall in den Makros
korrekt behandelt. Hat mir ziemlich Kopfschmerzen bereitet.
Benutzeravatar
inc.
Beiträge: 348
Registriert: 27.10.2004 12:25

Beitrag von inc. »

Remi, ich habe einen Code aus dem PureArea.net forum genannt bekommen, der einen Fehler verursacht. Sodann habe ich die Tokens dieses Codes einzeln debuggen lassen und den Fehler gefunden:

Code: Alles auswählen

If TEvent >= $80 And TEvent <= $8F 
wird wie folgt aufgeteilt:

Code: Alles auswählen

150 : If
150 : TEvent
150 : >=
150 : $80 A
150 : nd
150 : TEvent
150 : <=
150 : $8F
Das "And" nach dem Hex Wert ist hier gespalten worden.

Der Code ist wie gesagt im PureArea.net zu finden unter "Music&Movie" und heisst "MidiFileDecoder.pb"


EDIT:
Habe das vorab wie folgt gefixt:

Code: Alles auswählen

If Hex
  Select Asc(Mid(s, z, 1))
    Case '0' To '9', 'a' To 'f', 'A' To 'F'
      ToLen + 1
      Digit = #True
->

Code: Alles auswählen

If Hex
  Select Asc(Mid(s, z, 1))
    Case '0' To '9', 'a' To 'f', 'A' To 'F'
      If Not LCase(Mid(s, z, 3)) = "and"
        ToLen + 1
        Digit = #True
      EndIf
Hier gibts die OOP Option für PureBasic.
Benutzeravatar
edel
Beiträge: 3667
Registriert: 28.07.2005 12:39
Computerausstattung: GameBoy
Kontaktdaten:

Beitrag von edel »

Ich vermute mal dass das

Code: Alles auswählen

        Case ' ', 9
          ToLen + 1
zuviel ist.
Benutzeravatar
inc.
Beiträge: 348
Registriert: 27.10.2004 12:25

Beitrag von inc. »

Ja, du hast recht, aber ich war mir nicht so sicher, daher habe ich vorerst eine Abfrage hinzugefügt als etwas zu löschen.
Hier gibts die OOP Option für PureBasic.
Benutzeravatar
remi_meier
Beiträge: 1078
Registriert: 29.08.2004 20:11
Wohnort: Schweiz

Beitrag von remi_meier »

Beide nicht ganz richtig: ist erlaubt, daher Space und Tab.

Ist in einer Minute im ersten Post korrigiert.

Danke für die guten Bug-Reports!

greetz
Remi :)
Benutzeravatar
edel
Beiträge: 3667
Registriert: 28.07.2005 12:39
Computerausstattung: GameBoy
Kontaktdaten:

Beitrag von edel »

Da sieht man doch mal wieder wie durchdacht diese Syntax ist :freak:

Danke dir remi
Benutzeravatar
remi_meier
Beiträge: 1078
Registriert: 29.08.2004 20:11
Wohnort: Schweiz

Beitrag von remi_meier »

Thx, war wohl nur ein kleiner Bug in der Assertion. Hab's ausgebessert
(siehe erster Post).
Benutzeravatar
edel
Beiträge: 3667
Registriert: 28.07.2005 12:39
Computerausstattung: GameBoy
Kontaktdaten:

Beitrag von edel »

Die Antwort steht hier schon, blaetter mal etwas zurueck.
Benutzeravatar
remi_meier
Beiträge: 1078
Registriert: 29.08.2004 20:11
Wohnort: Schweiz

Beitrag von remi_meier »

Ah sorry, hab die Frage nicht mehr gesehen :roll:
Ja, ich weis, ich hab es genau wie auf Seite 3 geändert, allerdings entstehen dadurch wieder Fehler, "%8" wird dann z.B. als ein Token erkannt.
Stimmt. Es tut mir leid, aber dieses Problem ist nicht einfach zu lösen.
An einigen Stellen muss ich überprüfen, welchen Typ das letzte Token
hatte (z. B. eben um zu sehen, ob % für eine Binäre Zahl oder als
Operator steht). Ich habe den Code nun aber so modifiziert, dass
die letzten Tokens nicht mehr geändert werden, falls nur ein Whitespace
kommt. Diese Änderung ist aber völlig ungetestet. Ich würde das
Problem versuchen anders zu lösen. Der Lexer sollte einem die Behandlung
von Whitespaces ja eigentlich abnehmen <)

Also hier mit Vorsicht zu geniessen:

Code: Alles auswählen

;- Design by Contract Macros 
#CONTRACTS = #True 


Macro require 
EndMacro 

Macro body 
EndMacro 

Macro ensure 
EndMacro 

Macro returns 
  ProcedureReturn 
EndMacro 

Macro DQ 
" 
EndMacro 

Macro assert(cond, label="") 
  CompilerIf #CONTRACTS 
    If Not(cond) 
      CompilerIf #PB_Compiler_Debugger 
        Debug label+": Line "+Str(#PB_Compiler_Line)+": Contract violated: "+#DQUOTE$+DQ#cond#DQ+#DQUOTE$+" is false" 
        CallDebugger 
      CompilerElse 
        MessageRequester("Contract violated", label+": Line "+Str(#PB_Compiler_Line)+": Contract violated "+DQ#cond#DQ+" is false") 
      CompilerEndIf 
    EndIf 
  CompilerEndIf 
EndMacro 

Macro implies(a, b) 
  ((Not (a)) Or (b)) 
EndMacro 

EnableExplicit 



Enumeration 0 
  #PBSC_Other  ; Operators, other symbols 
  #PBSC_Identifier ; all variables, structures, pseudotypes, functions, pointer, constants... 
  #PBSC_Number ; 'numb', 466, $ FFFF, %10001, 1.0e-4, etc. 
  #PBSC_String ; "this is a String!" 
  #PBSC_Comment ; the whole rest of the line starting with a ';' 
  #PBSC_NewLine ; a new line begins, Token = #LF$ 
  #PBSC_TypeEnumerationEnd 
EndEnumeration 

Interface iPBSC 
  SetFile.l(FileName.s) 
  SetFileString(FileAsString.s) 
  SetFileLine(Line.l) 
  IsNextToken.l() 
  GetNextToken.s() 
  GetCurrentLineNb.l() 
  GetCurrentType.l() 
  CloseFile() 
EndInterface 

Structure cPBSC 
  *VTable 
  
  File.s 
  FileLine.l 
  FileMaxLine.l 
  
  Line.s 
  Started.l 
  
  CurrentType.l 
  
  LastToken.s 
  LastTokenType.l 
  PreLastToken.s 
  PreLastTokenType.l 
  PrePreLastToken.s 
  PrePreLastTokenType.l 
EndStructure 


Procedure _PBSC_SetLastToken(*this.cPBSC, s.s, updateLast = #True) 
  require 
    assert(*this <> 0 And Len(s) <> 0) 
  body 
    ;Static PreLastToken.s = #LF$ 
    If updateLast
      If *this\PreLastToken = "" : *this\PreLastToken = #LF$ : EndIf 
      *this\PrePreLastToken = *this\PreLastToken 
      *this\PreLastToken = *this\LastToken 
    EndIf
    *this\LastToken = s 
  ensure 
    assert(*this\LastToken = s) 
  returns 
EndProcedure 

Procedure _PBSC_SetTokenType(*this.cPBSC, Type.l, updateLast = #True) 
  require 
    assert(Type >= -1 And Type < #PBSC_TypeEnumerationEnd) 
    assert(*this <> 0) 
  body 
    If Type = -1 
      *this\PrePreLastTokenType = #PBSC_Other 
      *this\PreLastTokenType = #PBSC_Other 
      *this\LastTokenType = #PBSC_Other 
      *this\CurrentType = #PBSC_Other 
    Else 
      If updateLast
        *this\PrePreLastTokenType = *this\PreLastTokenType 
        *this\PreLastTokenType = *this\CurrentType 
        *this\LastTokenType = Type
      EndIf 
      *this\CurrentType = Type 
    EndIf 
  ensure 
    
  returns 
EndProcedure 

Procedure.l PBSC_SetFile(*this.cPBSC, FileName.s) 
  require 
    assert(*this <> 0) 
    assert(Len(FileName) <> 0 And FileSize(FileName) <> -1 And FileSize(FileName) <> -2) 
  body 
    Protected FileID.l, Format.l, Result.l = #False 
    
    FileID = ReadFile(#PB_Any, FileName) 
    If IsFile(FileID) 
      *this\FileLine = 1 
      _PBSC_SetLastToken(*this, #LF$) 
      _PBSC_SetTokenType(*this, -1) 
      *this\Line = "" 
      *this\Started = #True 
      
      Format = ReadStringFormat(FileID) 
      Select Format 
        Case #PB_Ascii, #PB_UTF8, #PB_Unicode 
          
          *this\FileMaxLine = 0 
          While Not Eof(FileID) 
            *this\FileMaxLine + 1 
            *this\File + ReadString(FileID, Format) + #LF$ 
          Wend 
          
          CloseFile(FileID) 
          Result = #True 
          
        Default 
          CloseFile(FileID) 
          Result = #False 
      EndSelect 
    EndIf 
  ensure 
    assert(Result = #False Or Result = #True) 
  returns Result 
EndProcedure 

Procedure PBSC_SetFileString(*this.cPBSC, FileAsString.s) ; lines separated with #LF$! 
  require 
    assert(*this <> 0) 
    assert(Len(FileAsString) <> 0) 
  body 
    *this\File     = FileAsString 
    *this\FileLine = 1 
    _PBSC_SetLastToken(*this, #LF$) 
    _PBSC_SetTokenType(*this, -1) 
    *this\Line     = "" 
    *this\Started  = #True 
    *this\FileMaxLine = CountString(*this\File, #LF$) + 1 
  ensure 
    assert(*this\FileMaxLine >= *this\FileLine) 
  returns 
EndProcedure 

Procedure PBSC_SetFileLine(*this.cPBSC, Line.l) 
  require 
    assert(*this <> 0) 
    assert(Line <= *this\FileMaxLine + 1) ; +1 because a loop could use this feature 
                                          ; to iterate through all the lines 
                                          ; but more than +1 should be a bug 
  body 
    *this\FileLine = Line 
    *this\Line     = "" 
    *this\Started  = #True 
    _PBSC_SetLastToken(*this, #LF$) 
    _PBSC_SetTokenType(*this, -1) 
  ensure 
  
  returns 
EndProcedure 

Procedure.l PBSC_IsNextToken(*this.cPBSC) 
  require 
    assert(*this <> 0) 
    assert(*this\File, "no file loaded") 
  body 
    Protected Result.l 
    If *this\File And (*this\FileLine <= *this\FileMaxLine Or Len(*this\Line) <> 0) 
      Result = #True 
    Else 
      Result = #False 
    EndIf 
  ensure 
    assert(Result = #True Or Result = #False) 
  returns Result 
EndProcedure 

Procedure.s _PBSC_ReadLine(*this.cPBSC) 
  require 
    assert(*this <> 0) 
    assert(*this\File, "no file loaded") 
  body 
    Protected Result.s 
    
    If *this\File 
      *this\FileLine + 1 
      Result = StringField(*this\File, *this\FileLine - 1, #LF$) 
    Else 
      Result = "" 
    EndIf 
  ensure 
  returns Result 
EndProcedure 

Procedure.s _PBSC_Trim(*this.cPBSC, s.s) 
  require 
    assert(*this <> 0) 
  body 
    Protected *p.CHARACTER, *n.CHARACTER, Result.s 
    
    *p = @s 
    While (*p\c = ' ' Or *p\c = #TAB) And *p\c 
      *p + SizeOf(CHARACTER) 
    Wend 
    ; *p zeigt auf Start des Textes 
    
    ; suche Ende 
    *n = *p 
    While *n\c <> 0 
      *n + SizeOf(CHARACTER) 
    Wend 
    
    *n - SizeOf(CHARACTER) 
    While (*n\c = ' ' Or *n\c = #TAB) And *n > *p 
      *n - SizeOf(CHARACTER) 
    Wend 
    
    Result = PeekS(*p, (*n + SizeOf(CHARACTER) - *p)/SizeOf(CHARACTER)) 
  ensure 
    assert(PeekC(@Result) <> ' ' And PeekC(@Result) <> #TAB, "l-trimming failed") 
    assert(PeekC(@Result + (Len(Result) - 1)*SizeOf(CHARACTER)) <> ' ' And PeekC(@Result + (Len(Result) - 1)*SizeOf(CHARACTER)) <> #TAB, "r-trimming failed") 
  returns Result 
EndProcedure 

Procedure.l _PBSC_GetIdentifier(*this.cPBSC, s.s) 
  require 
    assert(*this <> 0) 
    assert(Len(s) <> 0) 
  body 
    Protected z.l, Len.l, ToLen.l = 0, Const.l = 0, PseudoType.l = 0, Temp.s 
    Protected LastToken.s, notptr.l 
    
    If *this\LastToken = "." And (PeekC(@s) = 'p' Or PeekC(@s) = 'P') And PeekC(@s+SizeOf(CHARACTER)) = '-' 
      PseudoType = 1 
      ToLen = 2 
    EndIf 
    
    If PseudoType = 0 
      If PeekC(@s) = '#' 
        If *this\LastTokenType = #PBSC_Identifier Or *this\LastTokenType = #PBSC_Other 
          Temp = LCase(*this\LastToken) 
          Select Temp 
            Case "to", "procedurereturn", "select", "case", "if", "elseif", "compilerselect" 
              Const = 1 : ToLen = 1 
            Case "compilercase", "compilerif", "compilerelseif", "break", "while", "until", "with" 
              Const = 1 : ToLen = 1 
            Case "debug", "end", "and", "or", "xor", "not", "#", "includefile", "xincludefile", "includepath", "includebinary" 
              Const = 1 : ToLen = 1 
            Case ",","/","+","-","%","!","~","|","&","<<",">>","<",">","<=",">=","=","<>","(","[","{",":" 
              Const = 1 : ToLen = 1 
            Case "*" 
              If *this\LastTokenType = #PBSC_Identifier 
                ProcedureReturn 0 
              Else 
                Const = 1 : ToLen = 1 
              EndIf 
            Default 
              ProcedureReturn 0 
          EndSelect 
        ElseIf *this\LastTokenType = #PBSC_NewLine 
          Const = 1 : ToLen = 1 
        Else 
          ProcedureReturn 0 
        EndIf 
        
      ElseIf PeekC(@s) = '*' 
        notptr = #True 
        If *this\LastTokenType = #PBSC_Identifier Or *this\LastTokenType = #PBSC_Other 
          Temp = LCase(*this\LastToken) 
          Select Temp 
            Case "to", "procedurereturn", "select", "case", "if", "elseif", "compilerselect" 
              notptr = #False 
            Case "while", "until", "protected", "define", "global", "shared", "static", "with" 
              notptr = #False 
            Case "debug", "end", "and", "or", "xor", "not", "#" 
              notptr = #False 
            Case ",","/","+","-","%","!","~","|","&","<<",">>","<",">","<=",">=","=","<>","@","(","[","{",":" 
              notptr = #False 
            Case "*" 
              If *this\LastTokenType = #PBSC_Identifier 
                notptr = #True 
              Else 
                notptr = #False 
              EndIf 
            Default 
              notptr = #True 
          EndSelect 
        ElseIf *this\LastTokenType = #PBSC_NewLine 
          notptr = #False 
        EndIf 
        If notptr And *this\PrePreLastTokenType = #PBSC_Identifier 
          Temp = LCase(LastToken) 
          Select Temp 
            Case "protected", "define", "global", "shared", "static" 
              notptr = #False 
          EndSelect 
        EndIf 
        
        If notptr = #False 
          Const = 1 : ToLen = 1 
        EndIf 
        
        If Const <> 1 
          ProcedureReturn 0 
        EndIf 
      EndIf 
      
      If Const 
        z = 1 
        While (PeekC(@s+z*SizeOf(CHARACTER)) = ' ' Or PeekC(@s+z*SizeOf(CHARACTER)) = 9) 
          Const + 1 
          z + 1 
          ToLen + 1 
        Wend 
      EndIf 
      
      Select PeekC(@s + Const*SizeOf(CHARACTER)) 
        Case '_', 'a' To 'z', 'A' To 'Z' 
          ToLen + 1 
        Default 
          ProcedureReturn 0 
      EndSelect 
    EndIf 
    
    Len = Len(s) 
    For z = 2+Const+PseudoType To Len 
      Select Asc(Mid(s, z, 1)) 
        Case '_', 'a' To 'z', 'A' To 'Z', '0' To '9', '$' 
          ToLen + 1 
        Default 
          _PBSC_SetTokenType(*this, #PBSC_Identifier) 
          ProcedureReturn ToLen 
      EndSelect 
    Next 
    
    _PBSC_SetTokenType(*this, #PBSC_Identifier) 
    ProcedureReturn ToLen 
;   ensure 
;   returns 
EndProcedure 

Procedure.l _PBSC_GetString(*this.cPBSC, s.s) 
  require 
    assert(*this <> 0) 
    assert(Len(s) <> 0) 
  body 
    Protected z.l, Len.l, ToLen.l = 0, SearchString.l 
    
    
    If PeekC(@s) = '"' 
      SearchString = #True 
      ToLen = 1 
    ElseIf PeekC(@s) = Asc("'") 
      SearchString = #False 
      ToLen = 1 
    Else 
      ProcedureReturn 0 
    EndIf 
    
    Len = Len(s) 
    For z = 2 To Len 
      If SearchString 
        Select Asc(Mid(s, z, 1)) 
          Case '"' 
            _PBSC_SetTokenType(*this, #PBSC_String) 
            ProcedureReturn ToLen + 1 
          Default 
            ToLen + 1 
        EndSelect 
      Else 
        Select Asc(Mid(s, z, 1)) 
          Case Asc("'") 
            _PBSC_SetTokenType(*this, #PBSC_Number) 
            ProcedureReturn ToLen + 1 
          Default 
            ToLen + 1 
        EndSelect 
      EndIf 
    Next 
    
    _PBSC_SetTokenType(*this, #PBSC_String) 
    ProcedureReturn ToLen 
;   ensure 
;   returns 
EndProcedure 

Procedure.l _PBSC_GetNumber(*this.cPBSC, s.s) 
  require 
    assert(*this) 
    assert(Len(s) <> 0) 
  body 
    Protected z.l, Len.l, ToLen.l = 0, Digit.l = #False, Hex.l = #False, Spec.l = 0 
    Protected lastChar.c 
    
    If PeekC(@s) = ' ' Or PeekC(@s) = 9 
      ProcedureReturn 0 
    EndIf
    
    If PeekC(@s) = '$' 
      Hex = #True 
      ToLen = 1 
      Spec = 1 
    ElseIf PeekC(@s) = '%' 
      If *this\LastTokenType = #PBSC_Identifier Or *this\LastTokenType = #PBSC_Number 
        ProcedureReturn 0 
      ElseIf *this\LastToken = ")" Or *this\LastToken = "]" 
        ProcedureReturn 0 
      EndIf 
      ToLen = 1 
      Spec = 1 
    EndIf 
    
    Len = Len(s) 
    For z = (1+Spec) To Len 
      If Hex 
        Select Asc(Mid(s, z, 1)) 
          Case '0' To '9', 'a' To 'f', 'A' To 'F' 
            ToLen + 1 
            Digit = #True 
          Case ' ', 9 
            If _PBSC_Trim(*this, Left(s, z-1)) = "$" 
              ToLen + 1 
            Else 
              _PBSC_SetTokenType(*this, #PBSC_Number) 
              ProcedureReturn ToLen 
            EndIf 
          Default 
            If Digit 
              _PBSC_SetTokenType(*this, #PBSC_Number) 
              ProcedureReturn ToLen 
            Else 
              ProcedureReturn 0 
            EndIf 
        EndSelect 
      Else 
        Select Asc(Mid(s, z, 1)) 
          Case '0' To '9', '.', 'e', 'E' 
            If Digit = #False And (Asc(Mid(s, z, 1)) = '.' Or Asc(LCase(Mid(s, z, 1))) = 'e') 
              ProcedureReturn 0 
            EndIf 
            If LCase(Mid(s, z, 1)) = "e" 
              Select Asc(Mid(s, z-1, 1)) 
                Case '0' To '9', '.' 
                Default 
                  _PBSC_SetTokenType(*this, #PBSC_Number) 
                  ProcedureReturn ToLen 
              EndSelect 
            EndIf 
            lastChar = Asc(Mid(s, z, 1)) 
            ToLen + 1 
            Digit = #True 
          Case '+', '-' 
            If Digit 
              If lastChar = 'e' Or lastChar = 'E' 
                ToLen + 1 
              Else 
                _PBSC_SetTokenType(*this, #PBSC_Number) 
                ProcedureReturn ToLen 
              EndIf 
            Else 
              ProcedureReturn 0 
            EndIf 
          Case ' ', 9 
            If _PBSC_Trim(*this, Left(s, z-1)) = "%" 
              ToLen + 1 
            Else 
              _PBSC_SetTokenType(*this, #PBSC_Number) 
              ProcedureReturn ToLen 
            EndIf 
          Default 
            If Digit 
              _PBSC_SetTokenType(*this, #PBSC_Number) 
              ProcedureReturn ToLen 
            Else 
              ProcedureReturn 0 
            EndIf 
        EndSelect 
      EndIf 
    Next 
    
    _PBSC_SetTokenType(*this, #PBSC_Number) 
    ProcedureReturn ToLen 
  ;ensure 
  ;returns 
EndProcedure 

Procedure.l _PBSC_GetDOperator(*this.cPBSC, s.s) 
  require 
    assert(*this <> 0) 
    assert(Len(s) <> 0) 
  body 
    Protected Result.l = -1 
    
    Select PeekC(@s) 
      Case '<', '>' 
        Select PeekC(@s+SizeOf(CHARACTER)) 
          Case '>', '<', '=' 
            _PBSC_SetTokenType(*this, #PBSC_Other) 
            Result = 2 
        EndSelect 
    EndSelect 
    
    If Result <> 2 
      Result = 0 
    EndIf 
  ensure 
    assert(Result = 2 Or Result = 0) 
  returns Result 
EndProcedure 

Procedure.l _PBSC_FindToken(*this.cPBSC, s.s) 
  require 
    assert(*this <> 0) 
    assert(Len(s) <> 0) 
  body 
    ; ok: Kommentare als Ganzes 
    ; ok: Strings als Ganzes (auch mit ' umklammerte) 
    ; ok: Bezeichner als Ganzes (auch #KONST, String$, *Ptr) 
    ; ok: Pseudotypen als Ganzes 
    ; ok: Zahlen: 2001, $5461, %454 
    ; ok: Doppeloperatoren 
    Static RetVal.l = 0 
    
    If PeekC(@s) = ';' 
      _PBSC_SetLastToken(*this, s) 
      _PBSC_SetTokenType(*this, #PBSC_Comment) 
      RetVal = Len(s) 
    Else 
      RetVal = _PBSC_GetIdentifier(*this, s) 
      If RetVal 
        _PBSC_SetLastToken(*this, Left(s, RetVal)) 
      Else 
         RetVal = _PBSC_GetString(*this, s) 
        If RetVal 
          _PBSC_SetLastToken(*this, Left(s, RetVal)) 
        Else 
          RetVal = _PBSC_GetNumber(*this, s) 
          If RetVal 
            _PBSC_SetLastToken(*this, Left(s, RetVal)) 
          Else 
            RetVal = _PBSC_GetDOperator(*this, s) 
            If RetVal 
              _PBSC_SetLastToken(*this, Left(s, RetVal)) 
            Else 
              If Mid(s,1,1) = " " Or Mid(s,1,1) = #TAB$
                _PBSC_SetLastToken(*this, Mid(s, 1, 1), #False) 
                _PBSC_SetTokenType(*this, #PBSC_Other, #False)
              Else
                _PBSC_SetLastToken(*this, Mid(s, 1, 1)) 
                _PBSC_SetTokenType(*this, #PBSC_Other) 
              EndIf
              RetVal = 1 
            EndIf 
          EndIf 
        EndIf 
      EndIf 
    EndIf 
  ensure 
    assert(RetVal > 0) 
  returns RetVal 
EndProcedure 

Procedure.s PBSC_GetNextToken(*this.cPBSC) 
  require 
    assert(*this <> 0) 
    assert(*this\FileLine <= *this\FileMaxLine + 1, "searching outside of file") 
  body 
    Protected s0.s, Token.s, Len.l, Result.s 
    
    ; Line is trimmed or empty (if set by string and not by file)! 
    If *this\File And (*this\FileLine <= *this\FileMaxLine Or Len(*this\Line) <> 0) 
      
      If *this\Line = "" 
        _PBSC_SetTokenType(*this, #PBSC_NewLine) 
        _PBSC_SetLastToken(*this, #LF$) 
        
        s0 = _PBSC_ReadLine(*this) 
        *this\Line = s0;_PBSC_Trim(*this, s0) 
        
        If ( Not *this\Started) Or (*this\Started And *this\Line = "") 
          Result = #LF$ 
        Else 
          *this\Started = #False 
        EndIf 
      EndIf 
      
      If Result <> #LF$ 
        Len = _PBSC_FindToken(*this.cPBSC, *this\Line) 
        Token = Left(*this\Line, Len) 
        
        *this\Line = Mid(*this\Line, FindString(*this\Line, Token, 1)+Len(Token), Len(*this\Line)-Len(Token))
        
        Result = Token ;_PBSC_Trim(*this, Token) 
      EndIf 
    Else 
      Result = "" 
    EndIf 
  ensure 
  returns Result 
EndProcedure 

Procedure.l PBSC_GetCurrentLineNb(*this.cPBSC) 
  require 
    assert(*this <> 0) 
    assert(*this\FileMaxLine > 0, "no string loaded") 
  body 
    Protected Result.l 
    
    If *this\Started = #False And *this\LastToken = #LF$ 
      Result = *this\FileLine - 2 
    Else 
      Result = *this\FileLine - 1 
    EndIf 
  ensure 
    assert(Result > 0 And Result <= *this\FileMaxLine) 
  returns Result 
EndProcedure 

Procedure.l PBSC_GetCurrentType(*this.cPBSC) 
  require 
    assert(*this <> 0) 
  body 
    Protected Result.l 
    Result = *this\CurrentType 
  ensure 
    assert(Result >= 0 And Result < #PBSC_TypeEnumerationEnd) 
  returns Result 
EndProcedure 

Procedure PBSC_CloseFile(*this.cPBSC) 
  require 
    assert(*this <> 0) 
    assert(Len(*this\File) <> 0) 
  body 
    *this\File = "" 
EndProcedure 

DataSection 
cPBSC_VT: 
Data.l @PBSC_SetFile(), @PBSC_SetFileString(), @PBSC_SetFileLine(), @PBSC_IsNextToken(), @PBSC_GetNextToken() 
Data.l @PBSC_GetCurrentLineNb(), @PBSC_GetCurrentType(), @PBSC_CloseFile() 
EndDataSection 

Procedure.l New_PBSC() 
  require 
  body 
    Protected *obj.cPBSC 
    
    *obj = AllocateMemory(SizeOf(cPBSC)) 
    If *obj    
      *obj\VTable = ?cPBSC_VT 
    EndIf 
  ensure 
    assert(*obj <> 0, "couldn't create object") 
  returns *obj 
EndProcedure
Antworten