Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9876
Modified Files: inspect.lisp Log Message: Improve print-dynamic-context & friends.
--- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/12 16:10:47 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld frodef@acm.org ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.60 2007/04/12 16:10:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -38,6 +38,11 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit))
+(defun protect-unbound (x) + (if (not (eq x (%run-time-context-slot nil 'new-unbound-value))) + x + (format nil "#<unbound #x~X>" (%object-lispval x)))) + (defun stack-frame-funobj (stack frame) (stack-frame-ref stack frame -1))
@@ -113,6 +118,13 @@ (defun dynamic-context-tag (dynamic-context) (stack-frame-ref nil dynamic-context 1 :lisp))
+(defun stack-index-frame (stack index start-frame) + "Find the frame in which index is included." + (do ((frame start-frame (stack-frame-uplink stack frame))) + ((eq 0 frame) nil) + (when (< index frame) + (return frame)))) + (defmacro with-each-dynamic-context ((&optional start-context result) &rest clauses) "Only use this if you know what you're doing. See run-time.lisp." (let ((context (gensym "dynamic-context-")) @@ -120,6 +132,7 @@ (name (gensym "dynamic-name-")) (bind-clause (find :binding clauses :key #'caar)) (catch-clause (find :catch clauses :key #'caar)) + (lcatch-clause (find :lexical-catch clauses :key #'caar)) (up-clause (find :unwind-protect clauses :key #'caar)) (basic-restart-clause (find :basic-restart clauses :key #'caar))) `(do ((,context ,(if start-context start-context '(current-dynamic-context)) @@ -134,7 +147,8 @@ (multiple-value-bind ,(cdar bind-clause) (values ,context (stack-frame-ref nil ,context 0 :lisp) - (stack-frame-ref nil ,context 2 :lisp)) + (stack-frame-ref nil ,context 2 :lisp) + (stack-frame-ref nil ,context 1 :lisp)) ,@(rest bind-clause))))) ,@(when up-clause `(((eq ,tag (load-global-constant unwind-protect-tag)) @@ -153,29 +167,48 @@ (stack-frame-ref nil ,context -1 :lisp)) ; name 0 (length (cdar basic-restart-clause)))) ,@(rest basic-restart-clause)))))) + ,@(when lcatch-clause + `(((eq ,tag (load-global-constant unbound-function)) + (multiple-value-bind ,(cdar lcatch-clause) + (values ,context) + ,@(rest lcatch-clause))))) ,@(when catch-clause `((t (multiple-value-bind ,(cdar catch-clause) (values ,context ,tag) ,@(rest catch-clause))))))))))
-(defun pdc (&rest types) - (declare (dynamic-extent types)) - (let ((types (or types '(:restarts :bindings :catch)))) - (with-each-dynamic-context () - ((:basic-restart context name) - (when (member :restarts types) - (format t "~&restart: ~S fmt: ~S/~S [#x~X]" name - (rc-format context) - (rc-args context) - context))) - ((:binding context name value) - (declare (ignore context)) - (when (member :bindings types) - (format t "~&bind: ~S => ~Z" name value))) - ((:catch context tag) - (declare (ignore context)) - (when (member :catch types) - (format t "~&catch: ~Z: ~S" tag tag)))))) + +(defun print-dynamic-context (&key + (types '(:restart :binding :catch :unwind-protect :lexical-catch) types-p) + variables (spartan t) (show-functions t)) + (when (and variables (not types-p)) + (setf types '(:binding))) + (let ((format-values (if spartan "~Z" "~S")) + (last-frame nil)) + (flet ((info (context type format &rest args) + (when (member type types) + (let ((frame (stack-index-frame nil context (current-stack-frame)))) + (when (and show-functions frame (not (eq frame last-frame))) + (setf last-frame frame) + (format t "~& [[[in ~A]]]~%" (stack-frame-funobj nil frame)))) + (format t "~&[~8,'0X] " context) + (apply #'format t format args)))) + (with-each-dynamic-context () + ((:basic-restart context name) + (info context :basic-restart + "restart: ~S fmt: ~S/~S [#x~X]" + name (rc-format context) (rc-args context) context)) + ((:binding context name value scratch) + (when (or (null variables) + (member name variables)) + (info context :binding "bind: ~S => ~@? [scratch: ~@?]" + name format-values value format-values scratch))) + ((:unwind-protect context) + (info context :unwind-protect "unwind-protect")) + ((:lexical-catch context tag) + (info context :lexical-catch "lexical-catch" tag tag)) + ((:catch context tag) + (info context :catch "catch: ~Z: ~S" tag tag))))))
(define-compiler-macro %location-object (&environment env location tag) (assert (movitz:movitz-constantp tag env))