modruntime.bas

用VB实现的编译器的源代码

Attribute VB_Name = "ModRuntime"
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const SplitChar = "~"

Public AllSockets() As TCPSocket
Public SocketsCount As Integer
Public HSMode As Boolean
Public GlobalDataExchangeVariable
Public SkipALine As Boolean
Public BreakWinLoop As Boolean
Public PublicVars As New Dictionary
Public ProgramLines(65336) As String
Public AllControls(32768) As Object
Public NewControlIndex As Integer
Public Classes As New Dictionary
Public Pointer As Long
Public DebugMode As Boolean
Public CurrentLocal As Class
Public ExecutionalStack(200) As Class
Public ESStackPointer As Integer
Public LastIf As Boolean
Public FunctionReturn
Public Turtle As New TurtleGraph

Private LoopReturnPoint() As Integer
Private LoopPointer As Integer

Public Function getCID(Index As Integer, OwnerObject As Class) As String
    TKeys = OwnerObject.ControlCollection.Keys
    TItems = OwnerObject.ControlCollection.Items
    For f = LBound(TItems) To UBound(TItems)
        If CInt(TItems(f)) = Index Then
            getCID = TKeys(f)
            Exit Function
        End If
    Next f

End Function

Public Function Decode(Text As String) As String
    Dim ReturnStr As String
    For f = 1 To Len(Text) Step 4
        Token = Mid(Text, f, 4)
        DecodedToken = Val("&H" & Token)
        ReturnStr = ReturnStr & ChrW(DecodedToken)
    Next f
    Decode = ReturnStr
End Function

Public Sub Main()
    If Not Command = "" Then
        If Not Command = "DEBUG" Then
            FileCopy App.Path & "\" & App.EXEName & ".exe", Command
            Open Command For Binary As #1
                Seek #1, LOF(1)
                Do While LOF(1) < 262144
                    Put #1, , Chr(0)
                Loop
            Close #1
            End
        Else
            Open "C:\DebugCode.BIS" For Input As #1
                Pointer = 0
                Do Until EOF(1)
                    Line Input #1, TheLine
                    TheLine = Trim(TheLine)
                    If Not TheLine = "" Then
                        If TheLine = "debug" Then MsgBox "Debug version!": DebugMode = True
                        ToDebug Pointer & ": " & TheLine
                        ProgramLines(Pointer) = TheLine
                        Pointer = Pointer + 1
                    End If
                Loop
            Close #1
            GoTo ContinueTheProgram
        End If
    End If
    Randomize Timer
    i = Int(Rnd * 4000)
    Dim WorkPath As String
    WorkPath = Environ("TEMP") & "\CI" & i & ".EXE"
    FileCopy App.Path & "\" & App.EXEName & ".exe", WorkPath
    Dim caByte As String * 1
    Open WorkPath For Binary As #1
    Open Environ("TEMP") & "\CS" & i & ".SRC" For Binary As #2
        Seek #1, 262145
        Do Until EOF(1)
            Get #1, , caByte
            Put #2, , caByte
        Loop
    Close #2
    Close #1
    Open Environ("TEMP") & "\CS" & i & ".SRC" For Input As #1
        Pointer = 0
        Do Until EOF(1)
            Line Input #1, TheLine
            TheLine = Decode(CStr(TheLine))
            If TheLine = "debug" Then MsgBox "Debug version!": DebugMode = True
            ToDebug Pointer & ": " & TheLine
            ProgramLines(Pointer) = TheLine
            Pointer = Pointer + 1
        Loop
    Close #1
    
ContinueTheProgram:
    ReadGlobalVars
    CreateNewObject "AppMain", "AppMain"
    ToDebug "Start object 'AppMain' created."
    getObject("AppMain").ExecuteVoid "run", "", "", "", "", "", "", "", ""
End Sub

Public Sub ToDebug(Text)
    If DebugMode = False Then Exit Sub
    Open "C:\DEBUG.LOG" For Append As #4
        Print #4, Text
    Close #4
End Sub

Public Function getObject(name As String) As Class
    On Error Resume Next
    If Not Classes.Exists(name) Then
        CreateNewObject name, name
    End If
    If Left(Classes(name), 1) = "-" Then
        name = Mid(Classes(name), 2)
    End If
    Set getObject = Classes(name)
    ToDebug "--> getObject call '" & name & "'"
    ToDebug "--> found: " & getObject.name & " based on " & getObject.BaseClass
End Function

Public Function IsolateExpression(ByRef RawLine, ExpressionNumber As Integer, ByRef Waste As String)
    Dim GiveBackString$, CPos%
    CPos = 0
    GiveBackString = RawLine
    
     'For f = 1 To ExpressionNumber
     '    GiveBackString = Mid(GiveBackString, InStr(GiveBackString, "[") + 1)
     '    If InStr(GiveBackString, "]") > InStr(GiveBackString, "[") And f < ExpressionNumber Then
     '        Do Until InStr(GiveBackString, "]") < InStr(GiveBackString, "[") Or InStr(GiveBackString, "[") = 0
     '            GiveBackString = Mid(GiveBackString, InStr(GiveBackString, "[") + 1)
     '        Loop
     '    End If
     'Next f
        
    'Count all brackets and find balance points
    If InStr(GiveBackString, "[") = 0 Then
        IsolateExpression = "You forgot a parameter."
        Exit Function
    End If
    Dim BalancePoint(10) As Integer
    Dim BalancePointCount As Integer
    BalancePoint(0) = InStr(GiveBackString, "[") - 1
    BalancePointCount = 1
    If BalancePoint(0) = -1 Then Exit Function
    For f = 1 To Len(GiveBackString)
        If Mid(GiveBackString, f, 1) = "[" Then OpenBrackets = OpenBrackets + 1
        If Mid(GiveBackString, f, 1) = "]" Then
            OpenBrackets = OpenBrackets - 1
            If OpenBrackets = 0 Then
                BalancePoint(BalancePointCount) = f + 1
                BalancePointCount = BalancePointCount + 1
            End If
        End If
    Next f
    BalancePoint(BalancePointCount) = Len(GiveBackString) + 1
    BalancePointCount = BalancePointCount + 1
        
    If BalancePointCount - 1 < ExpressionNumber Then Exit Function
        
    'Cut off the end
    GiveBackString = Left(GiveBackString, BalancePoint(ExpressionNumber) - 1)
    GiveBackString = Left(GiveBackString, InStrRev(GiveBackString, "]") - 1)
    
    'Jump to the start balance point
    GiveBackString = Mid(GiveBackString, BalancePoint(ExpressionNumber - 1))
    GiveBackString = Mid(GiveBackString, InStr(GiveBackString, "[") + 1)
        
    'LEGACY:
    
    'If InStrRev(GiveBackString, "]") = 0 Then
    '    Exit Function
    'End If
    
    'If InStrRev(GiveBackString, "[") > InStr(GiveBackString, "]") Then
    '    GiveBackString = Left(GiveBackString, InStrRev(GiveBackString, "[") - 1)
    'End If
    
    'If Mid(GiveBackString, InStrRev(GiveBackString, "]") + 1, 1) = "(" Then
    '    TempStr = Mid(GiveBackString, InStr(GiveBackString, "]") + 2)
    '    Waste = Left(TempStr, InStr(TempStr, ")") - 1)
    'End If
    
    'GiveBackString = Left(GiveBackString, InStrRev(GiveBackString, "]") - 1)
    
    IsolateExpression = Trim(GiveBackString)
End Function

Public Function getValueFromExpression(ByRef RawLine, Optional ExpressionNumber As Integer = 1)
    Dim Conversion As String
    Dim Unlockmode As Integer
    Unlockmode = 0
    GlobalDataExchangeVariable = 0
    DRawLine = RawLine
    Conversion = "none"
    DRawLine = IsolateExpression(DRawLine, ExpressionNumber, Conversion)
    Dim ReturnValue
    Dim RawArray
    RawArray = Split(DRawLine, " ")
    Dim ArPointer As Integer
    Dim ExpressionParse(128)
    Dim QuoteMode As Boolean
    QuoteMode = False
    ArPointer = 0
    
    'Pack all strings
    For f = LBound(RawArray) To UBound(RawArray)
        If QuoteMode = False Then
            ExpressionParse(ArPointer) = RawArray(f)
        Else
            ExpressionParse(ArPointer) = ExpressionParse(ArPointer) & " " & RawArray(f)
        End If
        
        If Unlockmode = 0 Then
            If Left(RawArray(f), 1) = "[" Then
                QuoteMode = True: Unlockmode = 1
            ElseIf Left(RawArray(f), 1) = "{" Then
                QuoteMode = True: Unlockmode = 2
            ElseIf Left(RawArray(f), 1) = """" Then
                QuoteMode = True: Unlockmode = 3
            End If
        End If
        
        If Unlockmode = 3 And Right(RawArray(f), 1) = """" Then
            QuoteMode = False: Unlockmode = 0
        ElseIf Unlockmode = 2 And Right(RawArray(f), 1) = "}" Then
            QuoteMode = False: Unlockmode = 0
        ElseIf Unlockmode = 1 And Right(RawArray(f), 1) = "]" Then
            QuoteMode = False: Unlockmode = 0
        End If
        
        If QuoteMode = False Then
            ArPointer = ArPointer + 1
        End If
    Next
    
    'Parse
    ReturnValue = ParseExpressionFragment(ExpressionParse(0))
    If ArPointer < 2 Then
        GoTo GiveItBack
    End If
    For f = 1 To ArPointer - 1
        'If Left(ExpressionParse(f), 1) = "$" Then
            Select Case ExpressionParse(f)
                Case "+"
                    f = f + 1
                    ReturnValue = Val(ReturnValue) + Val(ParseExpressionFragment(ExpressionParse(f)))
                Case "-"
                    f = f + 1
                    ReturnValue = Val(ReturnValue) - Val(ParseExpressionFragment(ExpressionParse(f)))
                Case "*"
                    f = f + 1
                    ReturnValue = Val(ReturnValue) * Val(ParseExpressionFragment(ExpressionParse(f)))
                Case "/"
                    f = f + 1
                    ReturnValue = Val(ReturnValue) / Val(ParseExpressionFragment(ExpressionParse(f)))
                Case "&"
                    f = f + 1
                    ReturnValue = ReturnValue & ParseExpressionFragment(ExpressionParse(f))
            End Select
        'End If
    Next
GiveItBack:
    getValueFromExpression = ReturnValue
End Function

Public Function ParseExpressionFragment(Fragment)
    Dim Identifier As String * 1
    Dim FragmentRaw As String
    Dim ReturnValue
    Identifier = Left(Fragment, 1)
    FragmentRaw = Mid(Fragment, 2)
    If FragmentRaw = "" Then FragmentRaw = "%20"
    'FragmentRaw = Replace(FragmentRaw, "%20", " ")
    FragmentRaw = Replace(FragmentRaw, "%0D", vbCrLf)
    FragmentRaw = Replace(FragmentRaw, "%09", vbTab)
    Select Case Identifier
    
        Case "("
            DataType = Left(FragmentRaw, InStr(FragmentRaw, ")") - 1)
            Content = ParseExpressionFragment(Mid(FragmentRaw, InStr(FragmentRaw, ")") + 1))
            Select Case DataType
                Case "int"
                    ReturnValue = CInt(Content)
                Case "unicode"
                    ReturnValue = CStr(Content)
                Case "float"
                    ReturnValue = CSng(Content)
                Case "double"
                    ReturnValue = CDbl(Content)
                Case "long"
                    ReturnValue = CLng(Content)
                Case "bool"
                    ReturnValue = CBool(Content)
            End Select
        
        Case """" ' "String"
            FragmentRaw = Replace(FragmentRaw, "%20", " ")
            ReturnValue = Left(FragmentRaw, Len(FragmentRaw) - 1)
            
        Case "["
            ReturnValue = getValueFromExpression("[" + FragmentRaw, 1)
        
        Case ":"  ' :Object.property
            Splitted = Split(FragmentRaw, ".")
            ObjectID$ = Splitted(0)
            If ObjectID = "this" Then ObjectID = CurrentLocal.name: ToDebug "This=" & CurrentLocal.name
            ValueID = Splitted(1)
            VarOutp = getObject(ObjectID).Variables(ValueID)
            If Len(VarOutp) > Len("OBJID_") Then
                If Left(VarOutp, Len("OBJID_")) = "OBJID_" Then
                    ReturnValue = CallByName(AllControls(CInt(getObject(ObjectID).ControlCollection(Mid(VarOutp, 7)))), CStr(Splitted(2)), VbGet)
                Else
                    ReturnValue = VarOutp