bas_via.bas

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

        If Position >= Len(Source) Then ErrMessage "found end of code. but expected "
    Wend
End Function
Sub DeclareFrame(Optional IsExport As Boolean, Optional NoCodeBlock As Boolean, Optional IsProto As Boolean, Optional IsProperty As Boolean)
    Dim pCount As Long
    Dim Ident As String
    Dim fAlias As String
    Dim Name As String
    Dim Method As String
    Dim IdentII As String
    Dim RetAs As String
    ArgCount = 0
    If IsProperty Then
        Method = Identifier
        If Method <> "set" And Method <> "get" Then
            ErrMessage "property "
        Else
            Method = "." & Method
        End If
    End If
    Ident = Identifier
    AddFrame Ident & Method, IsProperty
    Symbol "(":
NextDeclare:
    IdentII = Identifier
    If IdentII <> "" Then
        VariableBlock IdentII, True
        ArgCount = ArgCount + 1
    End If
    If IsSymbol(",") Then
        Symbol (","): GoTo NextDeclare
    ElseIf IsSymbol(")") Then
        Symbol (")")
        If IsIdent("as") Then
            SkipIdent
            RetAs = Identifier
            If RetAs = "dword" Or RetAs = "single" Or RetAs = "string" Then
                Frames(UBound(Frames)).ReturnAs = RetAs
            Else
                ErrMessage ""
            End If
            SkipBlank
        End If
        Terminator
    Else
        ErrMessage "unexpected "
    End If
    If IsProto Then
        AddSymbol Ident & Method, OffsetOf(".code"), 0, ST_FRAME, True
        AddSymbol Ident & Method & ".Address", OffsetOf(".code"), Code, ST_DWORD, True
    Else
        AddSymbol Ident & Method, OffsetOf(".code"), 0, ST_FRAME
        AddSymbol Ident & Method & ".Address", OffsetOf(".code"), Code, ST_DWORD
    End If
    If Not IsProto Then If IsExport Then AddExport Ident & Method
    If Not IsProto Then
        StartFrame
        CodeBlock
        AddSymbol Ident & Method & ".end", OffsetOf(".code"), 0, ST_FRAME
        EndProc
        EndFrame ArgCount * 4
        If Not NoCodeBlock Then CodeBlock
    End If
End Sub
Sub EndProc()
    If IsIdent("end") Then
        SkipIdent
        Terminator
        CurrentFrame = ""
        DoEvents
        If Not IsCmdCompile Then 编译进程 = "分析中.. (" & CInt(Position / Len(Source) * 100) & "% 完成.. | 位置: " & Position & " )"
        Exit Sub
    Else
        ErrMessage "无法进行到文件尾 "
        Exit Sub
    End If
End Sub
Sub InitParser()
    Dim i As Integer
    AppType = 0: pError = False: bLibrary = False: UnsignedDeclare = False
    CompareOne = "": CompareTwo = "": Source = ""
    For i = 1 To UBound(VirtualFiles)
        If Not VirtualFiles(i).Extension = EX_DIALOG Then
            Source = Source & "module " & Chr(34) & VirtualFiles(i).Name & Chr(34) & ";" & vbNewLine & VirtualFiles(i).Content & vbNewLine
        End If
    Next i
    Source = Replace(Source, vbTab, " ", 1, -1, vbTextCompare)
    Source = Replace(Source, " _ " & vbCrLf, "     ", 1, -1, vbTextCompare)
    Source = Replace(Source, " _" & vbCrLf, "    ", 1, -1, vbTextCompare)
    Source = Replace(Source, "_" & vbCrLf, "   ", 1, -1, vbTextCompare)
    Source = Source & vbNewLine
    Position = 1
End Sub
Sub Parse()
    StartCounter
    CurrentModule = "": CurrentFrame = "": CurrentType = "": EntryPoint = ""
    If Not bLibrary Then
        CreateSection ".data", Data, CH_INITIALIZED_DATA + CH_MEM_READ + CH_MEM_WRITE
        CreateSection ".code", Code, CH_CODE + CH_MEM_READ + CH_MEM_EXECUTE
        CreateSection ".idata", Import, CH_INITIALIZED_DATA + CH_MEM_READ + CH_MEM_WRITE
        CreateSection ".edata", Export, CH_INITIALIZED_DATA + CH_MEM_READ
        CreateSection ".rsrc", Resource, CH_INITIALIZED_DATA + CH_MEM_READ
        CreateSection ".reloc", Relocate, CH_MEM_DISCARDABLE + CH_INITIALIZED_DATA
        AssignProtoTypes
        DirectiveModule
        DirectiveApplication
        AddImport "lstrcpyA", "KERNEL32.DLL", 2, "lstrcpy"
        AddImport "lstrcmpA", "KERNEL32.DLL", 2, "lstrcmp"
        AddImport "wsprintfA", "USER32.DLL", -1, "Format"
        AddImport "ExitProcess", "KERNEL32.DLL", 1
        AddImport "GetModuleHandleA", "KERNEL32.DLL", 1, "GetModuleHandle"
        AddImport "HeapCreate", "KERNEL32.DLL", 3
        AddImport "HeapAlloc", "KERNEL32.DLL", 3
        AddImport "HeapDestroy", "KERNEL32.DLL", 1
        AddImport "RtlMoveMemory", "KERNEL32.DLL", 3, "MoveMemory"
        AddImport "MessageBoxA", "USER32.DLL", 4, "MessageBox"
        DeclareDataDWord "Instance", 0
        DeclareDataDWord "$Intern.Property", 0
        DeclareDataDWord "$Intern.Compare.One", 0
        DeclareDataDWord "$Intern.Compare.Two", 0
        DeclareDataDWord "$Intern.Float", 0
        DeclareDataDWord "$Intern.Array", 0
        DeclareDataDWord "$Intern.Loop", 0
        DeclareDataDWord "$Intern.Count", 0
        DeclareDataDWord "$Intern.Return", 0
        AddConstant "TRUE", -1: AddConstant "FALSE", 0
        AddConstant "NULL", 0
        AddCodeWord &H6A: InvokeByName "GetModuleHandle"
        AddCodeByte &HA3: AddCodeFixup "Instance"
        If Not IsDLL Then
            If EntryPoint = "" Then
                ExprCall "$entry"
            Else
                ExprCall EntryPoint
                Push 0
                InvokeByName "ExitProcess"
            End If
        Else
            InitializeDLL
        End If
    End If
    Call CodeBlock: If Not bLibrary And Not IsDLL Then EntryBlock: Call CodeBlock
End Sub
Sub CodeBlock()
    Dim Ident As String
    Ident = Identifier
    If Ident = "" Or pError = True Then Exit Sub
    Select Case LCase(Ident)
        Case "import": DeclareImport
        Case "const": DeclareConstant
        Case "type": DeclareType
        Case "frame": DeclareFrame
        Case "property": DeclareFrame False, False, False, True
        Case "export": DeclareFrame True
        Case "return": StatementReturn
        Case "if": StatementIf
        Case "while": StatementWhile
        Case "for": StatementFor
        Case "loop": StatementLoop
        Case "goto": StatementGoto
        Case "jump": StatementGoto
        Case "include": StatementInclude
        Case "library": StatementInclude
        Case "local": DeclareLocal
        Case "preserve": StatementPreserve
        Case "reserve": StatementReserve
        Case "destroy": StatementDestroy
        Case "direct": StatementDirect
        Case "bytes": StatementBytes
        Case "with": StatementWith
        Case "ubound": StatementUBound
        Case "lbound": StatementLBound
        Case "bitmap": DeclareBitmap
        Case "module": Position = Position - 6: DirectiveModule: CodeBlock: Exit Sub
        Case "end": Position = Position - 3: Exit Sub
        Case "end.": Position = Position - 4: Exit Sub
        Case "entry": Position = Position - 6: Exit Sub
        Case Else
            If IsImport(Ident) Then
                CallImport Ident
            ElseIf IsLocalVariable(Ident) Then
                EvalLocalVariable Ident
            ElseIf IsProperty(Ident & ".set") Then
                CallProperty Ident & ".set"
            ElseIf IsFrame(Ident) Then
                CallFrame Ident
            ElseIf IsVariable(Ident) Then
                EvalVariable Ident
            Else
                VariableBlock Ident
            End If
    End Select
End Sub
Sub VariableBlock(Ident As String, Optional FrameExpression As Boolean, Optional NoCodeBlock As Boolean)
    If Ident = "" Or pError = True Then Exit Sub
    Select Case LCase(Ident)
        Case "signed": UnsignedDeclare = False: Ident = Identifier: VariableBlock Ident, FrameExpression, NoCodeBlock: Exit Sub
        Case "unsigned": UnsignedDeclare = True: Ident = Identifier: VariableBlock Ident, FrameExpression, NoCodeBlock: Exit Sub
        Case "byte": DeclareVariable CurrentType, "byte", FrameExpression, NoCodeBlock
        Case "bool": DeclareVariable CurrentType, "byte", FrameExpression, NoCodeBlock
        Case "word": DeclareVariable CurrentType, "word", FrameExpression, NoCodeBlock
        Case "dword": DeclareVariable CurrentType, "dword", FrameExpression, NoCodeBlock
        Case "single": DeclareVariable CurrentType, "single", FrameExpression, NoCodeBlock
        Case "string": DeclareString CurrentType, FrameExpression, NoCodeBlock
        Case "boolean": DeclareVariable CurrentType, "byte", FrameExpression, NoCodeBlock
        Case Else
            If IsType(Ident) Then
                AssignType Identifier, Ident
            Else
                ErrMessage "unknown identifier -> "
            End If
    End Select
    UnsignedDeclare = False
End Sub
Function StringExpression() As String
    Dim Value As String
    SkipBlank
    Symbol Chr(34)
    Value = Mid$(Source, Position, 1)
    While Value <> Chr(34)
        StringExpression = StringExpression & Mid$(Source, Position, 1)
        Position = Position + 1
        Value = Mid$(Source, Position, 2)
        If Value = "\n" Then Position = Position + 2: StringExpression = StringExpression & vbCrLf
        If Value = "\t" Then Position = Position + 2: StringExpression = StringExpression & vbTab
        Value = Mid$(Source, Position, 1)
        If Value = vbCr Or Value = "" Then
            ErrMessage "unterminated string": Exit Function
        End If
    Wend
    Symbol Chr(34)
End Function
Function ConstantExpression() As Long
    If IsSymbol("[") Then
        Symbol "["
        While Not IsSymbol("]")
            ConstantExpression = NumberExpression
            If IsSymbol("+") Then
                Symbol "+"
                ConstantExpression = ConstantExpression + NumberExpression
            ElseIf IsSymbol("-") Then
                Symbol "-"
                ConstantExpression = ConstantExpression - NumberExpression
            ElseIf IsSymbol("|") Then
                Symbol "|"
                If IsSymbol("!") Then
                    Symbol "!"
                    ConstantExpression = ConstantExpression Or Not NumberExpression
                Else
                    ConstantExpression = ConstantExpression Or NumberExpression
                End If
            ElseIf IsSymbol("&") Then
                Symbol "&"
                If IsSymbol("!") Then
                    Symbol "!"
                    ConstantExpression = ConstantExpression And Not NumberExpression
                Else
                    ConstantExpression = ConstantExpression And NumberExpression
                End If
            ElseIf IsSymbol("~") Then
                Symbol "~"
                ConstantExpression = ConstantExpression Xor NumberExpression
            Else
                ErrMessage "invalid constant value": Exit Function
            End If
            If Position >= Len(Source) Then ErrMessage "found end of code. but expected "
        Wend
        Symbol "]"
    Else
    ConstantExpression = GetConstant(Identifier)
    End If
End Function
Sub AssignProtoTypes()
    Dim OPosition As Long
    OPosition = Position
    While Position <= Len(Source)
        If Mid$(Source, Position, 5) = "frame" Then
            Call SkipIdent: SkipBlank
            DeclareFrame False, False, True
        ElseIf Mid$(Source, Position, 8) = "property" Then
            Call SkipIdent: SkipBlank
            DeclareFrame False, False, True, True
        ElseIf Mid$(Source, Position, 6) = "export" Then
            Call SkipIdent: SkipBlank
            DeclareFrame True, False, True
        ElseIf Mid$(Source, Position, 2) = "//" Then
            While Mid$(Source, Position, 2) <> vbCrLf
                Position = Position + 1
            Wend
        End If
        Position = Position + 1
        If Position >= Len(Source) Then GoTo ProtoDone
    Wend
ProtoDone:
    Position = OPosition
End Sub
Sub DirectiveModule()
    Dim ModName As String
    If IsIdent("module") Then
        SkipIdent
        CurrentModule = StringExpression
        Terminator
    End If
End Sub
Sub DirectiveApplication()
    If IsIdent("application") Then
        bLibrary = False
        SkipIdent
        If IsIdent("PE") Then
            SkipIdent
            If IsIdent("GUI") Then
                SkipIdent
                AppType = GUI
            ElseIf IsIdent("CUI") Then
                SkipIdent
                AppType = CUI
            Else
                ErrMessage "invalid format "
            End If
            SkipBlank
            If IsIdent("DLL") Then
                SkipIdent
                IsDLL = True
            End If
            If IsIdent("entry") Then
                DeclareEntryPoint
            Else
                Terminator
            End If
        Else
            ErrMessage "expected "
        End If
    ElseIf IsIdent("library") Then
        SkipIdent
        bLibrary = True
        SkipBlank
        LibraryName = StringExpression
        Terminator
    Else
        ErrMessage "expected "
    End If
End Sub
Sub EntryBlock()
    Dim Ident As String
    If Not EntryPoint = "" Or EntryPoint = "entry" Then Exit Sub
    Ident = Identifier
    If Ident = "entry" Then
        AddSymbol "$entry", OffsetOf(".code"), Code, ST_LABEL
    Else
        ErrMessage "expected "
    End If
    CodeBlock
    Ident = Identifier
    If Not Ident = "end." Then
        ErrMessage "expected "
    Else
        Push 0
        InvokeByName "ExitProcess"
    End If
End Sub
Sub DirectiveSection()
    Dim Name As String
    Dim Ident As String
    Dim ST As ENUM_SECTION_TYPE
    Dim CH As ENUM_SECTION_CHARACTERISTICS
    Name = StringExpression
    If SectionExists(Name) Then GoTo DirSectionExists
    Blank
    Ident = Identifier
    Select Case LCase(Ident)
        Case "data": ST = Data: CH = CH + CH_INITIALIZED_DATA
        Case "code": ST = Code: CH = CH + CH_CODE
        Case "import": ST = Import
        Case "export": ST = Export
        Case "resource": ST = Resource
        Case Else
            ErrMessage "invalid section type "
    End Select
    If IsSymbol(" ") Then
JCharacteristic:
        Blank
        Ident = Identifier
        Select Case LCase(Ident)
            Case "code": CH = CH + CH_CODE
            Case "data": CH = CH + CH_INITIALIZED_DATA
            Case "udata": CH = CH + CH_UNINITIALIZED_DATA
            Case "discardable": CH = CH + CH_MEM_DISCARDABLE
            Case "executable": CH = CH + CH_MEM_EXECUTE
            Case "notchached": CH = CH + CH_MEM_NOT_CHACHED
            Case "notpaged": CH = CH + CH_MEM_NOT_PAGED
            Case "readable": CH = CH + CH_MEM_READ
            Case "shared": CH = CH + CH_MEM_SHARED
            Case "writeable": CH = CH + CH_MEM_WRITE
            Case Else
                ErrMessage "invalid characteristic "
        End Select
    End If
    If IsSymbol(" ") Then GoTo JCharacteristic
    CurrentSection = Name
DirSectionExists: