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