87 lines
3.3 KiB
Common Lisp
87 lines
3.3 KiB
Common Lisp
(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)))))))
|