module1.bas

编译原理课程设计用vb编写

Attribute VB_Name = "Module1"
Public globalCV As New clsVar

Public fMainForm As frmMain
Public globalSource As String
Public Const EM_SCROLLCARET = &HB7
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const KEYWORDS As String = "stop,case else,end select,exit for,exit do,elseif ,do while ,end if,select case ,loop until ,print ,input ,if ,for ,next,gosub ,return,while ,wend,end,else,loop,case ,end,do,goto ,gosub "
Public Const KEYWORD As String = "mod,xor,abs,sqr,stop,if,else,elseif,for,next,to,end,and,or,not,exit,print,step,while,wend,select,case,input,do,loop,until,goto,gosub,return,and,or,not,then"

Public ErrLine As Long      '出错位置
Public globalVars As Collection
Public globalPause As New Collection
Public runFlag As Boolean

Public flagChange As Boolean
Public globalFileName As String
Public globalln As Long
'记录frmVars的窗口坐标
Public frmVars_top As Long
Public frmVars_left As Long


Sub Main()
    If Command = "" Then
        Set fMainForm = New frmMain
        Load fMainForm
        fMainForm.Show
    Else
        Set fMainForm = New frmMain
        Load fMainForm
        fMainForm.Show
        fMainForm.txtSource.Text = fMainForm.FileRead(Command)
        globalFileName = Command
        flagChange = False
        'MsgBox "@" & Command & "@"
        'End
    End If
End Sub

Public Sub BanAdd(ByVal Item As Integer)
    For i = 1 To globalPause.Count
        If globalPause(i) = Item Then Exit Sub
    Next
    globalPause.Add Item
End Sub

Public Sub BanDel(ByVal Item As Integer)
    For i = 1 To globalPause.Count
        If globalPause(i) = Item Then
            globalPause.Remove i
            Exit For
        End If
    Next
End Sub

Public Sub BanClear()
    While globalPause.Count > 0
        globalPause.Remove 1
    Wend
End Sub

Public Function BanHave(ByVal Item As Integer) As Boolean
    For i = 1 To globalPause.Count
        If globalPause(i) = Item Then
            BanHave = True
            Exit Function
        End If
    Next
    BanHave = False
End Function

Public Function inArray(ss() As String, ByVal s As String)
    For Each i In ss
        If i = s Then
            inArray = True
            Exit Function
        End If
    Next
    inArray = False
End Function

Public Function InstrPlus(ByVal s As String, ByVal strin As String)
    '增强版的instr函数，能忽略双引号内的内容
    On Error Resume Next
    Dim ts As String
    Dim Count As Integer
    If s = "" Or strin = "" Then
        InstrPlus = 0
        Exit Function
    End If
    strin = LCase(strin)
    Count = 1
    For i = 1 To Len(s)
        c = Mid(s, i, 1)
        If c = """" Then
            If InStr(ts, """") = 0 Then
                ts = ts & """"
            Else
                ts = Mid(ts, 1, InStrRev(ts, """") - 1)
            End If
        Else
            If ts = "" Then
                If c = Mid(strin, Count, 1) Then
                    Count = Count + 1
                    If Count = Len(strin) + 1 Then
                        InstrPlus = i - Len(strin) + 1
                        Exit Function
                    End If
                Else
                    Count = 1
                End If
            End If
        End If
    Next
    If ts <> "" Then
        Err.Raise 202, , "表达式" & s & "错误"
        Exit Function
    End If
    InstrPlus = 0
End Function

Public Function ReplacePlus(ByVal s As String, ByVal ss As String, ByVal sd As String)
    If InStr(sd, ss) > 0 Then
        Err.Raise 333, , "不能替换"
        Exit Function
    End If
    Do While InstrPlus(s, ss) > 0
        s = Left(s, InstrPlus(s, ss) - 1) & sd & Mid(s, InstrPlus(s, ss) + Len(ss), Len(s))
    Loop
    ReplacePlus = s
End Function


Public Function FindBorder(ByVal s As String)
    '增强版的instrplus函数，能忽略括号内和双引号内的内容,寻找;或者,
    Dim ts As String
    If s = "" Then
        Exit Function
    End If
    For i = 1 To Len(s)
        c = Mid(s, i, 1)
        If c = "(" Then
            ts = ts + c
        ElseIf c = ")" Then
            If InStr(ts, "(") = 0 Then
                Err.Raise 201, , "表达式错误：缺少左括号"
                Exit Function
            End If
            ts = Mid(ts, 1, InStrRev(ts, "(") - 1)
        ElseIf c = """" Then
            If InStr(ts, """") = 0 Then
                ts = ts & """"
            Else
                ts = Mid(ts, 1, InStrRev(ts, """") - 1)
            End If
        Else
            If ts = "" And (c = "," Or c = ";") Then
                FindBorder = i
                Exit Function
            End If
        End If
    Next
    If ts <> "" Then
        Err.Raise 202, , "表达式" & s & "错误"
        Exit Function
    End If
    FindBorder = 0
End Function

Public Function FormatPlus(ByVal s As String)
    Dim cs As New clsSen
    cs.strText = LcasePlus(s)
    If Trim(s) = "" Then
        FormatPlus = s
        Exit Function
    End If
    
    Do
        rw1 = cs.ReadWord
        If rw1 = "(" Or cs.LookNextWord = ")" Or cs.LookNextWord = ";" Or cs.LookNextWord = "," Then
            rw = rw & rw1
        Else
            rw = rw & rw1 & " "
        End If
        If Err.Number > 0 Then
            FormatPlus = s
            Err.Clear
            Exit Function
        End If
    Loop While Not cs.Eof
    If rw <> "" Then rw = Left(rw, Len(rw) - 1)
    rw = ReplacePlus(rw, "< >", "<>")
    rw = ReplacePlus(rw, "< =", "<=")
    rw = ReplacePlus(rw, "> =", ">=")
    s = rw
    Dim ss() As String
    ss = Split(s, """")
    If UBound(ss) Mod 2 = 1 Then
        FormatPlus = s
    Else
        For i = 0 To UBound(ss)
            kw = Split(KEYWORD, ",")
            ssi = LCase(ss(i))
            For j = 0 To UBound(kw)
                ssi = " " & ssi & " "
                ssi = Replace(ssi, " " & kw(j) & " ", " " & UCase(Left(kw(j), 1)) & Right(kw(j), Len(kw(j)) - 1) & " ")
                ssi = Mid(ssi, 2, Len(ssi) - 2)
            Next
            r = r & IIf(i Mod 2 = 0, ssi, ss(i))
            If i <> UBound(ss) Then r = r & """"
        Next
        FormatPlus = r
    End If
End Function

Public Function LcasePlus(s)
    Dim ss() As String
    ss = Split(s, """")
    If UBound(ss) Mod 2 = 1 Then
        LcasePlus = s
    Else
        For i = 0 To UBound(ss)
            r = r & IIf(i Mod 2 = 0, LCase(ss(i)), ss(i))
            If i <> UBound(ss) Then r = r & """"
        Next
        LcasePlus = r
    End If
End Function