RPN calculator using lisp stack as RPN stack

rpn.lisp

(defpackage rpn (:use :cl) (:export :rpn))

(defpackage rpn-internal (:export :+ :print))

(in-package :rpn)

(defgeneric rpn-eval (token &optional y))

(defun rpn ()
  (rpn-eval (let ((*package* (find-package 'rpn-internal))) (read))))

(defmethod rpn-eval ((token number) &optional y)
  (loop
    (destructuring-bind (op &rest args)
        (multiple-value-list
         (if y
             (rpn-eval y)
             (rpn)))
      (multiple-value-bind (result more)
          (apply op token args)
        (when (eql result 'more-args)
          (return (values-list (list* op token args))))
        (format t "~A~@[;~A~]~%" result more)
        (setf token result
              y more)))))

(defmethod rpn-eval ((token symbol) &optional y)
  (when y (error "Arg not allowed to be passed to operator"))
  token)

(defmacro wrap-binop (rpn-name &optional (cl-name rpn-name))
  `(defun ,(intern (string rpn-name) 'rpn-internal) (x &optional y)
     (if y
         (,cl-name x y)
         'more-args)))

(defmacro wrap-unop (rpn-name &optional (cl-name rpn-name))
  `(defun ,(intern (string rpn-name) 'rpn-internal) (x)
     (,cl-name x)))

(wrap-binop +)
(wrap-binop -)
(wrap-binop *)
(wrap-binop /)
(wrap-binop log)
(wrap-binop ^ expt)
(wrap-binop ~ floor)

(defun rpn-internal::swap (x &optional y)
  (if y
      (values y x)
      'more-args))

(wrap-unop print identity)
(wrap-unop p identity)
(wrap-unop _ -)
(wrap-unop v sqrt)
(wrap-unop ln log)


#.`(progn
     ,@(loop for item in '(abs acos acosh asin asinh atan atanh cis cos cosh
                           exp phase sin sinh sqrt tan tanh)
             collect `(wrap-unop ,item)))