We’ve build the basic building blocks of our system to define operation keys.  Now, we put it together.

First, we’ll need a structure to hold the definition of a key.  This will include the position of the key in the interface layout, in a yet-to-be-determined format, a unique ID, an indication of whether a key is available in run-mode, program-mode, or both, a text abbreviation for the key that might be used for a text-based UI, the function it invokes, and a documentation string.  Here’s the initial form of the structure:

(defstruct (key-struct)
  (key-location         nil)
  (key-id               nil)
  (avail-modes          :RUN-MODE)
  (abbrev               nil)
  (run-mode-fcn         nil)
  (doc-string           nil))

We’ll also need some forms to hold the key structures and hand out unique IDs:

(let ((keys '())
      (next-id 0))

  (defun make-new-id ()
    (prog1
        next-id
      (incf next-id)))

  (defun register-key-structure (ks)
    (let ((this-id (key-struct-key-id ks)))
      (when (>= this-id next-id)
        (setf next-id (1+ this-id))))
    (push ks keys))

  (defun get-keys ()
    keys))

The HP-67 calculator also has a register called the “Last X” register, for use in undoing keypress mistakes.  It holds the value of X as it was before any operation that can destroy the X register.  Most operation keys will update this value, so an appropriate form is added to the rules expansion function we saw earlier.  That function is now as follows:

(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 
                 (get-angle-state ,state-var)))
              (from-radians (angle)
                (convert-angle-from-radians 
                 angle 
                 (get-angle-state ,state-var)))
              (to-rational (num)
                (convert-number-to-rational 
                 num 
                 (get-rational-state ,state-var)))
              (to-double-fp (num)
                (coerce num 'double-float)))

           ,(when update-last-x
                  `(update-last-x ,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)
               ((or arithmetic-error simple-error) (c)
                 (set-error-state ,stack-var c)
                ,@(mapcar #'(lambda (x)
                              `(setf ,x 0)) 
                          gensyms-output)))

             ,@(mapcar #'(lambda (x)
                           `(push-stack ,stack-var ,x)) 
                       gensyms-output)))))))

Putting this all together, we define a macro that produces a new operation key and puts it in the list of defined keys.  Note that the macro ends with a (values) form so that it doesn’t insert any text into the stream here, as this macro isn’t actually creating functions, it’s just creating and storing data structures.  Here is the macro:

(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
                    (expand-rules `(,run-mode-forms)
                                  :update-last-x updates-last-x)))
  (values))

Here is a sample invocation of this macro:

CL-USER> (define-op-key 
             (:abbreviation "+" 
                            :documentation "Adds X to Y")
           (+ Y X))
NIL