; German forum: http://www.purebasic.fr/german/viewtopic.php?t==1408&start=10
; Author: LittleFurz (updated for PB 4.00 by Andre)
; Date: 15. January 2005
; OS: Windows
; Demo: No


; need VirtualBin userlib ? ****

Structure sToken 
    tokBefehl.s 
    
    tokData1.s 
    tokType1.l 
    
    tokData2.s 
    tokType2.l 
EndStructure 

Structure sPointer 
    potName.s 
    potZeile.l 
EndStructure 

Structure AllTypes 
    StructureUnion 
        b.b 
        w.w 
        l.l 
        f.f 
        s.s 
    EndStructureUnion 
EndStructure 

Enumeration 
    #TYPString 
    #TYPLong 
    #TYPMemory 
    #TYPPointer 
EndEnumeration 


;IncludeFile "EasyCompiler.pb.declare" 
Declare cMain()
Declare WriteStructure(FileID, *Var.AllTypes, *Struc.BYTE) 
Declare LoadFile(strDateiname.s)
Declare CPrint(pText.s, Head.b) 
Declare.b isNumeric(strZahl.s) 


Global DateiOuthWnd1.l ; Code 
Global DateiOuthWnd2.l ; Pointer 

Global NewList SourceCode.sToken() 
Global NewList StdPointer.sPointer() 
Global NewList Includes.s() 

cMain() 
End 

;- HauptProgramm 
Procedure cMain() 
    Define.s DateiName 
    
    OpenConsole() 
    
    DateiName     = ReplaceString(ProgramParameter(), Chr(34), "") 
    DateiOuthWnd1 = CreateFile(#PB_Any, "Code.OBJ") 
    DateiOuthWnd2 = CreateFile(#PB_Any, "Ptr.OBJ")    
    
    CPrint("****************************************************" + #STX$, #False) 
    CPrint("Easy Compiler V.: 0.2                               " + #STX$, #False) 
    CPrint("****************************************************" + #STX$, #False) 
    CPrint(#STX$, #False) 
    
    SetCurrentDirectory_(GetPathPart(DateiName)) 
    If FileSize(DateiName) > 0 
        LoadFile(DateiName)    
        CPrint("Verarbeitete Zeilen Code: ", #True) 
        CPrint(Str(ListIndex(StdPointer()) + ListIndex(SourceCode()) + 2) + #STX$, #False) 
        
        CPrint("Starte Compileren..." + #STX$, #True) 
        ForEach SourceCode(): WriteStructure(DateiOuthWnd1, SourceCode(), @"sslsl"): Next 
        ForEach StdPointer(): WriteStructure(DateiOuthWnd2, StdPointer(), @"sl") : Next 
        
        CloseFile(DateiOuthWnd1) 
        CloseFile(DateiOuthWnd2) 
        
        CPrint("Fuehre Dateien zusammen..." + #STX$, #True) 
        DateiName = Left(DateiName, FindString(DateiName, ".", 1)-1) + ".ezb" 
        DeleteFile(DateiName) 
        VBinAdd(DateiName, "Code.OBJ", "", 9) 
        VBinAdd(DateiName, "Ptr.OBJ" , "", 9) 
        ForEach Includes()
          VBinAdd(DateiName, Includes(), "", 9)
        Next 
        
        CPrint("Programm erfolgreich compiliert !" + #STX$, #True) 
    Else 
        If DateiName = "" 
            CPrint("Bitte geben Sie eine Datei an !" + #STX$, #True) 
        Else 
            If FileSize(DateiName) = -1 
                CPrint("^CFehler^7: Die Datei wurde nicht gefunden !" + #STX$, #True) 
            ElseIf FileSize(DateiName) = -2 
                CPrint("^CFehler^7: Die Datei ist ein Verzeichniss !" + #STX$, #True) 
            EndIf            
        EndIf 
    EndIf 
EndProcedure 

;- Sonstige Funktionen 
Procedure WriteStructure(FileID, *Var.AllTypes, *Struc.BYTE) 
    Define.l lngLength 
    
    While *Struc\b 
        Select *Struc\b 
            Case 'b': WriteData(FileID, *Var, 1) : *Var + 1 
            Case 'w': WriteData(FileID, *Var, 2) : *Var + 2 
            Case 'l': WriteData(FileID, *Var, 4) : *Var + 4 
            Case 'f': WriteData(FileID, *Var, 4) : *Var + 4 
            Case 's' 
                Length = Len(*Var\s) 
                WriteData(FileID, @Length,  4) 
                If Length 
                    WriteData(FileID, *Var\l, Length) 
                EndIf 
                *Var + 4 
        EndSelect 
        *Struc + 1 
    Wend 
EndProcedure 

Procedure LoadFile(strDateiname.s) 
    Define.l FilehWnd 
    Define.s tmpZeile 
    
    If FileSize(strDateiname) > 0 
        CPrint("Verarbeite Datei ^8" + GetFilePart(strDateiname) + "^7..." + #STX$, #True) 
        FilehWnd = ReadFile(#PB_Any, strDateiname) 
        While Eof(FilehWnd) = #False 
            tmpZeile = ReplaceString(LTrim(ReadString(FilehWnd)), Chr(9),"") 
            
            Select Left(tmpZeile, 1) 
                Case ";" 
                Case "%" ; Include Binärdatei 
                    AddElement(Includes()) 
                    Includes() = Mid(tmpZeile, 2, Len(tmpZeile)) 
                Case "$" ; Include Datei 
                    LoadFile(Mid(tmpZeile, 2, Len(tmpZeile))) 
                Case "." ; Pointer 
                    If ListIndex(SourceCode()) <> -1 
                        AddElement(StdPointer()) 
                        StdPointer()\potName  = Mid(tmpZeile, 2, Len(tmpZeile)) 
                        StdPointer()\potZeile = ListIndex(SourceCode()) 
                        Debug "Jumpmark " + StdPointer()\potName + " at " + Str(StdPointer()\potZeile)                        
                    EndIf 
                Default 
                    If tmpZeile <> "" 
                        AddElement(SourceCode()) 
                        SourceCode()\tokBefehl =  LCase(Trim(StringField(tmpZeile, 1, ";"))) 
                        SourceCode()\tokData1  = StringField(StringField(tmpZeile, 2, ";"), 1, ",") 
                        SourceCode()\tokData2  = StringField(StringField(tmpZeile, 2, ";"), 2, ",")                        
                        
                        Select Left(SourceCode()\tokData1, 1) 
                            Case "#" ; Zahl 
                                SourceCode()\tokType1 = #TYPLong 
                                SourceCode()\tokData1 = Mid(SourceCode()\tokData1, 2, Len(SourceCode()\tokData1)) 
                            Case "*" ; String 
                                SourceCode()\tokType1 = #TYPString 
                                SourceCode()\tokData1 = Mid(SourceCode()\tokData1, 2, Len(SourceCode()\tokData1)) 
                            Case "@" ; Pointer 
                                SourceCode()\tokType1 = #TYPPointer 
                                SourceCode()\tokData1 = Mid(SourceCode()\tokData1, 2, Len(SourceCode()\tokData1)) 
                            Default  ; Speicher 
                                SourceCode()\tokType1 = #TYPMemory 
                        EndSelect 
                        
                        Select Left(SourceCode()\tokData2, 1) 
                            Case "#" ; Zahl 
                                SourceCode()\tokType2 = #TYPLong 
                                SourceCode()\tokData2 = Mid(SourceCode()\tokData2, 2, Len(SourceCode()\tokData2)) 
                                If isNumeric(SourceCode()\tokData1) = #False 
                                    CPrint("^CERROR^7: In Zeile " + Str(ListIndex(SourceCode())) + ", Longzuweisung enthält keine Long Variable !"+#STX$, #True) 
                                EndIf                                
                            Case "*" ; String 
                                SourceCode()\tokType2 = #TYPString 
                                SourceCode()\tokData2 = Mid(SourceCode()\tokData2, 2, Len(SourceCode()\tokData2)) 
                            Case "@" ; Pointer 
                                SourceCode()\tokType2 = #TYPPointer 
                                SourceCode()\tokData2 = Mid(SourceCode()\tokData2, 2, Len(SourceCode()\tokData2))                                
                            Default  ; Speicher 
                                SourceCode()\tokType2 = #TYPMemory 
                        EndSelect                        
                    EndIf  
            EndSelect        
        Wend        
        CloseFile(FilehWnd) 
    EndIf 
EndProcedure 

Procedure CPrint(pText.s, Head.b) 
    Define.l i 
    Define.s Color, tmpStr 
    
    CharToOem_(@pText, @pText) 
    If Head = #True 
        CPrint("^8> ", #False) 
        ConsoleColor(7, 0) 
    EndIf 
    For i = 1 To Len(pText) 
        If Mid(pText, i, 1) = "^" 
            Color = UCase(Mid(pText, i + 1, 1)) 
            
            Select Color 
                Case "0": Color = "0"  ; 0   Schwarz -_- 
                Case "1": Color = "1"  ; 1   Blau 
                Case "2": Color = "2"  ; 2   Grün 
                Case "3": Color = "3"  ; 3   Türkis 
                Case "4": Color = "4"  ; 4   Rot 
                Case "5": Color = "5"  ; 5   Magenta 
                Case "6": Color = "6"  ; 6   Braun 
                Case "7": Color = "7"  ; 7   Hellgrau (Std.) 
                Case "8": Color = "8"  ; 8   Dunkelgrau 
                Case "9": Color = "9"  ; 9   Hellblau 
                Case "A": Color = "10" ; 10  Hellgrün 
                Case "B": Color = "11" ; 11  Cyan 
                Case "C": Color = "12" ; 12  Hellrot 
                Case "D": Color = "13" ; 13  Helles Magenta 
                Case "E": Color = "14" ; 14  Gelb 
                Case "F": Color = "15" ; 15  Weiß 
                Default:Print(Mid(pText, i, 2)) 
            EndSelect 
            
            ConsoleColor(Val(Color), 0) 
            i + 1 
        ElseIf Mid(pText, i, 1) = Chr(2) 
            PrintN("") 
        Else 
            Print(Mid(pText, i, 1)) 
        EndIf 
    Next 
    ConsoleColor(7, 0) 
EndProcedure 

Procedure.b isNumeric(strZahl.s) 
    Define.b bytResult 
    Define.l lngCount 
    Define.s strTmpChar 
    
    bytResult = #True 
    For lngCount = 1 To Len(strZahl) 
        strTmpChar = Mid(strZahl, lngCount, 1) 
        If Asc(strTmpChar) < '0' Or Asc(strTmpChar) > '9' 
            bytResult = #False 
            Break 
        EndIf 
    Next 
    
    ProcedureReturn bytResult 
EndProcedure

; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = -