;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; CodeStepper-v2.1.lisp -- a facility for the step-by-step evaluation of code ;; ;; PROGRAMMER ;; Lee Spector ;; Assistant Professor of Computer Science ;; School of CCS ;; Hampshire College ;; Amherst, MA 01002 USA ;; lspector@hampshire.edu ;; ;; DATE ;; July 19, 1995 #| DESCRIPTION CodeStepper is a facility for the step-by-step evaluation of code. This can be particularly useful for simulating the parallel execution of several pieces of code. Code-stepping the code after it has completed causes evaluation to restart at the beginning. Any Lisp functions that take a constant number of arguments (no optional or keyword arguments) may be used in the code, but they must first be "registered." Macros and special forms may NOT be used, but there is a pseudo-macro facility for obtaining macro-like behavior. HISTORY CodeStepper-v2.1.lisp (date: July 19, 1995) fixed a bug in the handling of NIL. CodeStepper-v2.lisp (date: January 26, 1995) was the original v2. The primary improvement in v2 is that code-steppers containing pseudomacros can be quickly created AND executed -- in v1 one had to trade fast creation for fast execution. CodeStepper-v1.lisp (date: January 7, 1995) used an different, incompatible implementation of pseudomacros. USE First make sure that all of the functions used in the code are "registered" as step-functions using REGISTER-STEP-FUNCTION. The second argument to REGISTER-STEP-FUNCTION is the number of arguments that should be passed to the registered function; note that this must be a constant (there are no provisions for optional or keyword parameters). Macros and special forms will not work correctly as step-functions, but there is a pseudo-macro facility for obtaining macro-like behavior (see below). Examples: (register-step-function '+ 2) (register-step-function 'print 1) One can unregister all step-functions with (CLEAR-STEP-FUNCTIONS). Next make sure that all of the pseudo-macros used in the code are registered as pseudo-macros using REGISTER-PSEUDO-MACRO. The second argument to REGISTER-PSEUDO-MACRO is the number of arguments that should be passed to the registered pseudo-macro. Pseudo-macros are defined using DEFINE-PSEUDO-MACRO. The correct definition of pseudo-macros is nontrivial and is not explained here; perhaps in the next version. Some example pseudo-macro definitions are at the end of the file. These include numerical versions of "if-then-else" and "while" along with "quote." One can unregister all pseudomacros with (CLEAR-PSEUDO-MACROS). Next create a code-stepper object using the standard CLOS MAKE-INSTANCE function, passing your code as a :code keyword argument. Example: ;; first make sure the functions are registered (clear-step-functions) (mapc #'register-step-function '(+ * print) '(2 2 1)) ;; now create the code stepper (defvar my-cs) (setq my-cs (make-instance 'code-stepper :code '(print (+ 1 (print (* 2 3)))))) Next execute the code step-by-step by calling STEP-CODE. Examples: (step-code my-cs) (dotimes (i 20) (step-code my-cs)) OPTIONS None (*COMPILE-PSEUDO-MACRO-LAMBDAS* was removed as of v2). THEORY Code-steppers work by translating their Lisp code into reverse polish notation and executing the resulting rpn code with an internal stack. Pseudo-macros introduce complications; these are handled by including local-storage-accecssing function calls in the rpn code. |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; step-function database (defvar *step-functions* nil "the database of registered step-functions") (defun register-step-function (fn num-params) ;; remove any previously registered step-function of the same name (when (assoc fn *step-functions*) (setq *step-functions* (remove fn *step-functions* :key #'car))) ;; register the new one (setq *step-functions* (acons fn num-params *step-functions*))) (defun step-function-p (fn) (assoc fn *step-functions*)) (defun step-function-params (fn) (cdr (assoc fn *step-functions*))) (defun clear-step-functions () (setq *step-functions* nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; pseudo-macro database (defvar *pseudo-macros* nil "the pseudo-macro database") (defvar *pseudo-macro-functions* nil "the names of functions that may be incorporated into calls pushed by pseudo-macros onto the rpn instructions. Forms beginning with these symbols will not be 'flattened' in the production of rpn code.") (defun define-pseudo-macro (name definition) (setf (get name 'pseudo-macro-definition) definition)) (defun register-pseudo-macro (name num-params) ;; remove any previously registered pseudo-macro of the same name (when (assoc name *pseudo-macros*) (setq *pseudo-macros* (remove name *pseudo-macros* :key #'car))) ;; register the new one (setq *pseudo-macros* (acons name num-params *pseudo-macros*))) (defun pseudo-macro-p (name) (assoc name *pseudo-macros*)) (defun pseudo-macro-params (name) (cdr (assoc name *pseudo-macros*))) (defun pseudo-macro-definition (name) (get name 'pseudo-macro-definition)) (defun clear-pseudo-macros () (setq *pseudo-macros* nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; code-stepper class and major functions (defclass code-stepper () ((code :accessor code :initarg :code :initform '(print 'empty-code) :documentation "the Lisp code to be evaluated step-by-step") (rpn-code :accessor rpn-code :documentation "the complete rpn translation of the code") (fragments :accessor fragments :initform (make-hash-table) :documentation "miscellaneous storage for use by pseudo-macros") (instructions :accessor instructions :documentation "the currently executing copy of the rpn code -- will be popped as executed, manipulated by pseudo-macros, etc.") (stack :accessor stack :initarg :stack :initform nil :documentation "the result stack, used in the execution of the rpn code in the instructions"))) (defmethod initialize-instance :after ((cs code-stepper) &rest init-args) (declare (ignore init-args)) ;; convert the code to rpn and store the rpn code (setf (rpn-code cs) (convert-code (code cs) cs)) ;; copy the rpn code to the instructions slot to prepare for execution (setf (instructions cs) (rpn-code cs))) (defun store-fragment (tag code cs) (setf (gethash tag (fragments cs)) code)) (defun retrieve-fragment (tag cs) (gethash tag (fragments cs))) (defun step-code (cs) (when (null (instructions cs)) (setf (instructions cs) (rpn-code cs)) (setf (stack cs) nil)) (let ((fn (pop (instructions cs))) (args nil)) (cond ((and (consp fn) ;; it's a form pushed by a pseudo-macro (member (car fn) *pseudo-macro-functions*)) (apply (car fn) (cons cs (cdr fn)))) ((step-function-p fn) ;; it's a step-function name (push (apply fn (dotimes (i (step-function-params fn) args) (push (pop (stack cs)) args))) (stack cs))) (t (push (eval fn) (stack cs))))) ;; it's a terminal (values)) (defun convert-code (code cs) (if (listp code) (reverse (flatten-non-pseudo-macro-fn (convert-pseudo-macros (reverse-arguments code) cs))) code)) (defun convert-pseudo-macros (code cs) (if (listp code) (if (pseudo-macro-p (first code)) (funcall (pseudo-macro-definition (first code)) code cs) (mapcar #'(lambda (code-part) (convert-pseudo-macros code-part cs)) code)) code)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utilities (defun flatten-non-pseudo-macro-fn (input &optional accumulator (stop-at-nil nil)) "Return a flat list of the atoms in the input. Ex: (flatten '((a) (b (c) d))) => (a b c d). Leaves calls to pseudo-macro functions untouched. After Norvig." (cond ((and stop-at-nil (null input)) accumulator) ((atom input) (cons input accumulator)) ((member (car input) *pseudo-macro-functions*) (cons input accumulator)) (t (flatten-non-pseudo-macro-fn (first input) (flatten-non-pseudo-macro-fn (rest input) accumulator t))))) (defmacro push-all (stuff place) `(if (listp ,stuff) (setf ,place (append ,stuff ,place)) (push ,stuff ,place))) (defun reverse-arguments (expression) "Returns a copy of expression with the order of all arguments reversed. For example, (foo bar baz biz) becomes (foo biz baz bar). Leaves calls to psuedo-macros untouched." (cond ((not (consp expression)) expression) ((pseudo-macro-p (car expression)) expression) (t (cons (car expression) (mapcar #'reverse-arguments (reverse (cdr expression))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; pseudo-macro definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;"if not zero" (inz n then-code else-code) (defun ifnz-fn (cs then-code-tag else-code-tag) (if (not (= 0 (pop (stack cs)))) (push-all (retrieve-fragment then-code-tag cs) (instructions cs)) (push-all (retrieve-fragment else-code-tag cs) (instructions cs)))) (pushnew 'ifnz-fn *pseudo-macro-functions*) (define-pseudo-macro 'ifnz #'(lambda (call cs) (let ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (then-code (convert-code (third call) cs)) (else-code (convert-code (fourth call) cs)) (then-code-tag (gensym)) (else-code-tag (gensym))) (store-fragment then-code-tag then-code cs) (store-fragment else-code-tag else-code cs) (list (list 'ifnz-fn then-code-tag else-code-tag) partial-n-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;"if less than" (if< n m code-if-n n m code-if-n>m else-code) (defun if>-fn (cs then-code-tag else-code-tag) (if (> (pop (stack cs)) (pop (stack cs))) (push-all (retrieve-fragment then-code-tag cs) (instructions cs)) (push-all (retrieve-fragment else-code-tag cs) (instructions cs)))) (pushnew 'if>-fn *pseudo-macro-functions*) (define-pseudo-macro 'if> #'(lambda (call cs) (let ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (partial-m-code (convert-pseudo-macros (reverse-arguments (third call)) cs)) (then-code (convert-code (fourth call) cs)) (else-code (convert-code (fifth call) cs)) (then-code-tag (gensym)) (else-code-tag (gensym))) (store-fragment then-code-tag then-code cs) (store-fragment else-code-tag else-code cs) (list (list 'if<-fn then-code-tag else-code-tag) partial-n-code partial-m-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "if equal" (if= n m code-if-n=m else-code) (defun if=-fn (cs then-code-tag else-code-tag) (if (= (pop (stack cs)) (pop (stack cs))) (push-all (retrieve-fragment then-code-tag cs) (instructions cs)) (push-all (retrieve-fragment else-code-tag cs) (instructions cs)))) (pushnew 'if=-fn *pseudo-macro-functions*) (define-pseudo-macro 'if= #'(lambda (call cs) (let ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (partial-m-code (convert-pseudo-macros (reverse-arguments (third call)) cs)) (then-code (convert-code (fourth call) cs)) (else-code (convert-code (fifth call) cs)) (then-code-tag (gensym)) (else-code-tag (gensym))) (store-fragment then-code-tag then-code cs) (store-fragment else-code-tag else-code cs) (list (list 'if=-fn then-code-tag else-code-tag) partial-n-code partial-m-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "while not zero" (whilenz n body) (defun whilenz-fn (cs n-code-tag body-code-tag repeat-code-tag) (if (= 0 (pop (stack cs))) (push 0 (stack cs)) (progn (push (retrieve-fragment repeat-code-tag cs) (instructions cs)) (push-all (retrieve-fragment n-code-tag cs) (instructions cs)) (push-all (retrieve-fragment body-code-tag cs) (instructions cs))))) (pushnew 'whilenz-fn *pseudo-macro-functions*) (define-pseudo-macro 'whilenz #'(lambda (call cs) (let* ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (n-code (reverse (flatten-non-pseudo-macro-fn partial-n-code))) (body-code (convert-code (third call) cs)) (n-code-tag (gensym)) (body-code-tag (gensym)) (repeat-code-tag (gensym)) (repeat-code (list 'whilenz-fn n-code-tag body-code-tag repeat-code-tag))) (store-fragment n-code-tag n-code cs) (store-fragment body-code-tag body-code cs) (store-fragment repeat-code-tag repeat-code cs) (list repeat-code partial-n-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "while greater" (while> n m body) (defun while>-fn (cs n-code-tag m-code-tag body-code-tag repeat-code-tag) (if (> (pop (stack cs)) (pop (stack cs))) (progn (push (retrieve-fragment repeat-code-tag cs) (instructions cs)) (push-all (retrieve-fragment n-code-tag cs) (instructions cs)) (push-all (retrieve-fragment m-code-tag cs) (instructions cs)) (push-all (retrieve-fragment body-code-tag cs) (instructions cs))) (push 0 (stack cs)))) (pushnew 'while>-fn *pseudo-macro-functions*) (define-pseudo-macro 'while> #'(lambda (call cs) (let* ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (n-code (reverse (flatten-non-pseudo-macro-fn partial-n-code))) (partial-m-code (convert-pseudo-macros (reverse-arguments (third call)) cs)) (m-code (reverse (flatten-non-pseudo-macro-fn partial-m-code))) (body-code (convert-code (fourth call) cs)) (n-code-tag (gensym)) (m-code-tag (gensym)) (body-code-tag (gensym)) (repeat-code-tag (gensym)) (repeat-code (list 'while>-fn n-code-tag m-code-tag body-code-tag repeat-code-tag))) (store-fragment n-code-tag n-code cs) (store-fragment m-code-tag m-code cs) (store-fragment body-code-tag body-code cs) (store-fragment repeat-code-tag repeat-code cs) (list repeat-code partial-n-code partial-m-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "while less" (while< n m body) (defun while<-fn (cs n-code-tag m-code-tag body-code-tag repeat-code-tag) (if (< (pop (stack cs)) (pop (stack cs))) (progn (push (retrieve-fragment repeat-code-tag cs) (instructions cs)) (push-all (retrieve-fragment n-code-tag cs) (instructions cs)) (push-all (retrieve-fragment m-code-tag cs) (instructions cs)) (push-all (retrieve-fragment body-code-tag cs) (instructions cs))) (push 0 (stack cs)))) (pushnew 'while<-fn *pseudo-macro-functions*) (define-pseudo-macro 'while< #'(lambda (call cs) (let* ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (n-code (reverse (flatten-non-pseudo-macro-fn partial-n-code))) (partial-m-code (convert-pseudo-macros (reverse-arguments (third call)) cs)) (m-code (reverse (flatten-non-pseudo-macro-fn partial-m-code))) (body-code (convert-code (fourth call) cs)) (n-code-tag (gensym)) (m-code-tag (gensym)) (body-code-tag (gensym)) (repeat-code-tag (gensym)) (repeat-code (list 'while<-fn n-code-tag m-code-tag body-code-tag repeat-code-tag))) (store-fragment n-code-tag n-code cs) (store-fragment m-code-tag m-code cs) (store-fragment body-code-tag body-code cs) (store-fragment repeat-code-tag repeat-code cs) (list repeat-code partial-n-code partial-m-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "while equal" (while= n m body) (defun while=-fn (cs n-code-tag m-code-tag body-code-tag repeat-code-tag) (if (= (pop (stack cs)) (pop (stack cs))) (progn (push (retrieve-fragment repeat-code-tag cs) (instructions cs)) (push-all (retrieve-fragment n-code-tag cs) (instructions cs)) (push-all (retrieve-fragment m-code-tag cs) (instructions cs)) (push-all (retrieve-fragment body-code-tag cs) (instructions cs))) (push 0 (stack cs)))) (pushnew 'while=-fn *pseudo-macro-functions*) (define-pseudo-macro 'while= #'(lambda (call cs) (let* ((partial-n-code (convert-pseudo-macros (reverse-arguments (second call)) cs)) (n-code (reverse (flatten-non-pseudo-macro-fn partial-n-code))) (partial-m-code (convert-pseudo-macros (reverse-arguments (third call)) cs)) (m-code (reverse (flatten-non-pseudo-macro-fn partial-m-code))) (body-code (convert-code (fourth call) cs)) (n-code-tag (gensym)) (m-code-tag (gensym)) (body-code-tag (gensym)) (repeat-code-tag (gensym)) (repeat-code (list 'while=-fn n-code-tag m-code-tag body-code-tag repeat-code-tag))) (store-fragment n-code-tag n-code cs) (store-fragment m-code-tag m-code cs) (store-fragment body-code-tag body-code cs) (store-fragment repeat-code-tag repeat-code cs) (list repeat-code partial-n-code partial-m-code)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; "quote" (quote whatever) (defun quote-fn (cs quoted-stuff-tag) (push (retrieve-fragment quoted-stuff-tag cs) (stack cs))) (pushnew 'quote-fn *pseudo-macro-functions*) (define-pseudo-macro 'quote #'(lambda (call cs) (let ((quoted-stuff-tag (gensym))) (store-fragment quoted-stuff-tag (second call) cs) (list 'quote-fn quoted-stuff-tag)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; register the pseudo-macros defined above (clear-pseudo-macros) (register-pseudo-macro 'ifnz 3) (register-pseudo-macro 'if< 4) (register-pseudo-macro 'if> 4) (register-pseudo-macro 'if= 4) (register-pseudo-macro 'whilenz 2) (register-pseudo-macro 'while> 3) (register-pseudo-macro 'while< 3) (register-pseudo-macro 'while= 3) (register-pseudo-macro 'quote 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; examples #| ;; a small set of registered step-functions for the examples (clear-step-functions) (mapc #'register-step-function '(+ * print list) '(2 2 1 2)) (defvar my-cs nil "a variable to hold example code-steppers") ;; a simple code-stepper (setq my-cs (make-instance 'code-stepper :code '(print (+ 1 (print (* 2 3)))))) ;; step it 20 times (dotimes (i 20) (step-code my-cs)) ;; the following demonstrates argument evaluation order (setq my-cs (make-instance 'code-stepper :code '(print (+ (print 1) (print 2))))) (dotimes (i 20) (step-code my-cs)) ;; a symbolic example, using the quote pseudo-macro (setq my-cs (make-instance 'code-stepper :code '(print (list (print (list 'a '(b))) (print (list nil nil)))))) (dotimes (i 20) (step-code my-cs)) ;; the following use the ifnz pseudo-macro (setq my-cs (make-instance 'code-stepper :code '(ifnz 1 (print 1) (print 2)))) (dotimes (i 20) (step-code my-cs)) (setq my-cs (make-instance 'code-stepper :code '(ifnz 1 (print (ifnz 0 22 99)) (print 2)))) (dotimes (i 20) (step-code my-cs)) (setq my-cs (make-instance 'code-stepper :code '(ifnz 1 (print (ifnz (print 0) 22 (+ (print 33) (print 66)))) (print 2)))) (dotimes (i 20) (step-code my-cs)) ;; the following uses the if< pseudo-macro (setq my-cs (make-instance 'code-stepper :code '(if< 1 2 (print 1) (print 2)))) (dotimes (i 20) (step-code my-cs)) ;; the following use the whilenz pseudo-macro (setq my-cs (make-instance 'code-stepper :code '(whilenz 1 (print 1)))) (dotimes (i 20) (step-code my-cs)) (defvar mynum) (setq my-cs (make-instance 'code-stepper :code '(whilenz mynum (print mynum)))) (setq mynum 5) (dotimes (i 20) (step-code my-cs)) (setq mynum 0) (dotimes (i 20) (step-code my-cs)) ;; the following uses the while> pseudo-macro (defvar mynum1) (defvar mynum2) (setq my-cs (make-instance 'code-stepper :code '(while> mynum1 mynum2 (print (+ mynum1 mynum2))))) (setq mynum1 5 mynum2 4) (dotimes (i 20) (step-code my-cs)) (setq mynum1 0) ;; 20 iterations leaves us in the guts so we'll still get a 9 printed here (dotimes (i 20) (step-code my-cs)) ;; but not here (dotimes (i 20) (step-code my-cs)) |#