The HP-67 calculator, naturally, has memory into which numbers can be stored.  There are 26 of these memory registers.  There are registers 0 through 9, secondary registers 0 through 9, registers “A” through “E”, and special register “I”.

The secondary registers are protected, many memory operations can’t touch them until they are swapped with the primary registers.  However, the statistical operations use the secondary registers as their accumulator space, so some care has to be taken with them.  The registers “A” through “E” are just normal memory, but the indirection register “I” is special.  The “I” register can be used to supply integer arguments to certain other operations, like setting display width, referencing memory, or branching in programs.  It is unlikely that the user of the calculator would ever use “I” in interactive use of the calculator, but the indirection register is very useful for writing programs on the calculator.  The indirection register holds floating-point values, but only the integer value is used for indirection operations.

When the indirection register is used to refer to memory registers, a value on the interval 0-9 references the primary memory 0 through 9.  A value on the interval 10-19 references the secondary memory 0 through 9.  A value on the interval 20-24 references the registers “A” through “E”, and a value of 25 references the “I” register itself.

Naturally, in a Lisp program, we’re not memory-constrained to the degree that the HP-67 is.  We will, therefore, allow any number of memory registers, keyed against a string name.  For backwards compatibility, we will still support the “I” register with its ability to modify numbered memory registers, but those numbers will be converted to strings.  The user of the calculator will be encouraged not to use pure numeric names for memory registers, to avoid conflicting with the legacy behaviour built into this emulator.

The HP-67 calculator also has 4 flags.  These are boolean registers that can be set by certain relational operators, or set directly with commands, and can be used to control flow in a program.  We will support an arbitrary number of named flags.  The indirection operator also affects flags, when its value lies between 0 and 3, so we will support that behaviour.  Further, flags 2  and 3 are test-cleared.  If the value is read, it is returned, but the flag is then reset to false.

So, we’ve got some new slots in our stack structure, and some new functions to manipulate the stack.  In the C++ code, I found it helpful to order the memory registers with the most-recently-accessed-or-modified first.  I think, for this code, I’ll order them by most-recently-modified first, to avoid the values dancing around the display the way they do in the C++ version.  Here’s the new Lisp code:

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

  (memory               nil)
  (register-i           0)
  (flags                '(("0" . nil)
                          ("1" . nil)
                          ("2" . nil)
                          ("3" . nil)))

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



(defun memory-name (name)
  (etypecase name
    (string (copy-seq name))
    (integer (format nil "~D" name))))

(defun convert-indirection-name (name)
  (assert (numberp name))
  (let ((num (floor name)))
    (cond
      ((or (< num 0) (> num 25))
       "")
      ((= num 25)
       (values t t))
      ((> num 19)
       (subseq "ABCDE" (- num 20) (- num 19)))
      (t
       (format nil "~D" num)))))



(defun store-memory (stack name val &key indirection)
  (let (converted use-i-reg)
    (cond
      (indirection
       (multiple-value-bind (c-name special-i-reg)
           (convert-indirection-name name)
         (setf use-i-reg special-i-reg
               converted c-name)))
      (t
       (setf converted (memory-name name))))

    (cond
      (use-i-reg
       (setf (stack-register-i stack) val))
      (t
       (setf (stack-memory stack)
             (delete-duplicates
              (push (cons converted val)
                    (stack-memory stack))
              :key 'car
              :test 'string=
              :from-end t)))))
  val)


(defun recall-memory (stack name &key indirection)
  (let (converted use-i-reg)
    (cond
      (indirection
       (multiple-value-bind (c-name special-i-reg)
           (convert-indirection-name name)
         (setf use-i-reg special-i-reg
               converted c-name)))
      (t
       (setf converted (memory-name name))))
    (cond
      (use-i-reg
       (stack-register-i stack))
      (t
       (let ((record (assoc converted
                            (stack-memory stack)
                            :test 'string=)))
         (if record
             (cdr record)
             0))))))


(defun set-flag (stack name &key clear)
  (let* ((converted (memory-name name))
         (record (assoc converted (stack-flags stack)
                        :test 'string=)))
    (cond
      (record
       (setf (cdr record) (not clear)))
      (t
       (setf (stack-flags stack)
             (push (cons converted (not clear))
                   (stack-flags stack)))))))

(defun clear-flag (stack name)
  (set-flag stack name :clear t))

(defun get-flag (stack name)
  (let* ((converted (memory-name name))
         (record (assoc converted (stack-flags stack)
                        :test 'string=))
         (rval (cdr record)))
    (when (or (string= converted "2")
              (string= converted "3"))
      (clear-flag stack name))
    rval))


(defun set-i-register (stack value)
  (setf (stack-register-i stack) value))

(defun swap-primary-secondary (stack)
  (dotimes (i 10)
    (let ((val-prim (recall-memory stack i
                                   :indirection t))
          (val-second (recall-memory stack (+ i 10)
                                     :indirection t)))
      (store-memory stack i val-second
                    :indirection t)
      (store-memory stack (+ i 10) val-prim
                    :indirection t))))

This code is in the github repository under the tag v2014-10-25.

We talked about a “location” to be defined later.  It’s time now to define it.  Here’s the structure:

(defstruct (location)
  (row          nil)     ;; 1-offset row number
  (column       nil)     ;; 1-offset column number
  (shift        :UNSHIFTED)
  (width        1)
  (category-1   nil)
  (category-2   nil))

The row and column are just the 1-offset locations on the calculator keypad, with the 1,1 entry being the upper-left key on the calculator.  The shift field indicates whether the function is associated with one of the three shift keys.  These keys allow a single operation key to have up to four different behaviours, depending on whether or not a shift key was pressed before the key itself.  The three keys have colours that match the label colour on the key.  They are f (yellow), g (blue), and h (black).  The width indicator is because the ENTER key is double-width, so we want to be able to indicate that in the key layout.  The category fields are there for use in non-GUI interfaces.  For a command-line interface with button names laid out above, it makes sense to group like functions together for clarity.  In that way, we can say that the sine function is in the :TRIGONOMETRY category-1, and the inverse sine is in the :TRIGONOMETRY category-1 and :INVERSE category-2.

So, what do our key definitions look like now?  Here’s a set of 5, the arithmetic operations down the left side of the keypad:

(define-op-key 
    (:location (make-location
                :row 5
                :col 1
                :category-1 :ARITHMETIC)
               :abbreviation "-" 
               :documentation "Subtracts X from Y")
    X <- (- Y X))

(define-op-key 
    (:location (make-location
                :row 6
                :col 1
                :category-1 :ARITHMETIC)
               :abbreviation "+" 
               :documentation "Adds X to Y")
    X <- (+ Y X))

(define-op-key 
    (:location (make-location
                :row 7
                :col 1
                :category-1 :ARITHMETIC)
               :abbreviation "*" 
               :documentation "Multiplies Y by X")
    X <- (* Y X))

(define-op-key 
    (:location (make-location
                :row 8
                :col 1
                :category-1 :ARITHMETIC)
               :abbreviation "/" 
               :documentation "Divides Y by X")
    X <- (/ Y X))

(define-op-key 
    (:location (make-location
                :row 8
                :col 1
                :shift :H-BLACK
                :category-1 :ARITHMETIC)
               :abbreviation "!" 
               :documentation "Computes X factorial")
    (assert (and (integerp X)
                 (>= X 0)))
  (let ((result 1))
    (dotimes (i X)
      (setf result (* result (1+ i))))
    X <- result))

The code in this state is checked into the github repository under the tag “v2014-10-23”.

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