Now, as we start to work on the behaviour of the number keys, it becomes clear that there are some problems with the way this has been laid out, and we’ll have to back up and change some things.

If you are typing in a number on the keypad, and then hit a function key, such as ‘+’, there is an implied press of the ENTER key before the ‘+’.  However, our tokens have been set up to return their results when the function was called.  If we call the operation on ‘+’, and it doesn’t hand back a token, it’s too late to perform the ENTER operation.  We have to know whether or not a key is a token key before we call its associated function.

We can also make some changes to the modal keys.  We had CHS, EEX, and CLX as behaving differently when pressed while a number was being input as when pressed before number construction begins.  However, we can make EEX consistent by changing its behaviour in the number assembly code, we don’t have to define two logical key structures for it.  Similarly, CLX could be implemented as a non-token key, by first pushing the number being assembled onto the stack, and then replacing it with zero.  That leaves only CHS to behave differently.

To work towards this, we’ll have some code that puts together a number based on tokens it receives.  We call this the token assembler structure, and the associated functions are here:

(defstruct (token-assembler)
  (mantissa-sign        1)
  (mantissa             (make-string-output-stream))
  (mantissa-digits      0)
  (exponent-sign        1)
  (exponent             (make-array 2))
  (exponent-digits      0)

  (translation          '((:0 . "0") (:1 . "1") (:2 . "2")
                          (:3 . "3") (:4 . "4") (:5 . "5")
                          (:6 . "6") (:7 . "7") (:8 . "8")
                          (:9 . "9") (:DOT . ".") (:EEX . "d")
                          (:ENTER . :ENTER) (:CLX . :CLX)
                          (:CHS . :CHS)))

  (seen-dot             nil)
  (seen-expt            nil)
  (finalized            nil))


(defun produce-result (assembler)
  (let ((s (make-string-output-stream))
        (e-digs (token-assembler-exponent-digits assembler)))
    (when (= (token-assembler-mantissa-sign assembler) -1)
      (format s "-"))
    (format s "~A" (get-output-stream-string (token-assembler-mantissa assembler)))
    (format s "d")
    (when (= (token-assembler-exponent-sign assembler) -1)
      (format s "-"))
    (cond
      ((= e-digs 0) (format s "0"))
      (t
       (dotimes (i e-digs)
         (format s (aref (token-assembler-exponent assembler) i)))))
    (get-output-stream-string s)))
      

(defun add-token (assembler token)
  (when (eq token :CLX)
    (return-from add-token :RESET))
  (when (eq token :ENTER)
    (return-from add-token :FINALIZE))
  (if (token-assembler-seen-expt assembler)
      (add-token-to-exponent assembler token)
      (add-token-to-mantissa assembler token))
  :CONSTRUCTING)

(defun add-token-to-exponent (assembler token)
  (with-slots ((sign exponent-sign)
               (exp exponent)
               (exp-n exponent-digits)
               (table translation))
      assembler
    (let ((val (cdr (assoc token table))))
      (ecase token
        ((:0 :1 :2 :3 :4 :5 :6 :7 :8 :9)
         (cond
           ((= exp-n 2)
            (setf (aref exp 0) (aref exp 1))
            (setf (aref exp 1) val))
           (t
            (setf (aref exp exp-n) val)
            (incf exp-n))))
        ((:DOT :EEX)
         ;; do nothing
         )
        (:CHS
         (setf sign (* -1 sign)))))))


(defun add-token-to-mantissa (assembler token)
  (with-slots ((sign mantissa-sign)
               (mant mantissa)
               (mant-n mantissa-digits)
               (seen-dot seen-dot)
               (seen-expt seen-expt)
               (table translation))
      assembler
    (let ((val (cdr (assoc token table))))
      (ecase token
        ((:0 :1 :2 :3 :4 :5 :6 :7 :8 :9)
         (when (< mant-n *digits-in-display*)
           (format mant "~A" val)
           (incf mant-n)))
        (:DOT
         (unless seen-dot
           (setf seen-dot t)
           (format mant ".")))
        (:EEX
         (when (= mant-n 0)
           (format mant "1")
           (incf mant-n))
         (setf seen-expt t))
        (:CHS
         (setf sign (* -1 sign)))))))