via.cls

来自「VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成E」· CLS 代码 · 共 2,004 行 · 第 1/5 页

Function HiByte(ByVal iWord As Integer) As Byte
    HiByte = (iWord And &HFF00&) \ &H100
End Function
Function LoByte(ByVal iWord As Integer) As Byte
    LoByte = iWord And &HFF
End Function
Function HiWord(lDword As Long) As Integer
    HiWord = (lDword And &HFFFF0000) \ &H10000
End Function
Function LoWord(lDword As Long) As Integer
    If lDword And &H8000& Then
        LoWord = lDword Or &HFFFF0000
    Else
        LoWord = lDword And &HFFFF&
    End If
End Function
Function HiSWord(lDword As Single) As Integer
    HiSWord = (lDword And &HFFFF0000) \ &H10000
End Function
Function LoSWord(lDword As Single) As Integer
    If lDword And &H8000& Then
        LoSWord = lDword Or &HFFFF0000
    Else
        LoSWord = lDword And &HFFFF&
    End If
End Function
Function LoDWord(ByVal cQWord As Currency) As Long
    Dim QWord As TYPE_QWORD: Dim LoHiQword As TYPE_LOHIQWORD
    QWord.Value = cQWord / 10000
    LSet LoHiQword = QWord
    LoDWord = LoHiQword.lLoDWord
End Function
Function HiDWord(ByVal cQWord As Currency) As Long
    Dim QWord As TYPE_QWORD: Dim LoHiQword As TYPE_LOHIQWORD
    QWord.Value = cQWord / 10000
    LSet LoHiQword = QWord
    HiDWord = LoHiQword.lHiDWord
End Function
Function MakeQWord(ByVal lHiDWord As Long, ByVal lLoDWord As Long) As Currency
    Dim QWord As TYPE_QWORD: Dim LoHiQword As TYPE_LOHIQWORD
    LoHiQword.lHiDWord = lHiDWord: LoHiQword.lLoDWord = lLoDWord
    LSet QWord = LoHiQword: MakeQWord = QWord.Value * 10000
End Function



Sub ReserveArray(Ident As String, Size As Long)
    DeclareDataDWord Ident & ".PtrToArray", 0
    DeclareDataDWord Ident & ".HeapHandle", 0
    DeclareDataDWord Ident & ".ubound", 0
    DeclareDataDWord Ident & ".lbound", 0
    DeclareDataDWord Ident & ".Array", 0
    If CurrentFrame <> "" Then
        Push 0: Push 0: Push 0
        InvokeByName "HeapCreate"
        AssignEAX Ident & ".HeapHandle"
        Push GetSymbolSize(Ident) * Size: Push 8
        PushContent Ident & ".HeapHandle"
        InvokeByName "HeapAlloc"
        AssignEAX Ident & ".PtrToArray"
        Push 0: PopEAX: AssignEAX Ident & ".lbound"
        Push Size: PopEAX: AssignEAX Ident & ".ubound"
    End If
End Sub
Sub GetArray(Ident As String)
    Expression Ident & ".Array"
    Push GetSymbolSize(Ident)
    PushContent Ident & ".Array"
    Push GetSymbolSize(Ident)
    ExprMul
    PushEAX
    PushContent Ident & ".PtrToArray"
    ExprAdd
    PushEAX
    PushAddress Ident
    InvokeByName "MoveMemory": PushContent Ident
End Sub
Sub SetArray(Name As String)
    Symbol "("
    Expression "$Intern.Array"
    Symbol ")"
    Symbol "="
    Expression Name
    Push GetSymbolSize(Name)
    PushAddress Name
    PushContent "$Intern.Array"
    Push GetSymbolSize(Name)
    ExprMul
    PushEAX
    PushContent Name & ".PtrToArray"
    ExprAdd
    PushEAX
    InvokeByName "MoveMemory"
End Sub
Sub StatementPreserve()
    Dim Ident As String
    Ident = Identifier
    Symbol "("
    Expression "$Intern.Array"
    Symbol ")"
    Terminator
    PushContent "$Intern.Array": Push 1
    PushContent Ident & ".HeapHandle"
    InvokeByName "HeapAlloc"
    PushContent "$Intern.Array": PopEAX: AssignEAX Ident & ".ubound"
    CodeBlock
End Sub
Sub StatementReserve()
    Dim Ident As String
    Ident = Identifier
    Symbol "("
    Expression "$Intern.Array"
    Symbol ")"
    Terminator
    Push 0: Push 0: Push 0
    InvokeByName "HeapCreate"
    AssignEAX Ident & ".HeapHandle"
    PushContent "$Intern.Array"
    Push GetSymbolSize(Ident)
    ExprMul
    PushEAX
    Push 8
    PushContent Ident & ".HeapHandle"
    InvokeByName "HeapAlloc"
    AssignEAX Ident & ".PtrToArray"
    PushContent "$Intern.Array": PopEAX: AssignEAX Ident & ".ubound"
    CodeBlock
End Sub
Sub StatementDestroy()
    Dim Ident As String
    Ident = Identifier
    Terminator
    If SymbolExists(Ident & ".HeapHandle") Then
        PushContent Ident & ".HeapHandle"
        InvokeByName "HeapDestroy"
        Push 0: PopEAX
        AssignEAX Ident & ".ubound"
    Else
        ErrMessage "cannot destroy "
    End If
    CodeBlock
End Sub
Sub StatementUBound()
    Dim Ident As String
    Symbol "("
    Ident = Identifier
    Symbol ")"
    PushContent Ident & ".ubound"
End Sub
Sub StatementLBound()
    Dim Ident As String
    Symbol "("
    Ident = Identifier
    Symbol ")"
    PushContent Ident & ".lbound"
End Sub



Function OptimizeAble(ByInstruction As String, Optional Variable As String) As Boolean
    Dim B1 As Byte: Dim B2 As Byte: Dim B3 As Byte: Dim B4 As Byte
    On Error GoTo NotOptimize
    Select Case ByInstruction
        Case "PopEAX"
            If Section(2).Bytes(UBound(Section(2).Bytes)) = &H50 Then
                ReDim Preserve Section(2).Bytes(UBound(Section(2).Bytes) - 1) As Byte
                OptimizeAble = True
            ElseIf Section(2).Bytes(UBound(Section(2).Bytes) - 4) = &H68 Then
                B1 = Section(2).Bytes(UBound(Section(2).Bytes) - 3)
                B2 = Section(2).Bytes(UBound(Section(2).Bytes) - 2)
                B3 = Section(2).Bytes(UBound(Section(2).Bytes) - 1)
                B4 = Section(2).Bytes(UBound(Section(2).Bytes))
                ReDim Preserve Section(2).Bytes(UBound(Section(2).Bytes) - 5) As Byte
                AddCodeByte &HB8
                AddCodeByte B1
                AddCodeByte B2
                AddCodeByte B3
                AddCodeByte B4
                OptimizeAble = True
            End If
        Case Else
    End Select
NotOptimize:
End Function
Function Identifier() As String
    Dim Value As String
    SkipBlank
    Value = Mid$(Source, Position, 1)
    If Value = "." And WithIdent <> "" Then Identifier = WithIdent
    While (UCase(Value) >= "A" And UCase(Value) <= "Z") Or Value = "." Or Value = "_"
            While IsNumeric(Mid$(Source, Position + 1, 1))
                Identifier = Identifier & Mid$(Source, Position, 1)
                Position = Position + 1
            Wend
            Identifier = Identifier & Mid$(Source, Position, 1)
            Position = Position + 1
            Value = Mid$(Source, Position, 1)
    Wend
    If IsSymbol(":") Then DeclareLabel Identifier: Identifier = Identifier()
End Function
Sub Skip(Optional NumberOfChars As Integer)
    Position = Position + 1 + NumberOfChars
End Sub
Sub SkipBlank()
    Dim Value As String
    Dim Value2 As String
    Value = Mid$(Source, Position, 1)
    Value2 = Mid$(Source, Position, 2)
    While Value = " " Or Value = vbCr Or Value = vbLf Or Value = vbTab Or Value2 = "//"
          If Value2 = "//" Then
            While Mid$(Source, Position, 2) <> vbCrLf
                Position = Position + 1: If Position >= Len(Source) Then ErrMessage "found end of code": Exit Sub
            Wend
          End If
        Position = Position + 1
        Value = Mid$(Source, Position, 1)
        Value2 = Mid$(Source, Position, 2)
    Wend
End Sub
Sub SkipIdent()
    Call Identifier
End Sub
Sub Symbol(Value As String)
    SkipBlank
    If Mid$(Source, Position, 1) = Value Then
        Position = Position + 1
    Else
        ErrMessage "expected symbol "
    End If
End Sub
Function IsIdent(Word As String) As Boolean
    SkipBlank
    If Mid$(Source, Position, Len(Word)) = Word Then IsIdent = True
End Function
Function IsSymbol(Value As String) As Boolean
    If Mid$(Source, Position, Len(Value)) = Value Then IsSymbol = True
End Function
Sub Blank()
    If Mid$(Source, Position, 1) = " " Then
        Position = Position + 1
    Else
        ErrMessage "expected blank "
    End If
End Sub
Sub Terminator()
    If Mid$(Source, Position, 1) = ";" Then
        Position = Position + 1
    Else
        ErrMessage "expected terminator (;) but found "
    End If
End Sub
Function IsVariable(Name As String) As Boolean
    Dim i As Integer
    For i = 0 To UBound(Symbols)
        If Symbols(i).Name = Name Then
            If Symbols(i).SymType = ST_BYTE Or Symbols(i).SymType = ST_WORD Or Symbols(i).SymType = ST_DWORD Or Symbols(i).SymType = ST_SINGLE Or Symbols(i).SymType = ST_US_BYTE Or Symbols(i).SymType = ST_US_WORD Or Symbols(i).SymType = ST_US_DWORD Or Symbols(i).SymType = ST_STRING Then
                IsVariable = True
                Exit Function
            End If
            Exit Function
        End If
    Next i
End Function
Function IsEndOfCode(Value As Long) As Boolean
    If Value > Len(Source) Then
        ErrMessage "found end of code. but expected "
    End If
End Function
Function IsVariableExpression() As Boolean
    If (UCase(Mid$(Source, Position, 1)) >= "A" And UCase(Mid$(Source, Position, 1)) <= "Z") Then
        IsVariableExpression = True
    End If
End Function
Function IsStringExpression() As Boolean
    If Mid$(Source, Position, 1) = Chr(34) Then
        IsStringExpression = True
    End If
End Function
Function IsFloatExpression() As Boolean
    Dim i As Integer
    Dim StrFloat As String
    Dim OPosition As Long
    OPosition = Position
    While IsNumeric(Mid$(Source, Position, 1)) Or Mid$(Source, Position, 1) = "-" Or Mid$(Source, Position, 1) = "."
        StrFloat = StrFloat & Mid$(Source, Position, 1)
        Position = Position + 1
    Wend
    Position = OPosition
    If InStr(1, StrFloat, ".", vbTextCompare) <> 0 Then
        IsFloatExpression = True
    End If
End Function
Function IsNumberExpression() As Boolean
    Dim i As Integer
    If IsNumeric(Mid$(Source, Position, 1)) Or Mid$(Source, Position, 1) = "-" Or Mid$(Source, Position, 1) = "$" Then
        IsNumberExpression = True
    ElseIf IsConstantExpression Then
        For i = 1 To UBound(Constants)
            If IsIdent(Constants(i).Name) Then
                IsNumberExpression = True
                Exit Function
            End If
        Next i
    End If
End Function
Function IsConstantExpression() As Boolean
    If (UCase(Mid$(Source, Position, 1)) >= "A" And UCase(Mid$(Source, Position, 1)) <= "Z") Then
        IsConstantExpression = True
    ElseIf IsSymbol("[") Then
        IsConstantExpression = True
    End If
End Function
Function NumberExpression() As Variant
    Dim i As Integer
    Dim CToHex As Boolean
    Dim Str2Hex As String
    SkipBlank
    If IsSymbol("$") Then
        Symbol "$"
        CToHex = True
        While IsNumeric(Mid$(Source, Position, 1)) Or Mid$(Source, Position, 1) = "-" Or Mid$(Source, Position, 1) = "A" Or Mid$(Source, Position, 1) = "B" Or Mid$(Source, Position, 1) = "C" Or Mid$(Source, Position, 1) = "D" Or Mid$(Source, Position, 1) = "E" Or Mid$(Source, Position, 1) = "F"
                NumberExpression = NumberExpression & Mid$(Source, Position, 1)
                Position = Position + 1
        Wend
    Else
        While IsNumeric(Mid$(Source, Position, 1)) Or Mid$(Source, Position, 1) = "-" Or Mid$(Source, Position, 1) = "."
                Dim IsNegative As Boolean
                Dim IsFloatRec As Boolean
                Dim AfterPoint As String
                If Mid$(Source, Position, 1) = "." Then
                    Position = Position + 1
                    While IsNumeric(Mid$(Source, Position, 1))
                        AfterPoint = AfterPoint & Mid$(Source, Position, 1)
                        Position = Position + 1
                    Wend
                    Position = Position - 1
                    If CSng("0.1") = 0.1 Then
                        AfterPoint = "0." & AfterPoint
                    ElseIf CSng("0,1") = 0.1 Then
                        AfterPoint = "0," & AfterPoint
                    End If
                    NumberExpression = CSng(NumberExpression) + CSng(AfterPoint)
                    If IsNegative = True Then NumberExpression = NumberExpression * (-1)
                ElseIf Mid$(Source, Position, 1) = "-" Then
                    IsNegative = True
                Else
                    NumberExpression = NumberExpression & Mid$(Source, Position, 1)
                End If
                Position = Position + 1
        Wend
        If AfterPoint = "" Then
            If IsNegative Then
                NumberExpression = NumberExpression * (-1)
            End If
        End If
    End If
    If CToHex = True Then NumberExpression = CLng("&H" & NumberExpression)
    If NumberExpression = 0 Then
        For i = 1 To UBound(Constants)
            If IsIdent(Constants(i).Name) Then
                NumberExpression = GetConstant(Identifier)
                Exit Function
            End If
        Next i
    End If
End Function
Sub InsertSource(sISource As String)
    Dim Header As String: Dim Footer As String
    Header = Mid$(Source, 1, Position - 1)
    Footer = Mid$(Source, Position, Len(Source) - Position + 1)
    Source = Header & sISource & Footer
End Sub
Function VariableExpression() As String
    SkipBlank
    VariableExpression = Identifier
End Function
Sub InitResources()
    lUniqueBMP = 0
    ReDim D(0) As TYPE_RES_DIRECTORY
End Sub
Sub DeclareBitmap()
    Dim i As Long
    Dim Ident As String
    Dim sFile As String
    lUniqueBMP = lUniqueBMP + 1
    Ident = Identifier
    Symbol ","
    sFile = StringExpression
    Terminator
    i = FindDirIDByType(2): If i = -1 Then i = AddResourceDirectory(2)
    AddResourceItem i, lUniqueBMP
    AddResourceResource i, GetDirItemUBound(CLng(i)), 2, sFile, Ident
    CodeBlock
End Sub
Function GetDirItemUBound(DirID As Integer) As Long
    GetDirItemUBound = UBound(D(DirID).IT)
End Function
Function FindDirIDByType(DirType As Integer) As Long
    Dim i As Integer
    For i = 1 To UBound(D)