cexpression.cls

運動會或各式活動秩序冊製作及檢錄表製作管理系統

        Else
    
            ' we are expecting an operator
    
            ' remember which character comes before this one
            temp = Mid$(expr$, Index - 1, 1)
            ' search the opcode
            opcode = OperatorOpcode(expr, Index)
            If opcode = opUnknown Then GoTo CompileExprUnknownOperator
            
            If opcode = opAnd Or opcode = opOr Or opcode = opXor Or opcode = opMod Then
                ' a few binary operators must be preceeded by a space or a ")"
                ' and must be followed by a space or a "("
                If InStr(" )", temp) = 0 Then
                    GoTo CompileExprSyntaxError
                ElseIf InStr(" (", Mid$(expr$, Index, 1)) = 0 Then
                    GoTo CompileExprSyntaxError
                End If
            End If
    
            ' if it was not a ")" we must prepare to get an operand
            If opcode <> opCloseBracket Then waitForOperator = False
    
            '---------------------------------------------------------------------
            ' this portion of the routine compares the priority of the
            ' operator just parsed with the priority of other operators
            ' pending in opStack()
            ' As long as the priority of current operator or function is
            ' greater than the priority of the operator/function on top of
            ' opStack(), the latter must be popped off the stack and executed
            ' 255 is the highest priority, assigned to the "(" and the
            ' "start-of-expression" state; the test in the DO WHILE command
            ' prevents from popping too many items off the OPstack
            '---------------------------------------------------------------------
            
            Do While opPriority(opcode) <= opPriority(opStack(opSp)) And opPriority(opStack(opSp)) <> 255
                AppendToCompiled opStack(opSp)
                ' adjust the stack pointer
                If opNumArgs(opStack(opSp)) > 0 Then
                    ' this is a function
                    sp = sp - opNumArgs(opStack(opSp)) + 1
                ElseIf opStack(opSp) >= opFirst_BinaryOperator Then
                    ' this is a binary operator
                    sp = sp - 1
                End If
                ' pop the operator off the stack
                opSp = opSp - 1
                ' check that the expression is well-balanced
                If opSp < 0 Or sp <= 0 Then GoTo CompileExprSyntaxError
            Loop
    
            ' if the opcode terminates an operand
            If opNumArgs(opcode) = -1 Then
                argStack(argSp) = argStack(argSp) - 1
                If argStack(argSp) < 0 Then GoTo CompileExprWrongArgs
            End If
            
            ' A few opcodes need special treatment
                 
            Select Case opcode
                Case opEnd
                    If opSp <> 1 Then GoTo CompileExprSyntaxError
                    If argStack(argSp) <> 0 Then GoTo CompileExprWrongArgs
                    ReDim Preserve compOpcodes(compItems)
                    ReDim Preserve compValues(compItems)
                    m_ErrorPos = 0
                    Exit Sub
                Case opCloseBracket
                    If opStack(opSp) <> opOpenBracket Then GoTo CompileExprSyntaxError
                    If argStack(argSp) <> 0 Then GoTo CompileExprWrongArgs
                    ' pop the "(" off the stack
                    opSp = opSp - 1
                    argSp = argSp - 1
                Case opComma
                    If argStack(argSp) = 0 Then GoTo CompileExprWrongArgs
                    waitForOperator = False
                Case Else
                    ' all other opcodes must be pushed onto opStack ()
                    GoSub CompileExprPushOpcode
            End Select
        End If
    
    Loop
    
    ' this line is never executed ...

    '---------------------------------------------------------------------
    '   Subroutines
    '---------------------------------------------------------------------
                    
CompileExprPushOpcode:
    opSp = opSp + 1
    opStack(opSp) = opcode
    If opNumArgs(opcode) > 0 Then
        argSp = argSp + 1
        argStack(argSp) = opNumArgs(opcode)
        waitForOperator = False
    End If
    Return

CompileExprSyntaxError:
    m_ErrorCode = expSyntaxError
    m_ErrorDescription = "Syntax Error" & m_ErrorDescription
    Exit Sub

CompileExprUnknownFunction:
    m_ErrorCode = expUnknownFunction
    m_ErrorDescription = "Unknown function" & m_ErrorDescription
    Exit Sub

CompileExprWrongArgs:
    m_ErrorCode = expWrongNumberOfArguments
    m_ErrorDescription = "Wrong number of arguments for " & opNames(opStack(opSp - 1))
    Exit Sub

CompileExprUnknownOperator:
    m_ErrorCode = expUnknownOperator
    m_ErrorDescription = "Unknown operator" & m_ErrorDescription
    Exit Sub
    
End Sub

' append to the compiled expression
' (support routine for CompileExpression)

Private Sub AppendToCompiled(ByVal opcode As Integer, Optional Value As Variant)
    compItems = compItems + 1
    compOpcodes(compItems) = opcode
    If IsMissing(Value) Then
        ' do nothing
    ElseIf IsObject(Value) Then
        Set compValues(compItems) = Value
    Else
        compValues(compItems) = Value
    End If
End Sub

' move index past all blanks
' (support routine for CompileExpression)

Private Sub SkipBlanks(expr As String, Index As Long)
    Do While Asc(Mid$(expr, Index, 1)) = 32
        Index = Index + 1
    Loop
End Sub

' move index past a number and return the value
' (support routine for CompileExpression)

Private Function GetNumber(expr As String, Index As Long) As Variant
    Dim startIndex As Long, isDecimal As Boolean, number As String
    Dim digits As String
    
    digits = "0123456789"
    startIndex = Index
    
    ' this extracts the integer part
    Do While InStr(digits, Mid$(expr, Index, 1))
        Index = Index + 1
    Loop
    ' skip past the decimal part, if any
    If Mid$(expr$, Index, 1) = "." Then
        isDecimal = True
        Do
            Index = Index + 1
        Loop While InStr(digits, Mid$(expr, Index, 1))
    End If
    ' skip the exponent, if any
    If InStr("EeDd", Mid$(expr$, Index, 1)) Then
        Index = Index + 1
        If InStr("+-", Mid$(expr$, Index, 1)) Then Index = Index + 1
        Do While InStr(digits, Mid$(expr, Index, 1))
            Index = Index + 1
        Loop
    End If
    
    number = Mid$(expr, startIndex, Index - startIndex)
    If isDecimal Then
        GetNumber = Val(number)
    Else
        GetNumber = CLng(number)
    End If
End Function

' move index past an alphanumerical string and return the value
' (support routine for CompileExpression)

Private Function GetName(expr As String, Index As Long) As String
    Dim startIndex As Long, acode As Integer
    
    startIndex = Index
    Index = Index - 1
    Do
        Index = Index + 1
        acode = Asc(Mid$(expr, Index, 1))
        ' skip over digits, underscore, upper & lower characters
    Loop While (acode >= 48 And acode <= 57) Or (acode >= 65 And acode <= 90) Or (acode >= 97 And acode <= 122) Or acode = 95
        
    GetName = Mid$(expr, startIndex, Index - startIndex)
    SkipBlanks expr, Index
End Function

#If SupportStrings Then
' move index past a string constant and return the value
' (support routine for CompileExpression)

Private Function GetString(expr As String, Index As Long) As String
    Dim startIndex As Long
    Dim exprLen As Long
    Dim delimiter As Integer
    Dim mustFilter As Boolean
    Dim result As String
    Dim i As Long
    
    startIndex = Index
    delimiter = Asc(Mid$(expr, Index, 1))
    exprLen = Len(expr)
    
    Do
        Index = Index + 1
        If Index = exprLen Then
            ' exit if delimiter not found
            m_ErrorCode = expSyntaxError
            m_ErrorDescription = ": missing string delimiter"
            Exit Function
        ElseIf Asc(Mid$(expr, Index, 1)) = delimiter Then
            Index = Index + 1
            If Asc(Mid$(expr, Index, 1)) <> delimiter Then Exit Do
            mustFilter = True
        End If
    Loop

    result = Mid$(expr, startIndex + 1, Index - startIndex - 2)
    
    If mustFilter Then
        i = InStr(result, Chr$(delimiter))
        Do While i <> 0
            result = Left$(result, i) & Mid$(result, i + 2)
            i = InStr(i + 1, result, Chr$(delimiter))
        Loop
    End If
    
    GetString = result
End Function
#End If

' return the opcode of a function, or opUnknown if not a valid name
' (support routine for CompileExpression)

Private Function FunctionOpcode(funName As String) As expOpcodes
    Dim i As Long
    
    For i = opFirst_Function To opLast_Opcode
        If funName = opNames(i) Then
            FunctionOpcode = i
            Exit Function
        End If
    Next
    ' if the above search failed
    If funName = "NOT" Then
        FunctionOpcode = opNot
    Else
        FunctionOpcode = opUnknown
    End If
End Function

' return the opcode of an operator, or opUnknown if not a valid name
' (support routine for CompileExpression)

Private Function OperatorOpcode(expr As String, Index As Long) As expOpcodes
    Dim i As Long
    
    For i = opEnd To opFirst_Function - 1
        If InStr(Index, expr, opNames(i), vbTextCompare) = Index Then
            OperatorOpcode = i
            Index = Index + Len(opNames(i))
            Exit Function
        End If
    Next
    
    OperatorOpcode = opUnknown
    
End Function

' evaluate the expression using its compiled form
' it is possible to pass the value of all or part of the variables
Function Value(ParamArray vars() As Variant) As Variant
    On Error GoTo ValueError
    Dim Index As Long, sp As Integer
    Dim Tos As Variant
    Dim stak(1 To STACK_SIZE) As Variant

    ' don't evaluate empty or uncorrect expressions
    If m_Expression = "" Or m_ErrorCode Then Exit Function
    
    ' assign values to variables
    For Index = LBound(vars) To UBound(vars)
        If Index >= m_Variables.Count Then Exit For
        m_Variables(Index + 1).Value = vars(Index)
    Next

    ' to raise errors in the calling application
    ' we just need not to trap errors in this function
    'If Not RaiseErrors Then
        'On Error GoTo ValueError
    'End If
    
    ' prepare the default value, in case an error occurs
    Value = DefaultValue

    For Index = 1 To compItems
        Select Case compOpcodes(Index)
            Case opValue
                ' is a value
                ' (if it is a variable, its value is used automatically)
                sp = sp + 1
                stak(sp) = Tos
                Tos = compValues(Index)
            Case opPower
                Tos = stak(sp) ^ Tos
                sp = sp - 1
            Case opMul
                Tos = stak(sp) * Tos
                sp = sp - 1
            Case opDiv
                If Tos <> 0 Then
                  Tos = stak(sp) / Tos
                  sp = sp - 1
                Else
                  ' errmsg = "Division by zero"
                  ' Value = "Division by zero" ' DefaultValue
                   m_ErrorCode = expInvalidInputforFunction
                   m_ErrorDescription = "Division by zero"
                   Error = m_ErrorCode
                  'Exit Function
                End If
            Case opIntDiv
            
            If Tos <> 0 Then
                  Tos = stak(sp) \ Tos
                  sp = sp - 1
                Else
                'errmsg = "Division by zero"
                  'Value = "Division by zero" ' DefaultValue
                  m_ErrorCode = expInvalidInputforFunction
                  m_ErrorDescription = "Division by zero"
                  Error = m_ErrorCode

                  'Exit Function
                End If

            
                'Tos = stak(sp) \ Tos
                'sp = sp - 1
            Case opMod
                Tos = stak(sp) Mod Tos
                sp = sp - 1
            Case opAdd
                Tos = stak(sp) + Tos
                sp = sp - 1
            Case opSub
                Tos = stak(sp) - Tos
                sp = sp - 1
            Case opEq
                Tos = stak(sp) = Tos
                sp = sp - 1
            Case opLt
                Tos = stak(sp) < Tos
                sp = sp - 1
            Case opLe
                Tos = stak(sp) <= Tos
                sp = sp - 1
            Case opGt
                Tos = stak(sp) > Tos
                sp = sp - 1
            Case opGe
                Tos = stak(sp) >= Tos
                sp = sp - 1
            Case opNe
                Tos = stak(sp) <> Tos
                sp = sp - 1
            Case opMinus
                Tos = -Tos
            Case opNot
                Tos = Not Tos
            Case opAnd
                Tos = stak(sp) And Tos
                sp = sp - 1
            Case opOr