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.