'===========================================================================
' Subject: CALCULATOR FUNCTIONS               Date: Unknown Date           
'  Author: Unknown Author(s)                  Code: QB, QBasic, PDS        
'  Origin: CALCULATOR,FUNCTIONS             Packet: ALGOR.ABC
'===========================================================================
DECLARE FUNCTION Calc# (A$)
DECLARE SUB Arith (OO$, R#, H#)
DECLARE SUB GetExp (R#)
DECLARE SUB GetToken ()
DECLARE SUB Level1 (R#)
DECLARE SUB Level2 (R#)
DECLARE SUB Level3 (R#)
DECLARE SUB Level4 (R#)
DECLARE SUB Level5 (R#)
DECLARE SUB Level6 (R#)
DECLARE SUB Ptv (R#)
DECLARE SUB Un (OO$, R#)

DEFINT A-Z

COMMON SHARED Token$, TokenType#, p#, Arg$

'IF INSTR(PRG$, "+-*/<>()=&_?") THEN
'REPLACE "+" WITH " + " IN PRG$
'REPLACE "-" WITH " - " IN PRG$
'REPLACE "*" WITH " * " IN PRG$
''REPLACE "\" WITH " \ " IN PRG$
'REPLACE "/" WITH " / " IN PRG$
''REPLACE "^" WITH " ^ " IN PRG$
'REPLACE "<" WITH " < " IN PRG$
'REPLACE ">" WITH " > " IN PRG$
'REPLACE "(" WITH " ( " IN PRG$
'REPLACE ")" WITH " ) " IN PRG$
'REPLACE "=" WITH " = " IN PRG$
'REPLACE "&" WITH " & " IN PRG$
'REPLACE "?" WITH "" IN PRG$
'REPLACE "_"+CHR$(13,10) WITH " " IN PRG$
'END IF

PRINT
PRINT "((1 + 2) + (3 - 5) * 4 )/ 6="
PRINT Calc("((1+2)+(3-5)*4)/6")
PRINT ((1 + 2) + (3 - 5) * 4) / 6#
PRINT

DEFDBL A-Z
SUB Arith (OO$, R, H)

  IF OO$ = "-" THEN R = (R - H)
  IF OO$ = "+" THEN R = (R + H)
  IF OO$ = "*" THEN R = (R * H)
  IF OO$ = "/" THEN R = (R / H)
  IF OO$ = "^" THEN R = (R ^ H)
  IF OO$ = "<" THEN R = (R < H)
  IF OO$ = ">" THEN R = (R > H)
  IF OO$ = "=" THEN R = (R = H)

END SUB

' All of the following subroutines are necessary to perform the recursive
' descent parser.  CALC is the only callable routine, and must be passed
' a string containing a valid math expression.
' An invalid expression, such as (2**4) or (1+2+3+) will result in a
' SYNTAX ERROR message, printed on the screen by the sub PTV().  Mismatched
' parenthesis result in an error message displayed by sub LEVEL6().  These
' error messages could be replaced with the ERROR nn statement, allowing your
' own error-handling routines to report the error.
'
' This routine supports boolean expressions (1>2) and unary operators (5*-1)
FUNCTION Calc (A$)

  R = 0
  p = 1
  IF A$ = "" THEN GOTO EndCalcSub
  Arg$ = A$
  CALL GetExp(R)
  LET Calc = R

EndCalcSub:

END FUNCTION

SUB GetExp (R)

  CALL GetToken
  CALL Level1(R)

END SUB

SUB GetToken

  Token$ = ""

  WHILE MID$(Arg$, p, 1) = " "
    p = p + 1
  WEND

  IF INSTR("-+*/^()<>=", MID$(Arg$, p, 1)) THEN
    TokenType = 1
    Token$ = MID$(Arg$, p, 1)
    p = p + 1
    EXIT SUB
  END IF

    IF INSTR("01234567890.", MID$(Arg$, p, 1)) THEN
      WHILE INSTR(" -+*/^()<>=", MID$(Arg$, p, 1)) = 0
        Token$ = Token$ + MID$(Arg$, p, 1)
        p = p + 1
      WEND
      TokenType = 2
    END IF

END SUB

SUB Level1 (R)

  CALL Level2(R): OO$ = Token$
  WHILE OO$ = "<" OR OO$ = ">" OR OO$ = "="
    CALL GetToken
    CALL Level2(H)
    CALL Arith(OO$, R, H)
    OO$ = Token$
  WEND

END SUB

SUB Level2 (R)

  CALL Level3(R)
  OO$ = Token$
  WHILE OO$ = "+" OR OO$ = "-"
    CALL GetToken
    CALL Level3(H)
    CALL Arith(OO$, R, H)
    OO$ = Token$
  WEND

END SUB

SUB Level3 (R)

  CALL Level4(R)
  OO$ = Token$
  WHILE OO$ = "*" OR OO$ = "/"
    CALL GetToken
    CALL Level4(H)
    CALL Arith(OO$, R, H)
    OO$ = Token$
  WEND

END SUB

SUB Level4 (R)

  CALL Level5(R)
  IF Token$ = "^" THEN
    CALL GetToken
    CALL Level4(H)
    CALL Arith("^", R, H)
  END IF

END SUB

SUB Level5 (R)

  OO$ = ""
  IF TokenType = 1 AND (Token$ = "+" OR Token$ = "-") THEN
    OO$ = Token$
    CALL GetToken
  END IF

  CALL Level6(R)
  IF OO$ <> "" THEN CALL Un(OO$, R)

END SUB

SUB Level6 (R)

  IF Token$ = "(" AND TokenType = 1 THEN GOTO Eddy:
  CALL Ptv(R)
  EXIT SUB

Eddy:
  CALL GetToken
  CALL Level1(R)
  IF Token$ <> ")" THEN ERROR 102
  CALL GetToken

END SUB

SUB Ptv (R)

  IF TokenType = 2 THEN
    R = VAL(Token$)
    CALL GetToken
    EXIT SUB
  END IF

  BEEP
  ERROR 101
  END

END SUB

SUB Un (OO$, R)

  IF OO$ = "-" THEN R = -R

END SUB