Create a program which parses and evaluates arithmetic expressions.

Requirements

 An abstract-syntax tree (AST) for the expression must be created from parsing the input. 
 The AST must be used in evaluation, also, so the input may not be directly evaluated (e.g. by calling eval or a similar language feature.) 
 The expression will be a string or list of symbols like "(1+3)*7". 
 The four symbols + - * / must be supported as binary operators with conventional precedence rules. 
 Precedence-control parentheses must also be supported.


Note

For those who don't remember, mathematical precedence is as follows:

 Parentheses
 Multiplication/Division (left to right)
 Addition/Subtraction (left to right)


C.f
 
 24 game Player.
 Parsing/RPN calculator algorithm.
 Parsing/RPN to infix conversion.


(defun tokenize-stream (stream)
  (labels ((whitespace-p (char)
             (find char #(#\space #\newline #\return #\tab)))
           (consume-whitespace ()
             (loop while (whitespace-p (peek-char nil stream nil #\a))
                   do (read-char stream)))
           (read-integer ()
             (loop while (digit-char-p (peek-char nil stream nil #\space))
                   collect (read-char stream) into digits
                   finally (return (parse-integer (coerce digits 'string))))))
    (consume-whitespace)
    (let* ((c (peek-char nil stream nil nil)))
           (token (case c
                     (nil nil)
                     (#\( :lparen)
                     (#\) :rparen)
                     (#\* '*)
                     (#\/ '/)
                     (#\+ '+)
                     (#\- '-)
                     (otherwise
                       (unless (digit-char-p c)
                         (cerror "Skip it." "Unexpected character ~w." c)
                         (read-char stream)
                         (return-from tokenize-stream
                                      (tokenize-stream stream)))
                       (read-integer)))))
        (unless (or (null token) (integerp token))
          (read-char stream))
        token)))
 
(defun group-parentheses (tokens &optional (delimited nil))
  (do ((new-tokens '()))
      ((endp tokens)
       (when delimited
         (cerror "Insert it."  "Expected right parenthesis."))
       (values (nreverse new-tokens) '()))
    (let ((token (pop tokens)))
      (case token
        (:lparen
         (multiple-value-bind (group remaining-tokens)
             (group-parentheses tokens t)
           (setf new-tokens (cons group new-tokens)
                 tokens remaining-tokens)))
        (:rparen
         (if (not delimited)
           (cerror "Ignore it." "Unexpected right parenthesis.")
           (return (values (nreverse new-tokens) tokens))))
        (otherwise
         (push token new-tokens))))))
 
(defun group-operations (expression)
  (flet ((gop (exp) (group-operations exp)))
    (if (integerp expression)
      expression
      (destructuring-bind (a &optional op1 b op2 c &rest others)
                          expression
        (unless (member op1 '(+ - * / nil))
          (error "syntax error: in expr ~a expecting operator, not ~a"
                 expression op1))
        (unless (member op2 '(+ - * / nil))
          (error "syntax error: in expr ~a expecting operator, not ~a"
                 expression op2))
        (cond
         ((not op1) (gop a))
         ((not op2) `(,(gop a) ,op1 ,(gop b)))
         (t (let ((a (gop a)) (b (gop b)) (c (gop c)))
              (if (and (member op1 '(+ -)) (member op2 '(* /)))
                (gop `(,a ,op1 (,b ,op2 ,c) ,@others))
                (gop `((,a ,op1 ,b) ,op2 ,c ,@others))))))))))
 
(defun infix-to-prefix (expression)
  (if (integerp expression)
    expression
    (destructuring-bind (a op b) expression
      `(,op ,(infix-to-prefix a) ,(infix-to-prefix b)))))
 
(defun evaluate (string)
  (with-input-from-string (in string)
    (eval
      (infix-to-prefix
        (group-operations
          (group-parentheses
            (loop for token = (tokenize-stream in)
                  until (null token)
                  collect token)))))))