X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=535b4298519a86e644d6f9aa5279b92d0890bfad;hb=74a48d09e08aead6f67204878bdf9be4f448e1e8;hp=f8c18b7cc0a4cfd5cdeb4b8ea2b0951e72d628cb;hpb=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index f8c18b7..535b429 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -54,17 +54,8 @@ "Should the debugger display beginner-oriented help messages?") (defun debug-prompt (stream) - - ;; old behavior, will probably go away in sbcl-0.7.x - (format stream "~%~D" (sb!di:frame-number *current-frame*)) - (dotimes (i *debug-command-level*) - (write-char #\] stream)) - (write-char #\space stream) - - ;; planned new behavior, delayed since it will break ILISP - #+nil (format stream - "~%~D~:[~;[~D~]] " + "~%~W~:[~;[~W~]] " (sb!di:frame-number *current-frame*) (> *debug-command-level* 1) *debug-command-level*)) @@ -219,19 +210,19 @@ Function and macro commands: (cond ((sb!di:code-location-p place) (find place info-list :key #'breakpoint-info-place - :test #'(lambda (x y) (and (sb!di:code-location-p y) - (sb!di:code-location= x y))))) + :test (lambda (x y) (and (sb!di:code-location-p y) + (sb!di:code-location= x y))))) (t (find place info-list - :test #'(lambda (x-debug-fun y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-fun-p y-place) - (eq x-debug-fun y-place) - (or (not kind) - (eq kind (sb!di:breakpoint-kind - y-breakpoint)))))))))) + :test (lambda (x-debug-fun y-info) + (let ((y-place (breakpoint-info-place y-info)) + (y-breakpoint (breakpoint-info-breakpoint + y-info))) + (and (sb!di:debug-fun-p y-place) + (eq x-debug-fun y-place) + (or (not kind) + (eq kind (sb!di:breakpoint-kind + y-breakpoint)))))))))) ;;; If LOC is an unknown location, then try to find the block start ;;; location. Used by source printing to some information instead of @@ -757,24 +748,24 @@ reset to ~S." (print-frame-call *current-frame* :verbosity 2) (loop (catch 'debug-loop-catcher - (handler-bind ((error #'(lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t - "~&error flushed (because ~ - ~S is set)" - '*flush-debug-errors*) - (/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + ;; FIXME: Doing input on *DEBUG-IO* + ;; and output on T seems broken. + (format t + "~&error flushed (because ~ + ~S is set)" + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) ;; We have to bind level for the restart function created by ;; WITH-SIMPLE-RESTART. (let ((level *debug-command-level*) (restart-commands (make-restart-commands))) (with-simple-restart (abort - "Reduce debugger level (to debug level ~D)." + "Reduce debugger level (to debug level ~W)." level) (debug-prompt *debug-io*) (force-output *debug-io*) @@ -845,9 +836,9 @@ reset to ~S." name)))) (location (sb!di:frame-code-location *current-frame*)) ;; Let's only deal with valid variables. - (vars (remove-if-not #'(lambda (v) - (eq (sb!di:debug-var-validity v location) - :valid)) + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) temp))) (declare (list vars)) (cond ((null vars) @@ -888,9 +879,9 @@ reset to ~S." ;; name. ((and (not exact) (find-if-not - #'(lambda (v) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) + (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + (sb!di:debug-var-symbol-name (car vars)))) (cdr vars))) (error "specification ambiguous:~%~{ ~A~%~}" (mapcar #'sb!di:debug-var-symbol-name @@ -903,7 +894,7 @@ reset to ~S." (let ((v (find id vars :key #'sb!di:debug-var-id))) (unless v (error - "invalid variable ID, ~D: should have been one of ~S" + "invalid variable ID, ~W: should have been one of ~S" id (mapcar #'sb!di:debug-var-id vars))) ,(ecase ref-or-set @@ -1029,7 +1020,7 @@ argument") (let* ((name (if (symbolp form) (symbol-name form) - (format nil "~D" form))) + (format nil "~W" form))) (len (length name)) (res nil)) (declare (simple-string name) @@ -1072,10 +1063,10 @@ argument") (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun - #'(lambda () - (/show0 "in restart-command closure, about to i-r-i") - (invoke-restart-interactively restart)))) - (push (cons (format nil "~d" num) restart-fun) commands) + (lambda () + (/show0 "in restart-command closure, about to i-r-i") + (invoke-restart-interactively restart)))) + (push (cons (prin1-to-string num) restart-fun) commands) (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) (push (cons name restart-fun) commands)))) @@ -1175,9 +1166,9 @@ argument") (nth num *debug-restarts*)) (symbol (find num *debug-restarts* :key #'restart-name - :test #'(lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) (t (format t "~S is invalid as a restart name.~%" num) (return-from restart-debug-command nil))))) @@ -1231,7 +1222,7 @@ argument") (setf any-p t) (when (eq (sb!di:debug-var-validity v location) :valid) (setf any-valid-p t) - (format t "~S~:[#~D~;~*~] = ~S~%" + (format t "~S~:[#~W~;~*~] = ~S~%" (sb!di:debug-var-symbol v) (zerop (sb!di:debug-var-id v)) (sb!di:debug-var-id v) @@ -1353,10 +1344,10 @@ argument") (setq *cached-readtable* (copy-readtable)) (set-dispatch-macro-character #\# #\. - #'(lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token))) + (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) *cached-readtable*)) (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) @@ -1412,8 +1403,8 @@ argument") (when prev-location (let ((this-num (1- this-num))) (if (= prev-num this-num) - (format t "~&~D: " prev-num) - (format t "~&~D-~D: " prev-num this-num))) + (format t "~&~W: " prev-num) + (format t "~&~W-~W: " prev-num this-num))) (print-code-location-source-form prev-location 0) (when *print-location-kind* (format t "~S " (sb!di:code-location-kind prev-location)))