From fa160162a3a75322f8cb4142cb2b5735e28f4643 Mon Sep 17 00:00:00 2001 From: david Date: Tue, 23 Dec 2008 16:06:17 +0100 Subject: [PATCH] asm debugging help: use a FLET trick to get opcode names into the stack --- asm/asm.lisp | 79 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 40 insertions(+), 39 deletions(-) diff --git a/asm/asm.lisp b/asm/asm.lisp index 94ffbd3..3d47ae6 100644 --- a/asm/asm.lisp +++ b/asm/asm.lisp @@ -415,45 +415,46 @@ (flet ((defop (name args opcode &optional (pop 0) (push 0) (pop-scope 0) (push-scope 0) (local 0) (flag 0)) `(setf (gethash ',name *opcodes*) - (lambda (,@(mapcar 'car args) ;;&aux (#:debug-name ',name) - ) - ,@(when args `((declare (ignorable ,@(mapcar 'car args))))) - ;;(format t "assemble ~a ~%" ',name) - ,@(loop with op-name = name - for (name type) in args - for interner = (third (assoc type coders)) - when interner - collect `(setf ,name (,interner ,name)) - ;;when (eq 'q30 type) - ;;collect `(when (and (consp ,name) - ;; (eql 'qname (car ,name))) - ;; (setf ,name (apply 'qname (rest ,name)))) - when (eq 'ofs24 type) - collect (label-to-offset name op-name) - when (eq 'counted-ofs24 type) - collect (labels-to-offsets name)) - ,@(unless (and (numberp pop) (numberp push) (= 0 pop push)) - `((adjust-stack ,pop ,push))) - ,@(unless (and (numberp pop-scope) (numberp push-scope) - (= 0 pop-scope push-scope)) - `((adjust-scope ,pop-scope ,push-scope))) - ,@(unless (and (numberp local) (zerop local)) - `((when (and *current-method* - (> ,local (local-count *current-method*))) - (setf (local-count *current-method*) ,local)))) - ,@(unless (and (numberp flag) (zerop flag)) - `((when *current-method* - (setf (flags *current-method*) - (logior ,local (flags *current-method*)))))) - ,(if (null args) - `(list ,opcode) - `(append - (list ,opcode) - ,@(loop - for (name type) in args - for encoder = (second (assoc type coders)) - when encoder - collect `(,encoder ,name))))))) + (flet ((,name (,@(mapcar 'car args) ;;&aux (#:debug-name ',name) + ) + ,@(when args `((declare (ignorable ,@(mapcar 'car args))))) + ;;(format t "assemble ~a ~%" ',name) + ,@(loop with op-name = name + for (name type) in args + for interner = (third (assoc type coders)) + when interner + collect `(setf ,name (,interner ,name)) + ;;when (eq 'q30 type) + ;;collect `(when (and (consp ,name) + ;; (eql 'qname (car ,name))) + ;; (setf ,name (apply 'qname (rest ,name)))) + when (eq 'ofs24 type) + collect (label-to-offset name op-name) + when (eq 'counted-ofs24 type) + collect (labels-to-offsets name)) + ,@(unless (and (numberp pop) (numberp push) (= 0 pop push)) + `((adjust-stack ,pop ,push))) + ,@(unless (and (numberp pop-scope) (numberp push-scope) + (= 0 pop-scope push-scope)) + `((adjust-scope ,pop-scope ,push-scope))) + ,@(unless (and (numberp local) (zerop local)) + `((when (and *current-method* + (> ,local (local-count *current-method*))) + (setf (local-count *current-method*) ,local)))) + ,@(unless (and (numberp flag) (zerop flag)) + `((when *current-method* + (setf (flags *current-method*) + (logior ,local (flags *current-method*)))))) + ,(if (null args) + `(list ,opcode) + `(append + (list ,opcode) + ,@(loop + for (name type) in args + for encoder = (second (assoc type coders)) + when encoder + collect `(,encoder ,name)))))) + #',name))) ;; fixme: gensyms (defop-disasm (name args opcode &rest ignore) (declare (ignore ignore)) -- 2.11.4.GIT