Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/BASE_XP/CALC1.BAS

BASIC Source File | 1994-01-25 | 6.2 KB | 295 lines

Option Explicit
Const mt$ = ""
Const zero% = 0
Const one% = 1
Const two% = 2
Const plus$ = "+"
Const minus$ = "-"
Const times$ = "*"
Const div$ = "/"
Const oparen$ = "("
Const cparen$ = ")"
Const raise$ = "^"
Dim tokens$(1 To 7)      ' token symbols
Dim tprec%(1 To 7)       ' token precedence (higher is more important)
Dim vstack$(1 To 100)    ' value manipulation
Dim ostack$(1 To 100)    ' operand
Dim vtos%   ' stack pointer of value stack
Dim otos%   ' stack pointer of operand stack
Dim tstr$
Dim calcerr$

Sub clearstacks ()
Dim i%
For i = LBound(ostack) To UBound(ostack)
    ostack(i) = mt
Next
For i = LBound(vstack) To UBound(vstack)
    vstack(i) = mt
Next
initcalc
End Sub

Function eval$ (parseme$)
Dim tok$, orig$, otop$
orig = parseme
clearstacks
calcerr = mt
tok = lexx(parseme)
While tok <> mt
    Select Case tok
        Case oparen
            opush tok
        Case cparen
            opush tok
            reduce
        Case raise
            opush tok
        Case times
            opush tok
        Case div
            opush tok
        Case plus
            opush tok
        Case minus
            opush tok
        Case Else
            If IsNumeric(tok) Then
                vpush tok
            Else
                eval = "ERROR: Unrecognized token :" + parseme + ":"
                Exit Function
            End If
    End Select
    tok = lexx(parseme)
    If calcerr <> mt Then
        eval = calcerr
        Exit Function
    End If
Wend
reduce
If calcerr <> mt Then
    eval = calcerr
ElseIf vtos <> one Then
    eval = "Unable to reduce expression."
Else
' at this point, the top of stack should contain the value
eval = vpop()
End If
End Function

Function getprec% (tokval$)
' get token precedence
Dim i%
For i = one To UBound(tokens)
    If tokens(i) = tokval Then
        getprec = tprec(i)
        Exit Function
    End If
Next
getprec = 0
End Function

Sub initcalc ()
vtos = 0
otos = 0
tokens(1) = "("
tprec(1) = 3
tokens(2) = ")"
tprec(2) = 3
tokens(3) = "*"
tprec(3) = 2
tokens(4) = "/"
tprec(4) = 2
tokens(5) = "+"
tprec(5) = 1
tokens(6) = "-"
tprec(6) = 1
tokens(7) = "^"
tprec(7) = 4
tstr = "()*/+-^"
End Sub

Function lexx$ (parsexpr$)
Dim i%, w%, j%, cc$, pl%, hs%, wc$, ft$
hs = Len(parsexpr)
If parsexpr = mt Then
    lexx = mt
    Exit Function
End If
hs = Len(parsexpr)
ft = mt           ' find the FIRST token
For i = one To hs
    cc = Mid$(parsexpr, i, one)
    j = InStr(tstr, cc)
    If j Then
        ft = cc
        Exit For
    End If
Next
If ft <> mt Then
    w = InStr(parsexpr, ft)
    If w Then
        If w = one Then
            lexx = Left$(parsexpr, one)
            parsexpr = Trim$(Mid$(parsexpr, two))
        Else
            lexx = Trim$(Left$(parsexpr, w - one))
            parsexpr = Trim$(Mid$(parsexpr, w))
        End If
        Exit Function
    End If
End If
If IsNumeric(Trim$(parsexpr)) Then
    lexx = Trim$(parsexpr)
    parsexpr = mt
Else
    lexx = mt
    calcerr = "Unrecognized token at start of :" + parsexpr
End If
End Function

Function opop$ ()
If otos >= one Then
    opop = ostack(otos)
    ostack(otos) = mt
    otos = otos - one
Else
    opop = mt
End If
End Function

Sub opush (pval$)
Dim p1%, p2%
If pval = mt Then Exit Sub
If otos < UBound(ostack) Then
    If otos > zero Then
        p1 = getprec(pval)
        p2 = getprec(ostack(otos))
        If p2 > p1 Then
            reduce
        End If
    End If
    otos = otos + one
    ostack(otos) = pval
Else
    calcerr = "Operand Stack blown."
End If
End Sub

Sub reduce ()
Static pcount% ' paren reduction
Dim v1$, v2$, o1$
o1 = opop()
Select Case o1
    Case mt
        Exit Sub
    Case oparen
        If pcount = zero Then
            opush (o1)
            Exit Sub
        Else
            pcount = pcount - one
        End If
    Case cparen
        pcount = pcount + one
    Case raise
        v1 = vpop()
        v2 = vpop()
        If v1 = mt Or v2 = mt Then
            calcerr = "Expression error on operand ^"
            clearstacks
            Exit Sub
        End If
        On Error Resume Next
        vpush Trim$(Str$(Val(v2) ^ Val(v1)))
        If Err Then
            calcerr = "Arithmetic Overflow"
            clearstacks
            Exit Sub
        End If
        On Error GoTo 0

    Case times
        v1 = vpop()
        v2 = vpop()
        If v1 = mt Or v2 = mt Then
            calcerr = "Expression error on operand *"
            clearstacks
            Exit Sub
        End If
        On Error Resume Next
        vpush Trim$(Str$(Val(v1) * Val(v2)))
        If Err Then
            calcerr = "Arithmetic Overflow"
            clearstacks
            Exit Sub
        End If
        On Error GoTo 0

    Case div
        v1 = vpop()
        v2 = vpop()
        If v1 = mt Or v2 = mt Then
            calcerr = "Expression error on operand /"
            clearstacks
            Exit Sub
        End If
        If Val(v1) = zero Then
            calcerr = "Division by zero"
            clearstacks
            Exit Sub
        End If
        On Error Resume Next
        vpush Trim$(Str$(Val(v2) / Val(v1)))
        If Err Then
            calcerr = "Arithmetic Overflow"
            clearstacks
            Exit Sub
        End If
        On Error GoTo 0

    Case plus
        v1 = vpop()
        v2 = vpop()
        If v1 = mt Or v2 = mt Then
            calcerr = "Expression error on operand +"
            clearstacks
            Exit Sub
        End If
        vpush Trim$(Str$(Val(v2) + Val(v1)))

    Case minus
        v1 = vpop()
        v2 = vpop()
        If v1 = mt Or v2 = mt Then
            calcerr = "Expression error on operand -"
            clearstacks
            Exit Sub
        End If
        vpush Trim$(Str$(Val(v2) - Val(v1)))
End Select
reduce
End Sub

Function vpop$ ()
If vtos >= one Then
    vpop = vstack(vtos)
    vstack(vtos) = mt
    vtos = vtos - one
Else
    vpop = mt
End If
End Function

Sub vpush (pval$)
If pval = mt Then Exit Sub
If vtos < UBound(vstack) Then
    vtos = vtos + one
    vstack(vtos) = pval
Else
    calcerr = "Value Stack blown."
End If
End Sub