X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=9852810e3bbf85b38c300fdba69b0426ad710e90;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=adc28e09d3877f3625c6786066c5472d13f119f4;hpb=e8011f7c83587a9dc1b13281d0cc974bb0b054be;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index adc28e0..9852810 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -191,9 +191,14 @@ Other commands: In the debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line stream) - (map-backtrace (lambda (frame) - (print-frame-call frame stream :number t)) - :count count) + (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*) + *suppress-print-errors* + 'serious-condition)) + (*print-circle* t)) + (handler-bind ((print-not-readable #'print-unreadably)) + (map-backtrace (lambda (frame) + (print-frame-call frame stream :number t)) + :count count))) (fresh-line stream) (values)) @@ -295,11 +300,11 @@ thread, NIL otherwise." :deleted ((push (frame-call-arg element location frame) reversed-result)) :rest ((lambda-var-dispatch (second element) location nil - (progn - (setf reversed-result - (append (reverse (sb!di:debug-var-value - (second element) frame)) - reversed-result)) + (let ((rest (sb!di:debug-var-value (second element) frame))) + (if (listp rest) + (setf reversed-result (append (reverse rest) reversed-result)) + (push (make-unprintable-object "unavailable &REST argument") + reversed-result)) (return-from enumerating)) (push (make-unprintable-object "unavailable &REST argument") @@ -413,21 +418,20 @@ thread, NIL otherwise." ;; For the function arguments, we can just print normally. (let ((*print-length* nil) (*print-level* nil)) - (prin1 (ensure-printable-object name) stream)) - ;; If we hit a &REST arg, then print as many of the values as - ;; possible, punting the loop over lambda-list variables since any - ;; other arguments will be in the &REST arg's list of values. - (let ((print-args (ensure-printable-object args)) - ;; Special case *PRINT-PRETTY* for eval frames: if - ;; *PRINT-LINES* is 1, turn off pretty-printing. - (*print-pretty* - (if (and (eql 1 *print-lines*) - (member name '(eval simple-eval-in-lexenv))) - nil - *print-pretty*))) - (if (listp print-args) - (format stream "~{ ~_~S~}" print-args) - (format stream " ~S" print-args)))) + (prin1 name stream)) + ;; If we hit a &REST arg, then print as many of the values + ;; as possible, punting the loop over lambda-list variables + ;; since any other arguments will be in the &REST arg's list + ;; of values. Special case *PRINT-PRETTY* for eval frames: + ;; if *PRINT-LINES* is 1, turn off pretty-printing. + (let ((*print-pretty* + (if (and (eql 1 *print-lines*) + (member name '(eval simple-eval-in-lexenv))) + nil + *print-pretty*)))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))) (when kind (format stream "[~S]" kind)))) (when (>= verbosity 2) @@ -583,7 +587,7 @@ reset to ~S." ;; definitely preferred, because the FORMAT alternative was acting odd. (pprint-logical-block (stream nil) (format stream - "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A" + "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A" (type-of condition) #!+sb-thread sb!thread:*current-thread* #!-sb-thread nil @@ -1267,19 +1271,29 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (location (sb!di:frame-code-location *current-frame*)) (prefix (read-if-available nil)) (any-p nil) - (any-valid-p nil)) + (any-valid-p nil) + (more-context nil) + (more-count nil)) (dolist (v (sb!di:ambiguous-debug-vars - d-fun - (if prefix (string prefix) ""))) + d-fun + (if prefix (string prefix) ""))) (setf any-p t) (when (eq (sb!di:debug-var-validity v location) :valid) (setf any-valid-p t) + (case (sb!di::debug-var-info v) + (:more-context + (setf more-context (sb!di:debug-var-value v *current-frame*))) + (:more-count + (setf more-count (sb!di:debug-var-value v *current-frame*)))) (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" (sb!di:debug-var-symbol v) (zerop (sb!di:debug-var-id v)) (sb!di:debug-var-id v) (sb!di:debug-var-value v *current-frame*)))) - + (when (and more-context more-count) + (format *debug-io* "~S = ~S~%" + 'more + (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count)))) (cond ((not any-p) (format *debug-io* @@ -1591,15 +1605,33 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (!def-debug-command "RESTART-FRAME" () (if (frame-has-debug-tag-p *current-frame*) - (let* ((call-list (frame-call-as-list *current-frame*)) - (fun (fdefinition (car call-list)))) - (unwind-to-frame-and-call *current-frame* - (lambda () - (apply fun (cdr call-list))))) + (multiple-value-bind (fname args) (frame-call *current-frame*) + (multiple-value-bind (fun arglist ok) + (if (and (legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args t) + (values (sb!di:debug-fun-fun (sb!di:frame-debug-fun *current-frame*)) + (frame-args-as-list *current-frame*) + nil)) + (when (and fun + (or ok + (y-or-n-p "~@"))) + (unwind-to-frame-and-call *current-frame* + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist)))) + (format *debug-io* + "Can't restart ~S: no function for frame." + *current-frame*))) (format *debug-io* - "~@"))) + "~@" + *current-frame*))) (defun frame-has-debug-tag-p (frame) #!+unwind-to-frame-and-call-vop