clscode.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 = "clsCode"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private strSourceCode As String             '源代码
Private Lines() As New clsLine              '按行存放源代码的数组
Private iline As Integer                    '存入数组时用的临时变量
Private ce As New clsExpPlus                    '表达式处理模块

Public Function Init(ByVal sCode As String)
    strSourceCode = sCode
    strSourceCode = LcasePlus(strSourceCode)          '大小写合并
End Function

Public Function Run()
    '预处理
    On Error Resume Next
    globalCV.Clear              '清空变量表
    iline = 0                   '计数器置0
    
    '第一遍：源代码读入数组
    Dim tmpExp As String
    Dim icount As Integer
    For Each i In Split(strSourceCode, vbCrLf)
        icount = icount + 1
        If Trim(i) <> "" Then
            iline = iline + 1
            ReDim Preserve Lines(iline)
            Lines(iline).phLine = icount
            Lines(iline).strText = Trim(i)
            '处理内部行号
            If IsNumeric(Split(Lines(iline).strText, " ")(0)) Then
                Lines(iline).vLine = Split(Lines(iline).strText, " ")(0)
                Lines(iline).strText = Trim(Mid(Lines(iline).strText, InStr(i, " "), Len(Lines(iline).strText)))
            End If
            '忽略注释
            If InstrPlus(Lines(iline).strText, "'") > 0 Then
                Lines(iline).strText = Left(Lines(iline).strText, InstrPlus(Lines(iline).strText, "'") - 1)
            End If
            If Err.Number > 0 Then
                ErrLine = icount
                Exit Function
            End If
            '把制表符换成空格
            Lines(iline).strText = Trim(Replace(Lines(iline).strText, Chr(9), "    "))
            '预加工逻辑上不规范的语句
            'if logic then exp1
            'if logic then exp1 else exp2
            If Lines(iline).Head = "if" Or Lines(iline).Body = "if" Then
                sen = Lines(iline).strText
                If InstrPlus(LCase(sen), "then") = 0 Then
                    ErrLine = icount
                    Err.Raise 301, , "If缺少Then"
                    Exit Function
                End If
                tmpExp = Lines(iline).Body
                tmplogic = Trim(Left(tmpExp, InstrPlus(tmpExp, "then") - 1))
                If Len(sen) - InstrPlus(sen, "then") = 3 Then
                    'if logic then
                ElseIf InstrPlus(sen, "else") > 0 Then
                    'if logic then exp1 else exp2
                    exp1 = Trim(Mid(tmpExp, InstrPlus(tmpExp, "then") + 4, Len(tmpExp)))
                    exp2 = Trim(Right(exp1, Len(exp1) - InstrPlus(exp1, "else") - 3))
                    exp1 = Trim(Left(exp1, InstrPlus(exp1, "else") - 1))
                    Lines(iline).strText = "if " & tmplogic & " then"
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = exp1
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = "else"
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = exp2
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = "end if"
                Else
                    'if logic then exp1
                    exp1 = Trim(Mid(tmpExp, InstrPlus(tmpExp, "then") + 4, Len(tmpExp)))
                    Lines(iline).strText = "if " & tmplogic & " then"
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = exp1
                    iline = iline + 1
                    ReDim Preserve Lines(iline)
                    Lines(iline).phLine = icount
                    Lines(iline).strText = "end if"
                End If
            ElseIf Lines(iline).Head = "input" Then
                'input "x",x;y
                tmpExp = Lines(iline).Body
                
                If Right(tmpExp, 1) = ";" Or Right(tmpExp, 1) = "," Then
                    bd = Right(tmpExp, 1)
                    tmpExp = Left(tmpExp, Len(tmpExp) - 1)
                Else
                    bd = vbCrLf
                End If
                
                If FindBorder(tmpExp) > 0 Then
                    'Exit Do
                    Lines(iline).strText = "input " & Left(tmpExp, FindBorder(tmpExp) - 1)
                    tmpExp = Trim(Mid(tmpExp, FindBorder(tmpExp) + 1, Len(tmpExp)))

                    Do While FindBorder(tmpExp) > 0
                        iline = iline + 1
                        ReDim Preserve Lines(iline)
                        Lines(iline).phLine = icount
                        Lines(iline).strText = "input " & Left(tmpExp, FindBorder(tmpExp) - 1)
                        tmpExp = Trim(Mid(tmpExp, FindBorder(tmpExp) + 1, Len(tmpExp)))
                    Loop
                    
                    If tmpExp <> "" Then
                        iline = iline + 1
                        ReDim Preserve Lines(iline)
                        Lines(iline).phLine = icount
                        Lines(iline).strText = "input " & tmpExp
                    End If
                End If
            ElseIf Lines(iline).Head = "while" Then
                    tmpExp = Lines(iline).Body
                    Lines(iline).strText = "do while " & tmpExp
            ElseIf Lines(iline).Head = "wend" Then
                    Lines(iline).strText = "loop"
            End If
        End If
    Next
    '第二遍：预处理- Select Case语句变If ..ElseIf .. 格式
    Dim skSelect As New clsStack        'select case ... (case ...) ...end select 栈
    For i = 1 To UBound(Lines)
        ErrLine = Lines(i).phLine
        If Lines(i).Head = "select case" Then
            If i = UBound(Lines) Then
                Err.Raise 350, , "Select Case后面必须是Case"
                Exit Function
            End If
            If Lines(i + 1).Head <> "case" Then
                Err.Raise 351, , "Select Case后面必须是Case"
                Exit Function
            End If
            skSelect.Push Lines(i).Body
            Lines(i).strText = "select case "
        ElseIf Lines(i).Head = "case" Then
            tmpExp = Lines(i).Body
            If skSelect.Count = 0 Then
                Err.Raise 352, , "Case没有Select Case"
                Exit Function
            End If
            tl = skSelect.Item(0)
            If Lines(i - 1).Head = "select case" Then
                ad = "if "
            Else
                ad = "elseif "
            End If
            If InstrPlus(tmpExp, " to ") > 0 Then
                'exp1 to exp2
                exp1 = Trim(Left(tmpExp, InstrPlus(tmpExp, " to ")))
                exp2 = Trim(Mid(tmpExp, InstrPlus(tmpExp, " to ") + 3, Len(tmpExp)))
                rexp = ad & tl & ">=" & exp1 & " and " & tl & "<=" & exp2
            Else
                'exp[,exp2,...expn]
                If InStr(tmpExp, """") > 0 Then
                    Err.Raise 353, , "Case后面暂时不支持字符串"
                    Exit Function
                End If
                rexp = ad
                For Each ei In Split(tmpExp, ",")
                    rexp = rexp & tl & "=" & ei & " or "
                Next
                rexp = Left(rexp, Len(rexp) - 4)
            End If
            Lines(i).strText = rexp & " then"
        ElseIf Lines(i).Head = "case else" Then
            Lines(i).strText = "else"
        ElseIf Lines(i).Head = "end select" Then
            Lines(i).strText = "end if"
            If skSelect.Count = 0 Then
                Err.Raise 352, , "End Select没有Select Case"
                Exit Function
            End If
            skSelect.Pop
        End If
    Next
    If skSelect.Count > 0 Then
        Err.Raise 353, , "Select没有End Select"
        Exit Function
    End If
    '第三遍：预处理- 展开If ...ElseIf...End If成为嵌套形式
    Dim Lines1() As New clsLine
    Dim skElseif As New clsStack
    ReDim Preserve Lines1(0)
    i1 = 0
    For i = 1 To UBound(Lines)
        With Lines(i)
            ErrLine = .phLine
            If Trim(.strText <> "") Then
                i1 = i1 + 1
                Select Case .Head
                    Case "if"
                        skElseif.Push i & " 1"
                        
                        ReDim Preserve Lines1(i1)
                        Lines1(i1).strText = .strText
                        Lines1(i1).vLine = .vLine
                        Lines1(i1).phLine = .phLine
                        
                    Case "end if"
                        If skElseif.Count = 0 Then
                            Err.Raise 362, , "End If没有If"
                            Exit Function
                        End If
                        ts = Split(skElseif.Item(0), " ")
                        i1 = i1 - 1
                        For k = 1 To Int(ts(1))
                            i1 = i1 + 1
                            ReDim Preserve Lines1(i1)
                            Lines1(i1).strText = "end if"
                            Lines1(i1).vLine = .vLine
                            Lines1(i1).phLine = .phLine
                        Next
                    Case "elseif"
                        If skElseif.Count = 0 Then
                            Err.Raise 361, , "Else If没有If"
                            Exit Function
                        End If
                        ts = Split(skElseif.Pop, " ")
                        skElseif.Push ts(0) & " " & CStr(CInt(ts(1)) + 1)
                        
                        ReDim Preserve Lines1(i1)
                        Lines1(i1).strText = "else"
                        Lines(i1).vLine = .vLine
                        Lines(i1).phLine = .phLine
                        i1 = i1 + 1
                        ReDim Preserve Lines1(i1)
                        Lines1(i1).strText = "if " & .Body
                        Lines1(i1).vLine = .vLine
                        Lines1(i1).phLine = .phLine
                    Case Else
                        ReDim Preserve Lines1(i1)
                        Lines1(i1).strText = .strText
                        Lines1(i1).vLine = .vLine
                        Lines1(i1).phLine = .phLine
                End Select
            End If
        End With
    Next
    Lines = Lines1
    
    

    'For i = 1 To UBound(Lines)
    '    Debug.Print Lines(i).strText
    'Next
    'Exit Function
    
    '第四遍：预处理- 把代码行抽象成图的节点，并给这些节点建立联系
    Dim sk1 As New clsStack             'if ...(else)...end if栈
    Dim skFor As New clsStack           'for ...(exit for)...next 栈
    Dim skWhile As New clsStack         'while ...(exit do)... wend 栈
    Dim skDo As New clsStack            'do ...(exit do)... loop until 栈
    
    For i = 1 To UBound(Lines)
        ErrLine = Lines(i).phLine
        Select Case Lines(i).Head
            Case ""
                'ce.exp Lines(i).strText
            Case "if"
                'if_else_id
                sk1.Push i
            Case "else"
                'else_if
                If sk1.Count > 0 Then
                    tmp = sk1.Item(0)
                    Lines(i).else_if_id = tmp
                    Lines(tmp).if_else_id = i
                Else
                    Err.Raise 601, , "Else没有If"
                    Exit Function
                End If
            Case "end if"
                If sk1.Count > 0 Then
                    tmp = sk1.Pop
                    Lines(tmp).if_endif_id = i
                Else
                    Err.Raise 602, , "End If没有If"
                    Exit Function
                End If
            Case "for"
                skFor.Push i
            Case "exit for"
                If skFor.Count > 0 Then
                    tmp = skFor.Item(0)
                    Lines(i).exitfor_for_id = tmp
                Else
                    Err.Raise 300, , "Exit For不在循环体内"
                    Exit Function
                End If
            Case "next"
                If skFor.Count > 0 Then
                    tmp = skFor.Pop
                    Lines(i).next_for_id = tmp
                    Lines(tmp).for_next_id = i
                Else
                    Err.Raise 302, , "Next没有For"
                    Exit Function
                End If