(format t "~&~S: FUN-END in ~S" bp-number
(sb!di:debug-fun-name place))))))
\f
-;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
+;;;; MAIN-HOOK-FUN for steps and breakpoints
;;; This must be passed as the hook function. It keeps track of where
;;; STEP breakpoints are.
-(defun main-hook-function (current-frame breakpoint &optional return-vals
- fun-end-cookie)
+(defun main-hook-fun (current-frame breakpoint &optional return-vals
+ fun-end-cookie)
(setf *default-breakpoint-debug-fun*
(sb!di:frame-debug-fun current-frame))
(dolist (step-info *step-breakpoints*)
(break string)
(format t "~A" string)))
(t
- (break "error in main-hook-function: unknown breakpoint"))))))
+ (break "unknown breakpoint"))))))
\f
;;; Set breakpoints at the next possible code-locations. After calling
;;; this, either (CONTINUE) if in the debugger or just let program flow
(when bp-info
(sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
bp-info))))
- (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location
+ (let ((bp (sb!di:make-breakpoint #'main-hook-fun code-location
:kind :code-location)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info code-location bp 0)
*step-breakpoints*))))
(t
(let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-function debug-fun
+ (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
:kind :fun-end)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info debug-fun bp 0)
;;; lambda-list variables since any other arguments will be in the
;;; &REST arg's list of values.
(defun print-frame-call-1 (frame)
- (let* ((d-fun (sb!di:frame-debug-fun frame))
- (loc (sb!di:frame-code-location frame))
- (results (list (sb!di:debug-fun-name d-fun))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame))
+ (loc (sb!di:frame-code-location frame))
+ (reversed-args nil))
+
+ ;; Construct function arguments in REVERSED-ARGS.
(handler-case
- (dolist (ele (sb!di:debug-fun-lambda-list d-fun))
+ (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
(lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) results))
- :optional ((push (frame-call-arg (second ele) loc frame) results))
- :keyword ((push (second ele) results)
- (push (frame-call-arg (third ele) loc frame) results))
- :deleted ((push (frame-call-arg ele loc frame) results))
+ :required ((push (frame-call-arg ele loc frame) reversed-args))
+ :optional ((push (frame-call-arg (second ele) loc frame)
+ reversed-args))
+ :keyword ((push (second ele) reversed-args)
+ (push (frame-call-arg (third ele) loc frame)
+ reversed-args))
+ :deleted ((push (frame-call-arg ele loc frame) reversed-args))
:rest ((lambda-var-dispatch (second ele) loc
nil
(progn
- (setf results
+ (setf reversed-args
(append (reverse (sb!di:debug-var-value
(second ele) frame))
- results))
+ reversed-args))
(return))
(push (make-unprintable-object
"unavailable &REST argument")
- results)))))
+ reversed-args)))))
(sb!di:lambda-list-unavailable
()
- (push (make-unprintable-object "lambda list unavailable") results)))
- (pprint-logical-block (*standard-output* nil)
- (let ((x (nreverse (mapcar #'ensure-printable-object results))))
- (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))
- (when (sb!di:debug-fun-kind d-fun)
+ (push (make-unprintable-object "lambda list unavailable")
+ reversed-args)))
+
+ (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
+ (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args))))
+ ;; Since we go to some trouble to make nice informative function
+ ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+ ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
+ ;; For the function arguments, we can just print normally.
+ (format t "~{ ~_~S~}" args)))
+
+ (when (sb!di:debug-fun-kind debug-fun)
(write-char #\[)
- (prin1 (sb!di:debug-fun-kind d-fun))
+ (prin1 (sb!di:debug-fun-kind debug-fun))
(write-char #\]))))
(defun ensure-printable-object (object)
;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
;; but
;; 1. It doesn't affect our internal special variables
- ;; like *CURRENT-LEVEL*.
+ ;; like *CURRENT-LEVEL-IN-PRINT*.
;; 2. It isn't customizable.
;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
;; to the same value as the toplevel default.
;; helpful behavior for a debugger.
;; We try to remedy all these problems with explicit
;; rebindings here.
- (sb!kernel:*current-level* 0)
+ (sb!kernel:*current-level-in-print* 0)
(*print-length* *debug-print-length*)
(*print-level* *debug-print-level*)
(*readtable* *debug-readtable*)
(format *error-output*
"~&(caught ~S trying to print ~S when entering debugger)~%"
(type-of condition)
- '*debug-condition*)))
+ '*debug-condition*)
+ (when (typep condition 'cell-error)
+ ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+ (format *error-output*
+ "~&(CELL-ERROR-NAME = ~S)~%)"
+ (cell-error-name *debug-condition*)))))
;; After the initial error/condition/whatever announcement to
;; *ERROR-OUTPUT*, we become interactive, and should talk on
(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
`(let* ((temp (etypecase name
- (symbol (sb!di:debug-fun-symbol-variables
+ (symbol (sb!di:debug-fun-symbol-vars
(sb!di:frame-debug-fun *current-frame*)
name))
(simple-string (sb!di:ambiguous-debug-vars
*default-breakpoint-debug-fun*))))))
(setup-fun-start ()
(let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-start))
(setf break (sb!di:preprocess-for-eval break code-loc))
print-functions))))
(setup-fun-end ()
(setf bp
- (sb!di:make-breakpoint #'main-hook-function
+ (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-end))
(setf break
print-functions)))
(setup-code-location ()
(setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
- place
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun place
:kind :code-location))
(dolist (form print)
(push (cons
projects / sbcl.git / blobdiff