At this point, the monolithic file we’ve been working on is getting too large.  It makes sense to break things up into logical units.  It’s also time to stop thinking of this in terms of plugging commands into the REPL, and look at actually compiling and loading the files.  So, I’ve broken the big file into several smaller ones, and created an ASDF control file that looks like this:

(defpackage hp67
  (:use :common-lisp :asdf))

(in-package :hp67)

(defsystem "hp67"
  :description "hp67:  a programmable RPN calculator emulator."
  :version "0.1"
  :author "Christopher Neufeld"
  :licence "GPL v3"
  :components ((:file "stack")
               (:file "modes")
               (:file "key-structs"
                      :depends-on ("stack" "modes"))
               (:file "calc1"
                      :depends-on ("key-structs"))))
           

Now, I can issue the command:

CL-USER> (asdf:oos 'asdf:load-op 'hp67)

This compiles any files whose sources are more recent than the compiled .fasl files, and loads the project.

Now, the define-op-key macro that we were using was building structures at macro expansion time, and loading them into a data structure.  That’s not convenient if we want to compile and load the files.  We could define a make-load-form for the key-struct structures, but there’s no need to do that.  Instead, we change the define-op-key macro to issue code to construct the objects, that code will be executed at load time, rather than at macro expansion time.

Now that we can compile our forms, a few typos have shown up, which are corrected in the latest code.  We also get a large pile of warnings about labels that are not used in the expanded forms.  Warnings like that are annoying, because the can obscure more interesting warnings, so we’re going to change them from labels to macrolet forms.

The code described here is in the git repository under the tag v2014-10-31.

The top row of five keys on the calculator are a bit special.  When in run mode, and there are no program steps defined, they are single-key shortcuts for other operations that are shifted on other keys.  The keys are labelled A through E, and when there is no program defined they invoke the operations 1/x, sqrt(X), Y^X, rolldown, and X<->Y.

As soon as even one program step is defined, or in programming mode, the keys become shortcuts for GOSUB operations.  There are 10 possible targets: A through E, and a through e, the lowercase versions being chosen by the yellow F-shift key.

Defining these keys is a pattern that we can handle with a new macro, define-toprow-key.  This macro creates three new key definitions: one for the shortcut arithmetic operation, and one for each of the two GOSUB operations.

At this point, we notice that the stack roll-down operation isn’t going to fit into our previous design of allowing implicit assignments to X by the forms in the function, because we can’t have any pops or pushes to the stack around that operation.  So, we add a keyword override to disable the implicit X-assignment, and make it part of the form parser.

There are a few changes and bugfixes associated with this latest version, rather than reproducing all the new functions, I’ll just show the new macro.  The rest of the file can be seen in the git repository under the tag v2014-10-29.

Here’s the macro, and its invocation:

(defmacro define-toprow-key ((col letter abbreviation doc
                                  &key implicit-x (updates-last-x t))
                             &body arith-forms)
  `(progn
     (define-op-key
         (:location (make-location
                     :row 1
                     :col ,col
                     :category-1 :ARITHMETIC)
                    :modelist '(:RUN-NO-PROG)
                    :abbreviation ,abbreviation
                    :updates-last-x ,updates-last-x
                    :implicit-x ,implicit-x
                    :documentation ,(format nil
                                            "~S (when no program exists)"
                                            doc))
         ,@arith-forms)
     
     (define-op-key
         (:location (make-location
                     :row 1
                     :col ,col
                     :category-1 :FLOW-CONTROL)
                    :modelist '(:RUN-WITH-PROG)
                    :abbreviation ,(format nil
                                           "GSB-~C"
                                           letter)
                    :implicit-x ,implicit-x
                    :updates-last-x nil
                    :documentation ,(format nil
                                            "Call program label ~C"
                                            letter))
         :RETCODE <- '(:GOSUB ,(format nil "~C" letter))
         X <- X)
                    
     (define-op-key
         (:location (make-location
                     :row 1
                     :col ,col
                     :category-1 :FLOW-CONTROL)
                    :modelist '(:RUN-WITH-PROG)
                    :abbreviation ,(format nil
                                           "GSB-~C"
                                           (char-downcase letter))
                    :implicit-x ,implicit-x
                    :updates-last-x nil
                    :documentation ,(format nil
                                            "Call program label ~C"
                                            (char-downcase letter)))
         :RETCODE <- '(:GOSUB ,(format nil "~C"
                                       (char-downcase letter)))
         X <- X)))
                    


(define-toprow-key (1 #\A "1/x" "Reciprocal")
    X <- (/ 1.0d0 X))

(define-toprow-key (2 #\B "sqrt" "Square root")
    X <- (sqrt (to-double-fp X)))

(define-toprow-key (3 #\C "y^x" "Power")
    X <- (expt Y X))

(define-toprow-key (4 #\D "rolld" "Roll stack down"
                      :implicit-x nil
                      :updates-last-x nil)
  (roll-stack-down))

(define-toprow-key (5 #\E "x<>y" "Exchange X and Y"
                      :updates-last-x nil)
  X <- Y
  Y <- X)

We’ve just talked about memory, flags, and indirection.  Memory and flag operations take an argument, the name of the memory register or flag to be used.  Until now, our operations have drawn all their arguments from the stack, so now we will need to modify the code to allow the possibility of additional user-supplied arguments.

The flags only make sense in the context of a running program.  The flag-test operation allows the program to indicate whether or not the following program step should be skipped.  That means we are going to need to have these operation functions return a code.  We will ask that they return a list, as some return codes might have arguments themselves, such as branching directives that take a target name or address.

The convention will be this: keys that take an argument must declare so in the struct, and that argument will then be represented by the symbol ARG in the forms.  The default return value is ‘(:NORMAL-EXIT).  If a different value is to be returned, it must be explicitly set in the forms with a construct of the form :RETCODE <- (…).  If an error is signaled, the return code will always be set to ‘(:ERROR).

These new requirements require us to modify convert-to-setf-forms, expand-rules, and register-key-structure.  Here is the new code for those functions:

(defun convert-to-setf-forms (rules-list 
                              vars-used 
                              output-varnames
                              return-code-symbol
                              return-code-var)
  (let (rv)
    (do ((pos rules-list (cdr pos)))
        ((not pos) rv)
      (cond
        ((and (eq (second pos) *assign*)
              (eq (first pos) return-code-symbol))
         (append rv `((setf ,return-code-var ,(third pos))))
         (setf pos (cddr pos)))
        ((and (member (first pos) vars-used)
              (eq (second pos) *assign*)
              (third pos))
         (setf rv
               (append rv 
                       `((setf ,(nth (position (first pos)
                                               vars-used)
                                     output-varnames)
                               ,(third pos)))))
         (setf pos (cddr pos)))
        ((listp (first pos))
         (setf rv 
               (append 
                rv 
                (list 
                 (convert-to-setf-forms (first pos)
                                        vars-used
                                        output-varnames
                                        return-code-symbol
                                        return-code-var)))))
        (t
         (setf rv (append rv (list (first pos)))))))))

(defun expand-rules (rules-list &key
                                  update-last-x
                                  op-takes-arg)
  (let* ((varnames '(X Y Z W))
         (stack-var (gensym))
         (state-var (gensym))
         (ret-code-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 *assign* (get-symbols-in-list
                                      rules-list)))
               (= 1 (length rules-list)))
      (setf rules-list 
            (append (list (first varnames) *assign*)
                    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
             *rcode* ret-code-var))

      `(lambda ,(if op-takes-arg
                    `(,stack-var ,state-var ARG)
                    `(,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)))

              (set-flag (name)
                (set-flag-fcn ,stack-var name))
              (clear-flag (name)
                (clear-flag-fcn ,stack-var name))
              (get-flag (name)
                (get-flag-fcn ,stack-var name))

              (push-val (val)
                (push-stack ,stack-var val))

              (store-mem (name val)
                (cond
                  ((string-equal name "(i)")
                   (store-memory ,stack-var
                                 (get-i-register ,stack-var)
                                 val
                                 :indirection t))
                  (t
                   (store-memory ,stack-var name val))))
              (recall-mem (name)
                (cond
                  ((string-equal name "(i)")
                   (recall-memory ,stack-var
                                  (get-i-register ,stack-var)
                                  :indirection t))
                  (t
                   (recall-memory ,stack-var name))))

              (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)
                   (,ret-code-var '(:NORMAL-EXIT)))

             (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)
                (setf ,ret-code-var '(:ERROR))
                (recover-stack ,stack-var)))
             ,ret-code-var))))))

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

Here are some keys defined with the new code:

(define-op-key
    (:location (make-location
                :row 5
                :col 1
                :shift :H-BLACK
                :category-1 :FLAGS)
               :takes-argument t
               :abbreviation "SF"
               :documentation "Sets a flag")
  (set-flag ARG)
  X <- X)

(define-op-key
    (:location (make-location
                :row 6
                :col 1
                :shift :H-BLACK
                :category-1 :FLAGS)
               :takes-argument t
               :abbreviation "CF"
               :documentation "Clears a flag")
  (clear-flag ARG)
  X <- X)

(define-op-key
    (:location (make-location
                :row 7
                :col 1
                :shift :H-BLACK
                :category-1 :FLAGS)
               :takes-argument t
               :abbreviation "F?"
               :documentation "Tests a flag")
  (when (not (get-flag ARG))
    :RETCODE <- '(:SKIP-NEXT-STEP))
  X <- X)

(define-op-key
    (:location (make-location
                :row 3
                :col 3
                :category-1 :MEMORY
                :cateogry-2 :MEMORY-STORE)
               :takes-argument t
               :abbreviation "STO"
               :documentation "Saves a memory register")
  (store-mem ARG X)
  X <- X)

(define-op-key
    (:location (make-location
                :row 3
                :col 4
                :category-1 :MEMORY
                :cateogry-2 :MEMORY-RECALL)
               :takes-argument t
               :abbreviation "RCL"
               :documentation "Saves a memory register")
  (recall-mem ARG))


(define-op-key
    (:location (make-location
                :row 3
                :col 3
                :shift :H-BLACK
                :category-1 :MEMORY
                :cateogry-2 :MEMORY-STORE)
               :abbreviation "STI"
               :documentation "Saves by indirection")
  (store-mem "(i)" X)
  X <- X)

(define-op-key
    (:location (make-location
                :row 3
                :col 4
                :shift :H-BLACK
                :category-1 :MEMORY
                :cateogry-2 :MEMORY-RECALL)
               :abbreviation "RCI"
               :documentation "Recalls by indirection")
  (recall-mem "(i)"))

These changes are checked into the github repository under the tag v2014-10-27.

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”.