"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*))
(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
(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*)
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)
;; 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
(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
(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)
(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))))
(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)))))
(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)
(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*))))
(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)))
projects / sbcl.git / blobdiff