class.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public BaseClass As String
Public ControlCollection As New Dictionary
Public CurrentRunningMethod As String
Public MethodSignatures As New Dictionary
Public name As String
Public ReferenceLine As Long
Public ThisClassesForm As Object
Public Variables As New Dictionary

Private JumpPoints As New Dictionary

Private MethodParameters(9)
Private TempReturnvalue

Public Sub createMethodParameter(Number As Integer, Method As String, name As String)
    MethodSignatures.Add Method & "-" & name, Number
End Sub

Public Function getParameterContent(Method As String, parameterName As String)
    getParameterContent = MethodParameters(CInt(MethodSignatures(Method & "-" & parameterName)))
End Function

Public Sub setParameterContent(Number As Integer, newContent)
    MethodParameters(Number) = newContent
End Sub

Public Sub setParameterContents(P1, P2, P3, P4, P5, P6, P7, P8)
    If Not P1 = "" Then setParameterContent 1, P1
    If Not P2 = "" Then setParameterContent 2, P2
    If Not P3 = "" Then setParameterContent 3, P3
    If Not P4 = "" Then setParameterContent 4, P4
    If Not P5 = "" Then setParameterContent 5, P5
    If Not P6 = "" Then setParameterContent 6, P6
    If Not P7 = "" Then setParameterContent 7, P7
    If Not P8 = "" Then setParameterContent 8, P8
End Sub

Public Sub ExecuteVoid(RoutineName As String, P1, P2, P3, P4, P5, P6, P7, P8)
    CurrentRunningMethod = RoutineName
    setParameterContents P1, P2, P3, P4, P5, P6, P7, P8
    ToDebug "-->Executing void routine name " & RoutineName
    MethodFound = False
    ToDebug "-->Reference line is " & ReferenceLine
    For f& = ReferenceLine To Pointer
        If ProgramLines(f) = "<methods>" Then MethodFound = True
        If MethodFound = True And ProgramLines(f) = "method void " & RoutineName Then
            RawExecute CLng(f + 1)
            Exit Sub
        End If
        If ProgramLines(f) = "end class" Then Exit Sub
    Next f
End Sub

Public Sub ExecuteFunction(RoutineName As String, P1, P2, P3, P4, P5, P6, P7, P8)
    CurrentRunningMethod = RoutineName
    setParameterContents P1, P2, P3, P4, P5, P6, P7, P8
    ToDebug "-->Executing void routine name " & RoutineName
    MethodFound = False
    ToDebug "-->Reference line is " & ReferenceLine
    For f& = ReferenceLine To Pointer
        If ProgramLines(f) = "<methods>" Then MethodFound = True
        If MethodFound = True And ProgramLines(f) = "method function " & RoutineName Then
            RawExecute CLng(f + 1)
            Exit Sub
        End If
        If ProgramLines(f) = "end class" Then Exit Sub
    Next f
End Sub

Public Sub RawExecute(FromLine As Long, Optional ToLine = 65536)
    Set CurrentLocal = Me
    ToDebug "-->from line " & FromLine
    For f = FromLine To ToLine
        If ProgramLines(f) = "end method" Then Exit Sub
        XString = ProgramLines(f)
        If Left(XString, 1) = "(" Then
            XString = Mid(XString, 2)
            Do Until Right(XString, 1) = ")"
                f = f + 1
                XString = XString & SplitChar & ProgramLines(f)
            Loop
            XString = Left(XString, Len(XString) - 1)
        End If
        D = Split(XString, " ")
        Select Case D(0)
            Case "repeat"
                TempValue = Variables(D(1))
                ToDebug "!Repeat loop for variable " & D(1) & "=" & Variables(D(1))
                ToDebug "!Increment: " & getValueFromExpression(XString, 1)
                ToDebug "!Target: " & getValueFromExpression(XString, 2)
                Do Until Variables(D(1)) = getValueFromExpression(XString, 2)
                    RawExecute f + 1, f + 1
                    Variables(D(1)) = CInt(Variables(D(1))) + CInt(getValueFromExpression(XString, 1))
                Loop
                'SkipALine = True
                Variables(D(1)) = TempValue
                                        
            Case "anchor"
                JumpPoints(D(1)) = f
                                        
            Case "step"
                f = JumpPoints(D(1))
               
            Case "do"
                JumpPoints(D(1)) = f
                Variables(D(1)) = getValueFromExpression(XString, 1)
                ToDebug "DO " & Variables(D(1))
            
            Case "while"
                ToDebug "LOOP " & Variables(D(1))
                Variables(D(1)) = CDbl(Variables(D(1))) + _
                    getValueFromExpression(XString, 1)
                If Not Variables(D(1)) = getValueFromExpression(XString, 2) Then
                    f = JumpPoints(D(1))
                End If
                
            Case Else
            Interprete CStr(XString), Me
            If SkipALine = True Then
                SkipALine = False
                f = f + 1
                If Left(ProgramLines(f), 1) = "(" Then
                    Do Until Right(ProgramLines(f), 1) = ")"
                        f = f + 1
                    Loop
                End If
            End If
        End Select
    Next f
End Sub