home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / vb_code1 / base_xp / calc1.bas < prev    next >
BASIC Source File  |  1994-01-25  |  6KB  |  295 lines

  1. Option Explicit
  2. Const mt$ = ""
  3. Const zero% = 0
  4. Const one% = 1
  5. Const two% = 2
  6. Const plus$ = "+"
  7. Const minus$ = "-"
  8. Const times$ = "*"
  9. Const div$ = "/"
  10. Const oparen$ = "("
  11. Const cparen$ = ")"
  12. Const raise$ = "^"
  13. Dim tokens$(1 To 7)      ' token symbols
  14. Dim tprec%(1 To 7)       ' token precedence (higher is more important)
  15. Dim vstack$(1 To 100)    ' value manipulation
  16. Dim ostack$(1 To 100)    ' operand
  17. Dim vtos%   ' stack pointer of value stack
  18. Dim otos%   ' stack pointer of operand stack
  19. Dim tstr$
  20. Dim calcerr$
  21.  
  22. Sub clearstacks ()
  23. Dim i%
  24. For i = LBound(ostack) To UBound(ostack)
  25.     ostack(i) = mt
  26. Next
  27. For i = LBound(vstack) To UBound(vstack)
  28.     vstack(i) = mt
  29. Next
  30. initcalc
  31. End Sub
  32.  
  33. Function eval$ (parseme$)
  34. Dim tok$, orig$, otop$
  35. orig = parseme
  36. clearstacks
  37. calcerr = mt
  38. tok = lexx(parseme)
  39. While tok <> mt
  40.     Select Case tok
  41.         Case oparen
  42.             opush tok
  43.         Case cparen
  44.             opush tok
  45.             reduce
  46.         Case raise
  47.             opush tok
  48.         Case times
  49.             opush tok
  50.         Case div
  51.             opush tok
  52.         Case plus
  53.             opush tok
  54.         Case minus
  55.             opush tok
  56.         Case Else
  57.             If IsNumeric(tok) Then
  58.                 vpush tok
  59.             Else
  60.                 eval = "ERROR: Unrecognized token :" + parseme + ":"
  61.                 Exit Function
  62.             End If
  63.     End Select
  64.     tok = lexx(parseme)
  65.     If calcerr <> mt Then
  66.         eval = calcerr
  67.         Exit Function
  68.     End If
  69. Wend
  70. reduce
  71. If calcerr <> mt Then
  72.     eval = calcerr
  73. ElseIf vtos <> one Then
  74.     eval = "Unable to reduce expression."
  75. Else
  76. ' at this point, the top of stack should contain the value
  77. eval = vpop()
  78. End If
  79. End Function
  80.  
  81. Function getprec% (tokval$)
  82. ' get token precedence
  83. Dim i%
  84. For i = one To UBound(tokens)
  85.     If tokens(i) = tokval Then
  86.         getprec = tprec(i)
  87.         Exit Function
  88.     End If
  89. Next
  90. getprec = 0
  91. End Function
  92.  
  93. Sub initcalc ()
  94. vtos = 0
  95. otos = 0
  96. tokens(1) = "("
  97. tprec(1) = 3
  98. tokens(2) = ")"
  99. tprec(2) = 3
  100. tokens(3) = "*"
  101. tprec(3) = 2
  102. tokens(4) = "/"
  103. tprec(4) = 2
  104. tokens(5) = "+"
  105. tprec(5) = 1
  106. tokens(6) = "-"
  107. tprec(6) = 1
  108. tokens(7) = "^"
  109. tprec(7) = 4
  110. tstr = "()*/+-^"
  111. End Sub
  112.  
  113. Function lexx$ (parsexpr$)
  114. Dim i%, w%, j%, cc$, pl%, hs%, wc$, ft$
  115. hs = Len(parsexpr)
  116. If parsexpr = mt Then
  117.     lexx = mt
  118.     Exit Function
  119. End If
  120. hs = Len(parsexpr)
  121. ft = mt           ' find the FIRST token
  122. For i = one To hs
  123.     cc = Mid$(parsexpr, i, one)
  124.     j = InStr(tstr, cc)
  125.     If j Then
  126.         ft = cc
  127.         Exit For
  128.     End If
  129. Next
  130. If ft <> mt Then
  131.     w = InStr(parsexpr, ft)
  132.     If w Then
  133.         If w = one Then
  134.             lexx = Left$(parsexpr, one)
  135.             parsexpr = Trim$(Mid$(parsexpr, two))
  136.         Else
  137.             lexx = Trim$(Left$(parsexpr, w - one))
  138.             parsexpr = Trim$(Mid$(parsexpr, w))
  139.         End If
  140.         Exit Function
  141.     End If
  142. End If
  143. If IsNumeric(Trim$(parsexpr)) Then
  144.     lexx = Trim$(parsexpr)
  145.     parsexpr = mt
  146. Else
  147.     lexx = mt
  148.     calcerr = "Unrecognized token at start of :" + parsexpr
  149. End If
  150. End Function
  151.  
  152. Function opop$ ()
  153. If otos >= one Then
  154.     opop = ostack(otos)
  155.     ostack(otos) = mt
  156.     otos = otos - one
  157. Else
  158.     opop = mt
  159. End If
  160. End Function
  161.  
  162. Sub opush (pval$)
  163. Dim p1%, p2%
  164. If pval = mt Then Exit Sub
  165. If otos < UBound(ostack) Then
  166.     If otos > zero Then
  167.         p1 = getprec(pval)
  168.         p2 = getprec(ostack(otos))
  169.         If p2 > p1 Then
  170.             reduce
  171.         End If
  172.     End If
  173.     otos = otos + one
  174.     ostack(otos) = pval
  175. Else
  176.     calcerr = "Operand Stack blown."
  177. End If
  178. End Sub
  179.  
  180. Sub reduce ()
  181. Static pcount% ' paren reduction
  182. Dim v1$, v2$, o1$
  183. o1 = opop()
  184. Select Case o1
  185.     Case mt
  186.         Exit Sub
  187.     Case oparen
  188.         If pcount = zero Then
  189.             opush (o1)
  190.             Exit Sub
  191.         Else
  192.             pcount = pcount - one
  193.         End If
  194.     Case cparen
  195.         pcount = pcount + one
  196.     Case raise
  197.         v1 = vpop()
  198.         v2 = vpop()
  199.         If v1 = mt Or v2 = mt Then
  200.             calcerr = "Expression error on operand ^"
  201.             clearstacks
  202.             Exit Sub
  203.         End If
  204.         On Error Resume Next
  205.         vpush Trim$(Str$(Val(v2) ^ Val(v1)))
  206.         If Err Then
  207.             calcerr = "Arithmetic Overflow"
  208.             clearstacks
  209.             Exit Sub
  210.         End If
  211.         On Error GoTo 0
  212.     
  213.     Case times
  214.         v1 = vpop()
  215.         v2 = vpop()
  216.         If v1 = mt Or v2 = mt Then
  217.             calcerr = "Expression error on operand *"
  218.             clearstacks
  219.             Exit Sub
  220.         End If
  221.         On Error Resume Next
  222.         vpush Trim$(Str$(Val(v1) * Val(v2)))
  223.         If Err Then
  224.             calcerr = "Arithmetic Overflow"
  225.             clearstacks
  226.             Exit Sub
  227.         End If
  228.         On Error GoTo 0
  229.  
  230.     Case div
  231.         v1 = vpop()
  232.         v2 = vpop()
  233.         If v1 = mt Or v2 = mt Then
  234.             calcerr = "Expression error on operand /"
  235.             clearstacks
  236.             Exit Sub
  237.         End If
  238.         If Val(v1) = zero Then
  239.             calcerr = "Division by zero"
  240.             clearstacks
  241.             Exit Sub
  242.         End If
  243.         On Error Resume Next
  244.         vpush Trim$(Str$(Val(v2) / Val(v1)))
  245.         If Err Then
  246.             calcerr = "Arithmetic Overflow"
  247.             clearstacks
  248.             Exit Sub
  249.         End If
  250.         On Error GoTo 0
  251.  
  252.     Case plus
  253.         v1 = vpop()
  254.         v2 = vpop()
  255.         If v1 = mt Or v2 = mt Then
  256.             calcerr = "Expression error on operand +"
  257.             clearstacks
  258.             Exit Sub
  259.         End If
  260.         vpush Trim$(Str$(Val(v2) + Val(v1)))
  261.  
  262.     Case minus
  263.         v1 = vpop()
  264.         v2 = vpop()
  265.         If v1 = mt Or v2 = mt Then
  266.             calcerr = "Expression error on operand -"
  267.             clearstacks
  268.             Exit Sub
  269.         End If
  270.         vpush Trim$(Str$(Val(v2) - Val(v1)))
  271. End Select
  272. reduce
  273. End Sub
  274.  
  275. Function vpop$ ()
  276. If vtos >= one Then
  277.     vpop = vstack(vtos)
  278.     vstack(vtos) = mt
  279.     vtos = vtos - one
  280. Else
  281.     vpop = mt
  282. End If
  283. End Function
  284.  
  285. Sub vpush (pval$)
  286. If pval = mt Then Exit Sub
  287. If vtos < UBound(vstack) Then
  288.     vtos = vtos + one
  289.     vstack(vtos) = pval
  290. Else
  291.     calcerr = "Value Stack blown."
  292. End If
  293. End Sub
  294.  
  295.