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.

Now, we start to define the stack object.  It will be a structure that holds the current stack as a list, the defined length of the stack, and the last-X register.  It will also have flags to indicate whether we are forcing rational numbers, whether complex numbers are allowed, and a flag that indicates the stack is in an error state.

If a complex number is passed to the stack when they are no allowed, it should raise a condition, so we’ll also define that.  Then, we have a few stack manipulation functions.

The HP-67 calculator had a 4-register stack, so we’ll default to that, but allow the flexibility to make it longer, or even unlimited.  When the HP-67 calculator popped an item from the stack, the deepest element was duplicated.  That is, the empty space created was not filled with a zero, but kept the value that used to be there.  We will replicate this behaviour, except in the case of unlimited stack depth.  In that case, newly-introduced elements will be zero.

Stack operations will be forbidden if the stack is in an error state.

So, the first version of these components is as follows:

(define-condition not-real-number (error)
  ((val         :initarg value
                :reader get-val))
  (:documentation "Complex number encountered in real-only mode.")
  (:report (lambda (c s)
             (format s "The complex value ~A was encountered."
                     (get-val c)))))

(defstruct (stack)
  (registers            (list 0 0 0 0))
  (num-registers        4)
  (last-x               nil)

  (use-rationals-p      nil)
  (complex-allowed-p    nil)
  (error-state          nil))


(defun trim-list-to-length (list num)
  (assert (<= num (length list)))
  (dotimes (i (1- num))
    (setf list (cdr list)))
  (setf (cdr list) '()))


(defun set-stack-size (stack num)
  "Changes the size of the stack.  Size 0 means unlimited."
  (assert (and (integerp num)
               (>= num 0)))
  (when (and (/= num 0)
             (/= (stack-num-registers stack) num))
    (let ((num-new-entries (- num
                              (length (stack-registers stack)))))
      (cond
        ((> num-new-entries 0)
         (setf (stack-registers stack)
               (append (stack-registers stack)
                       (make-sequence 'list
                                      num-new-entries
                                      :initial-element 0))))
        (t
         (trim-list-to-length (stack-registers stack) num)))))

  (setf (stack-num-registers stack) num))


(defun pop-stack (stack)
  "Returns the first element from the stack."
  (unless (stack-error-state stack)
    (let (rv)
      (cond
        ((and (= 0 (stack-num-registers stack))
              (null stack))
         (setf rv 0))
        (t
         (let ((previous-contents (stack-registers stack)))
           (setf rv (pop previous-contents))
           (when (/= (stack-num-registers stack) 0)
             (setf (stack-registers stack)
                   (append previous-contents (last previous-contents)))))))
      (if (stack-use-rationals-p stack)
          (rational rv)
          rv))))


(defun push-stack (stack val)
  "Pushes an element on the stack."
  (assert (numberp val))
  (unless (stack-error-state stack)
    (when (and (complexp val)
               (not (stack-complex-allowed-p stack)))
      (error (make-condition 'not-real-number
                             :value val)))
    (when (stack-use-rationals-p stack)
      (setf val (rational val)))

    (push val (stack-registers stack))
    (when (/= 0 (stack-num-registers stack))
      (trim-list-to-length (stack-registers stack)
                           (stack-num-registers stack))))
  val)

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

Now, I’ll produce the first version of the expander function.  This takes in a list of rules associated with a keypress, and converts them into a Lisp form.  This function will later be called in a macro to define the key operations.  We’ll be using backticks again, since we’re producing code, and that’s the way to make it readable in the source.

Now, at this point an introductory text usually goes through a few iterations, first making a simple version, then adding in gensyms, condition handlers, labels, and so on.  I’m just going to reproduce the whole thing up front and describe it.  Note that we may decide to change or augment this function in the future if we discover something that needs it.

So, here’s the current version of the expander:

;; This is going to change a basic rules list into explicit pops,
;; pushes, and exception handling
(defun expand-rules (rules-list)
  (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)))

           (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)))))))

The object returned is a lambda form of two arguments, a stack variable and a state variable.  This will allow us to funcall the form stored in a slot, with the appropriate arguments.

We know that some functions might need state information.  One example of this is the operation of converting an angle to radians so that it can be used in a trigonometric operation.  If the current state of the calculator is set to radians, this does nothing, but if it’s set to degrees or gradians, it has to do a conversion.  I don’t want to clutter the invocation in keypresses with the state variable, it should be invisible when defining keys, so I create a labels form to do the appropriate thing with the correct arguments behind the scenes, leaving the form in the keypress definition as simply:

X <- (sin (to-radians X))   or   X <- (from-radians (asin X))

I also have helper functions to convert between rationals and double-precision floats, optionally controlled by the state variable.

Next, the used variables are popped from the stack, and the assigned variables in their own symbols are initialized to zero.  The rules are then executed in a handler-case.  The purpose for this is to allow the calculator to behave well if a function domain error is encountered (such as division by zero), or an assert failure.  In the event of such an error, the stack is informed of the error and supplied with the condition that was signaled, and the output registers are set to zero.  Execution then finished when the output registers are pushed back onto the stack.

Here is a sample of the generated output when run on our rectangular-to-polar forms:

CL-USER> (expand-rules '(X <- (sqrt (+ (* X X) (* Y Y)))
                         Y <- (atan Y X)))
(LAMBDA (#:G939 #:G940)
  (DECLARE (IGNORABLE #:G939 #:G940))
  (LABELS ((TO-RADIANS (ANGLE)
             (CONVERT-ANGLE-TO-RADIANS ANGLE
              (GET-ANGLE-STATE #:G940)))
           (FROM-RADIANS (ANGLE)
             (CONVERT-ANGLE-FROM-RADIANS ANGLE
              (GET-ANGLE-STATE #:G940)))
           (TO-RATIONAL (NUM)
             (CONVERT-NUMBER-TO-RATIONAL NUM
              (GET-RATIONAL-STATE #:G940)))
           (TO-DOUBLE-FP (NUM)
             (COERCE NUM 'DOUBLE-FLOAT)))
    (LET ((X (POP-STACK #:G939))
          (Y (POP-STACK #:G939))
          (#:G942 0)
          (#:G941 0))
      (HANDLER-CASE
       (PROGN
        (SETF #:G941 (SQRT (+ (* X X) (* Y Y))))
        (SETF #:G942 (ATAN Y X)))
       ((OR ARITHMETIC-ERROR SIMPLE-ERROR) (C)
        (SET-ERROR-STATE #:G939 C) (SETF #:G942 0)
        (SETF #:G941 0)))
      (PUSH-STACK #:G939 #:G942)
      (PUSH-STACK #:G939 #:G941))))

At this point, it’s probably a good idea to talk about modes and calculator internals.  The HP-67 calculator supports several modes that modify behaviour.  Examples are programming mode vs. run mode, output in fixed, scientific, or engineering notation, and angular measures in radians, degrees, or gradians.  It is the angle measures that concern us.  The Lisp programming language, naturally, performs trigonometric operations in radians.  We will need to give the programmer an opportunity to account for other angular units when defining the operations that are associated with a keypress.  Our final form will need to account for this mode.  Our macro will define labels in scope to convert to and from radians according to the currently active mode.

Next, we come to the issue of floating-point roundoff.  The HP-67 calculator was actually implemented using BCD arithmetic internally.  It used a 56-bit register for 14 BCD digits.  10 digits formed the mantissa, 2 formed the exponent, and the remaining two digits recorded the signs of the mantissa and of the exponent.

BCD representations are uncommon now, outside of embedded applications and calculators.  The advantage is that every decimal representation that can be displayed can be exactly represented by the internal state of the calculator, which would not be the case if the internal representation were made using the common binary IEEE-754 representation.

If you use the HP-67 calculator to add .8 to itself 10 times, the result is exactly 8.00.  If you do the same thing at the REPL in SBCL, using single-precision floats, the result is 8.0000009536743.  We’d like our emulator to give the correct answer whenever possible.  A common approach is to throw more bits at the problem, and make use of double-precision floats, but we will avoid that whenever possible.  So, what can we do?  Well, Lisp has the concept of rationals, numeric representations that consist of a ratio of integers.  These are ideal for most uses, we can perform our arithmetic with rationals, and then, if necessary, pare the precision of the result down to the appropriate size for our emulator, exactly the way the calculator would do it.  For instance, if we were computing the ratio (/ 1 5), we would store it internally as that rational, with no loss of precision.  We would convert (/ 1 7) to its 10-digit rational form, 1428571429/10000000000.  If we were computing the square root of 2, which is an irrational number, we would express it as a double-precision number with 10 significant digits, and then convert it to a rational representation.  It would be stored as 707106781/500000000.  For simple arithmetic, we would have exact representations whenever possible.

There is some difficulty in trying to ensure that you work only with rational numbers in Lisp.  Arithmetic operations can take rationals and produce rationals, but most other functions do not.  In SBCL, the following output occurs when you compare two numbers that are mathematically equal:

CL-USER> (< (/ 1 3) (sqrt (/ 1 9)))
T

The further difficulty is that if a Lisp function requires a floating-point argument and it receives a rational, it promotes it to a single-precision float.  This behaviour is explicitly outlined in the CLHS.  Single-precision floats are entirely inappropriate when dealing with 10-digit numbers, so this would give us significant problems.

We will, therefore, provide another labels form to force intermediate values to 10-digit rational representations, and our key definition will include an option to pop values from the stack as double-precision floating-point numbers rather than as rationals.

This rational number representation will be a new mode, selectable by the user if desired.  In most applications, double-precision numbers are probably enough, but when doing accounting-style calculations (remember: money isn’t a floating-point number, it’s integer pennies) it is probably desirable to use rational representations.