We define our mode structure, that will be used to hold global state flags for the emulator:

(defstruct (modes)
  (angles               :RADIANS)
  (run/prog             :RUN-MODE)
  (complex              nil)
  (rational             nil)
  
  (display-mode         :FIXED))

We also fill in some missing functions that we’ve been preparing to use:

(defun backup-stack (stack)
  (setf (stack-registers-copy stack)
        (copy-tree (stack-registers stack))))

(defun recover-stack (stack)
  (setf (stack-registers stack)
        (copy-tree (stack-registers-copy stack))))

(defun set-error-state (stack c)
  (setf (stack-error-state stack) c))

(defun clear-error-state (stack)
  (setf (stack-error-state stack) nil))

(defun update-last-x (stack)
  (let ((contents (stack-registers stack)))
    (setf (stack-last-x stack)
          (if contents
              (first contents)
              0))))

(defun convert-angle-to-radians (angle angle-mode)
  (ecase angle-mode
    (:RADIANS angle)
    (:GRADIANS (* PI (/ angle 200.0d0)))
    (:DEGREES (* PI (/ angle 180.0d0)))))


(defun convert-angle-from-radians (angle angle-mode)
  (ecase angle-mode
    (:RADIANS angle)
    (:GRADIANS (* 200.0d0 (/ angle PI)))
    (:DEGREES (* 180.0d0 (/ angle PI)))))

(defun convert-number-to-rational (num rational-mode)
  "Convert the number, only if 'rational-mode' is non-nil"
  (if rational-mode
      (rational num)
      num))

Next, we modify our expand-rules function a bit, by setting it up so that errors cause the stack to recover to its former state.  I’d rather have an error leave the stack alone, than leave it in an unknown state.  The current form of the function is now:

(defun expand-rules (rules-list &key update-last-x)
  (let* ((varnames '(X Y Z W))
         (stack-var (gensym))
         (state-var (gensym))
         (vars-used (get-vars-used rules-list
                                   varnames))
         (vars-assigned (get-vars-assigned rules-list
                                           varnames)))

    ;; If this is an implicit X <- form, make it explicit so the setf
    ;; substitution will work later
    (when (and (= 1 (length vars-assigned))
               (not (member '<- (get-symbols-in-list
                                 rules-list)))
               (= 1 (length rules-list)))
      (setf rules-list 
            (append (list (first varnames) '<-)
                    rules-list)))

    ;; We need new symbols to hold the assigned values of the stack
    ;; variables, to avoid side-effects on multiple assignments.
    (let (gensyms-output)
      (dolist (v vars-assigned)
        (declare (ignore v))
        (push (gensym) gensyms-output))

      (setf rules-list 
            (convert-to-setf-forms 
             rules-list vars-assigned gensyms-output))

      `(lambda (,stack-var ,state-var)
         (declare (ignorable ,stack-var ,state-var))
         (labels
             ((to-radians (angle)
                (convert-angle-to-radians 
                 angle 
                 (modes-angles ,state-var)))
              (from-radians (angle)
                (convert-angle-from-radians 
                 angle 
                 (modes-angles ,state-var)))
              (to-rational (num)
                (convert-number-to-rational 
                 num 
                 (modes-rational ,state-var)))
              (to-double-fp (num)
                (coerce num 'double-float)))

           ,(when update-last-x
                  `(update-last-x ,stack-var))
           (backup-stack ,stack-var)
           (let (,@(mapcar #'(lambda (x) 
                               `(,x (pop-stack ,stack-var))) 
                           vars-used)
                 ,@(mapcar #'(lambda (x) 
                               (list x 0))
                           gensyms-output))
             (handler-case
                 (progn
                   ,@rules-list
                   ,@(mapcar #'(lambda (x)
                                 `(push-stack ,stack-var ,x)) 
                             gensyms-output))

               ((or arithmetic-error simple-error not-real-number) (c)
                 (set-error-state ,stack-var c)
                (recover-stack ,stack-var)))))))))

Next, I realized there were two errors in the define-op-key macro.  First, we were missing an eval, so the output of expand-rules was being stored as a list, rather than as a function.  Second, the run-mode-forms were being passed with one-too-many levels of nesting because I had a comma instead of a ,@.  That’s fixed up here:

(defmacro define-op-key ((&key
                          location
                          (id (make-new-id))
                          (mode :RUN-MODE)
                          abbreviation
                          (updates-last-x t)
                          documentation)
                         &body run-mode-forms)
  (register-key-structure
   (make-key-struct :key-location location
                    :key-id id
                    :avail-modes mode
                    :abbrev abbreviation
                    :doc-string documentation
                    :run-mode-fcn
                    (eval (expand-rules 
                           `(,@run-mode-forms)
                           :update-last-x updates-last-x))))
  (values))

And now, we’re ready to perform a test operation, just to make sure everything seems to be on track:

CL-USER> (define-op-key 
             (:abbreviation "+" 
                            :documentation "Adds X to Y")
           X <- (+ Y X))
NIL
CL-USER> (let ((stack (make-stack))
               (mode (make-modes)))
           (push-stack stack 3) 
           (push-stack stack 4)
           (format t "stack= ~A~%" (stack-registers stack))
           (funcall (key-struct-run-mode-fcn (first (get-keys)))
                    stack mode)
           (format t "stack= ~A~%" (stack-registers stack)))

stack= (4 3 0 0)
stack= (7 0 0 0)
NIL

At this point, the code is starting to get a bit big. Rather than have people assemble the full code from multiple blog postings, I’ve put the current version onto github. Find it here.