X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=535b4298519a86e644d6f9aa5279b92d0890bfad;hb=74a48d09e08aead6f67204878bdf9be4f448e1e8;hp=25b55c59b6ad6b02e441cca82fff6ee2d47f2835;hpb=0af84c9c90b1277be6863df8f28f1f0e5512323c;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 25b55c5..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*)) @@ -157,8 +148,8 @@ Function and macro commands: (declaim (type integer *number-of-steps*)) ;;; This is used when listing and setting breakpoints. -(defvar *default-breakpoint-debug-function* nil) -(declaim (type (or list sb!di:debug-function) *default-breakpoint-debug-function*)) +(defvar *default-breakpoint-debug-fun* nil) +(declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*)) ;;;; code location utilities @@ -194,11 +185,10 @@ Function and macro commands: (setf next-list (next-code-locations (first next-list)))) next-list))) -;;; Returns a list of code-locations of the possible breakpoints of the -;;; debug-function passed. -(defun possible-breakpoints (debug-function) +;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN. +(defun possible-breakpoints (debug-fun) (let ((possible-breakpoints nil)) - (sb!di:do-debug-function-blocks (debug-block debug-function) + (sb!di:do-debug-fun-blocks (debug-block debug-fun) (unless (sb!di:debug-block-elsewhere-p debug-block) (if *only-block-start-locations* (push (first-code-location debug-block) possible-breakpoints) @@ -208,8 +198,8 @@ Function and macro commands: (push code-location possible-breakpoints)))))) (nreverse possible-breakpoints))) -;;; Searches the info-list for the item passed (code-location, -;;; debug-function, or breakpoint-info). If the item passed is a debug +;;; Search the info-list for the item passed (CODE-LOCATION, +;;; DEBUG-FUN, or BREAKPOINT-INFO). If the item passed is a debug ;;; function then kind will be compared if it was specified. The kind ;;; if also compared if a breakpoint-info is passed since it's in the ;;; breakpoint. The info structure is returned if found. @@ -220,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-function y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-function-p y-place) - (eq x-debug-function 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 @@ -256,10 +246,9 @@ Function and macro commands: ;;; info about a made breakpoint (defstruct (breakpoint-info (:copier nil)) ;; where we are going to stop - (place (required-argument) - :type (or sb!di:code-location sb!di:debug-function)) + (place (missing-arg) :type (or sb!di:code-location sb!di:debug-fun)) ;; the breakpoint returned by sb!di:make-breakpoint - (breakpoint (required-argument) :type sb!di:breakpoint) + (breakpoint (missing-arg) :type sb!di:breakpoint) ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is ;; non-NIL, drop into the debugger. (break #'identity :type function) @@ -272,10 +261,10 @@ Function and macro commands: (print nil :type list) ;; the number used when listing the possible breakpoints within a ;; function. Could also be a symbol such as start or end. - (code-location-number (required-argument) :type (or symbol integer)) + (code-location-number (missing-arg) :type (or symbol integer)) ;; the number used when listing the breakpoints active and to delete ;; breakpoints - (breakpoint-number (required-argument) :type integer)) + (breakpoint-number (missing-arg) :type integer)) ;;; Return a new BREAKPOINT-INFO structure with the info passed. (defun create-breakpoint-info (place breakpoint code-location-number @@ -307,23 +296,23 @@ Function and macro commands: "~&~S: ~S in ~S" bp-number loc-number - (sb!di:debug-function-name (sb!di:code-location-debug-function - place)))) - (:function-start - (format t "~&~S: FUNCTION-START in ~S" bp-number - (sb!di:debug-function-name place))) - (:function-end - (format t "~&~S: FUNCTION-END in ~S" bp-number - (sb!di:debug-function-name place)))))) + (sb!di:debug-fun-name (sb!di:code-location-debug-fun + place)))) + (:fun-start + (format t "~&~S: FUN-START in ~S" bp-number + (sb!di:debug-fun-name place))) + (:fun-end + (format t "~&~S: FUN-END in ~S" bp-number + (sb!di:debug-fun-name place)))))) ;;;; MAIN-HOOK-FUNCTION 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 - function-end-cookie) - (setf *default-breakpoint-debug-function* - (sb!di:frame-debug-function current-frame)) + fun-end-cookie) + (setf *default-breakpoint-debug-fun* + (sb!di:frame-debug-fun current-frame)) (dolist (step-info *step-breakpoints*) (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info)) (let ((bp-info (location-in-list step-info *breakpoints*))) @@ -347,7 +336,7 @@ Function and macro commands: (print-common-info () (build-string (with-output-to-string (*standard-output*) - (when function-end-cookie + (when fun-end-cookie (format t "~%Return values: ~S" return-vals)) (when condition (when (breakpoint-info-print bp-hit-info) @@ -416,11 +405,11 @@ Function and macro commands: (push (create-breakpoint-info code-location bp 0) *step-breakpoints*)))) (t - (let* ((debug-function (sb!di:frame-debug-function *current-frame*)) - (bp (sb!di:make-breakpoint #'main-hook-function debug-function - :kind :function-end))) + (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*)) + (bp (sb!di:make-breakpoint #'main-hook-function debug-fun + :kind :fun-end))) (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info debug-function bp 0) + (push (create-breakpoint-info debug-fun bp 0) *step-breakpoints*)))))))) ;;;; STEP @@ -439,7 +428,7 @@ Function and macro commands: (*standard-output* *debug-io*)) #!+sb-doc "Show a listing of the call stack going down from the current frame. In the - debugger, the current frame is indicated by the prompt. Count is how many + debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line *standard-output*) (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) @@ -502,11 +491,11 @@ Function and macro commands: ;;; 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-function frame)) + (let* ((d-fun (sb!di:frame-debug-fun frame)) (loc (sb!di:frame-code-location frame)) - (results (list (sb!di:debug-function-name d-fun)))) + (results (list (sb!di:debug-fun-name d-fun)))) (handler-case - (dolist (ele (sb!di:debug-function-lambda-list d-fun)) + (dolist (ele (sb!di:debug-fun-lambda-list d-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)) @@ -530,9 +519,9 @@ Function and macro commands: (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-function-kind d-fun) + (when (sb!di:debug-fun-kind d-fun) (write-char #\[) - (prin1 (sb!di:debug-function-kind d-fun)) + (prin1 (sb!di:debug-fun-kind d-fun)) (write-char #\])))) (defun ensure-printable-object (object) @@ -552,7 +541,7 @@ Function and macro commands: ;;; Prints a representation of the function call causing FRAME to ;;; exist. VERBOSITY indicates the level of information to output; -;;; zero indicates just printing the debug-function's name, and one +;;; zero indicates just printing the DEBUG-FUN's name, and one ;;; indicates displaying call-like, one-liner format with argument ;;; values. (defun print-frame-call (frame &key (verbosity 1) (number nil)) @@ -694,28 +683,32 @@ reset to ~S." (internal-debug)))))) (defun show-restarts (restarts s) - (when restarts - (format s "~&restarts:~%") - (let ((count 0) - (names-used '(nil)) - (max-name-len 0)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (when name - (let ((len (length (princ-to-string name)))) - (when (> len max-name-len) - (setf max-name-len len)))))) - (unless (zerop max-name-len) - (incf max-name-len 3)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (cond ((member name names-used) - (format s "~& ~2D: ~@VT~A~%" count max-name-len restart)) - (t - (format s "~& ~2D: [~VA] ~A~%" - count (- max-name-len 3) name restart) - (push name names-used)))) - (incf count))))) + (cond ((null restarts) + (format s + "~&(no restarts: If you didn't do this on purpose, ~ + please report it as a bug.)~%")) + (t + (format s "~&restarts:~%") + (let ((count 0) + (names-used '(nil)) + (max-name-len 0)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (when name + (let ((len (length (princ-to-string name)))) + (when (> len max-name-len) + (setf max-name-len len)))))) + (unless (zerop max-name-len) + (incf max-name-len 3)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (cond ((member name names-used) + (format s "~& ~2D: ~@VT~A~%" count max-name-len restart)) + (t + (format s "~& ~2D: [~VA] ~A~%" + count (- max-name-len 3) name restart) + (push name names-used)))) + (incf count)))))) ;;; This calls DEBUG-LOOP, performing some simple initializations ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into @@ -746,30 +739,33 @@ reset to ~S." (*stack-top* (or *stack-top-hint* *real-stack-top*)) (*stack-top-hint* nil) (*current-frame* *stack-top*)) - (handler-bind ((sb!di:debug-condition (lambda (condition) - (princ condition *debug-io*) - (throw 'debug-loop-catcher nil)))) + (handler-bind ((sb!di:debug-condition + (lambda (condition) + (princ condition *debug-io*) + (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil)))) (fresh-line) (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*) - (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*) @@ -801,32 +797,12 @@ reset to ~S." (t (funcall cmd-fun))))))))))))))) -;;; FIXME: As far as I know, the CMU CL X86 codebase has never -;;; supported access to the environment of the debugged function. It -;;; would be really, really nice to make that work! (Until then, -;;; non-NIL *AUTO-EVAL-IN-FRAME* seems to be useless, and as of -;;; sbcl-0.6.10 it even seemed to be actively harmful, since the -;;; debugger gets confused when trying to unwind the frames which -;;; arise in SIGINT interrupts. So it's set to NIL.) -(defvar *auto-eval-in-frame* nil - #!+sb-doc - "When set, evaluations in the debugger's command loop occur relative - to the current frame's environment without the need of debugger - forms that explicitly control this kind of evaluation. In an ideal - world, the default would be T, but since unfortunately the X86 - debugger support isn't good enough to make this useful, the - default is NIL instead.") - ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) (/noshow (fboundp 'compile)) - (/noshow (and (fboundp 'compile) *auto-eval-in-frame*)) (setq +++ ++ ++ + + - - expr) - (let* ((values (multiple-value-list - (if (and (fboundp 'compile) *auto-eval-in-frame*) - (sb!di:eval-in-frame *current-frame* -) - (eval -)))) + (let* ((values (multiple-value-list (eval -))) (*standard-output* *debug-io*)) (/noshow "done with EVAL in DEBUG-EVAL-PRINT") (fresh-line) @@ -852,17 +828,17 @@ reset to ~S." (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name - (symbol (sb!di:debug-function-symbol-variables - (sb!di:frame-debug-function *current-frame*) + (symbol (sb!di:debug-fun-symbol-variables + (sb!di:frame-debug-fun *current-frame*) name)) (simple-string (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-function *current-frame*) + (sb!di:frame-debug-fun *current-frame*) 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) @@ -903,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 @@ -918,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 @@ -958,7 +934,7 @@ reset to ~S." (define-var-operation :set value)) ;;; This returns the COUNT'th arg as the user sees it from args, the -;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a +;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a ;;; potential DEBUG-VAR from the lambda-list, then the second value is ;;; T. If this returns a keyword symbol or a value from a rest arg, ;;; then the second value is NIL. @@ -993,12 +969,12 @@ argument") (defun arg (n) #!+sb-doc - "Returns the N'th argument's value if possible. Argument zero is the first + "Return the N'th argument's value if possible. Argument zero is the first argument in a frame's default printed representation. Count keyword/value pairs as separate arguments." (multiple-value-bind (var lambda-var-p) - (nth-arg n (handler-case (sb!di:debug-function-lambda-list - (sb!di:frame-debug-function *current-frame*)) + (nth-arg n (handler-case (sb!di:debug-fun-lambda-list + (sb!di:frame-debug-fun *current-frame*)) (sb!di:lambda-list-unavailable () (error "No argument values are available.")))) (if lambda-var-p @@ -1044,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) @@ -1076,7 +1052,7 @@ argument") (setf (car cmds) (caar cmds)))))))) ;;; Return a list of debug commands (in the same format as -;;; *debug-commands*) that invoke each active restart. +;;; *DEBUG-COMMANDS*) that invoke each active restart. ;;; ;;; Two commands are made for each restart: one for the number, and ;;; one for the restart name (unless it's been shadowed by an earlier @@ -1087,8 +1063,10 @@ argument") (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun - #'(lambda () (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)))) @@ -1165,7 +1143,7 @@ argument") ;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.) ;;; ;;;(!def-debug-command "QUIT" () -;;; (throw 'sb!impl::top-level-catcher nil)) +;;; (throw 'sb!impl::toplevel-catcher nil)) ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in ;;; SBCL you just type the CONTINUE restart name instead (or "RESTART @@ -1176,6 +1154,7 @@ argument") ;;; (error "There is no restart named CONTINUE.")) (!def-debug-command "RESTART" () + (/show0 "doing RESTART debug-command") (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) @@ -1187,12 +1166,13 @@ 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))))) + (/show0 "got RESTART") (if restart (invoke-restart-interactively restart) ;; FIXME: Even if this isn't handled by WARN, it probably @@ -1229,7 +1209,7 @@ argument") (!def-debug-command-alias "P" "PRINT") (!def-debug-command "LIST-LOCALS" () - (let ((d-fun (sb!di:frame-debug-function *current-frame*))) + (let ((d-fun (sb!di:frame-debug-fun *current-frame*))) (if (sb!di:debug-var-info-available d-fun) (let ((*standard-output* *debug-io*) (location (sb!di:frame-code-location *current-frame*)) @@ -1242,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) @@ -1288,44 +1268,44 @@ argument") (defvar *cached-readtable* nil) (declaim (type (or readtable null) *cached-readtable*)) -(pushnew #'(lambda () - (setq *cached-debug-source* nil *cached-source-stream* nil - *cached-readtable* nil)) - sb!int:*before-save-initializations*) +(pushnew (lambda () + (setq *cached-debug-source* nil *cached-source-stream* nil + *cached-readtable* nil)) + *before-save-initializations*) -;;; We also cache the last top-level form that we printed a source for +;;; We also cache the last toplevel form that we printed a source for ;;; so that we don't have to do repeated reads and calls to ;;; FORM-NUMBER-TRANSLATIONS. -(defvar *cached-top-level-form-offset* nil) -(declaim (type (or index null) *cached-top-level-form-offset*)) -(defvar *cached-top-level-form*) +(defvar *cached-toplevel-form-offset* nil) +(declaim (type (or index null) *cached-toplevel-form-offset*)) +(defvar *cached-toplevel-form*) (defvar *cached-form-number-translations*) ;;; Given a code location, return the associated form-number -;;; translations and the actual top-level form. We check our cache --- +;;; translations and the actual top level form. We check our cache --- ;;; if there is a miss, we dispatch on the kind of the debug source. -(defun get-top-level-form (location) +(defun get-toplevel-form (location) (let ((d-source (sb!di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) - (eql (sb!di:code-location-top-level-form-offset location) - *cached-top-level-form-offset*)) - (values *cached-form-number-translations* *cached-top-level-form*) - (let* ((offset (sb!di:code-location-top-level-form-offset location)) + (eql (sb!di:code-location-toplevel-form-offset location) + *cached-toplevel-form-offset*)) + (values *cached-form-number-translations* *cached-toplevel-form*) + (let* ((offset (sb!di:code-location-toplevel-form-offset location)) (res (ecase (sb!di:debug-source-from d-source) - (:file (get-file-top-level-form location)) + (:file (get-file-toplevel-form location)) (:lisp (svref (sb!di:debug-source-name d-source) offset))))) - (setq *cached-top-level-form-offset* offset) + (setq *cached-toplevel-form-offset* offset) (values (setq *cached-form-number-translations* (sb!di:form-number-translations res offset)) - (setq *cached-top-level-form* res)))))) + (setq *cached-toplevel-form* res)))))) -;;; Locate the source file (if it still exists) and grab the top-level -;;; form. If the file is modified, we use the top-level-form offset +;;; Locate the source file (if it still exists) and grab the top level +;;; form. If the file is modified, we use the top level form offset ;;; instead of the recorded character offset. -(defun get-file-top-level-form (location) +(defun get-file-toplevel-form (location) (let* ((d-source (sb!di:code-location-debug-source location)) - (tlf-offset (sb!di:code-location-top-level-form-offset location)) + (tlf-offset (sb!di:code-location-toplevel-form-offset location)) (local-tlf-offset (- tlf-offset (sb!di:debug-source-root-number d-source))) (char-offset @@ -1364,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*)))) @@ -1375,7 +1355,7 @@ argument") (defun print-code-location-source-form (location context) (let* ((location (maybe-block-start-location location)) (form-num (sb!di:code-location-form-number location))) - (multiple-value-bind (translations form) (get-top-level-form location) + (multiple-value-bind (translations form) (get-toplevel-form location) (unless (< form-num (length translations)) (error "The source path no longer exists.")) (prin1 (sb!di:source-path-context form @@ -1396,23 +1376,23 @@ argument") ;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be ;;; used by sbreakpoint. (!def-debug-command "LIST-LOCATIONS" () - (let ((df (read-if-available *default-breakpoint-debug-function*))) + (let ((df (read-if-available *default-breakpoint-debug-fun*))) (cond ((consp df) - (setf df (sb!di:function-debug-function (eval df))) - (setf *default-breakpoint-debug-function* df)) + (setf df (sb!di:fun-debug-fun (eval df))) + (setf *default-breakpoint-debug-fun* df)) ((or (eq ':c df) - (not *default-breakpoint-debug-function*)) - (setf df (sb!di:frame-debug-function *current-frame*)) - (setf *default-breakpoint-debug-function* df))) + (not *default-breakpoint-debug-fun*)) + (setf df (sb!di:frame-debug-fun *current-frame*)) + (setf *default-breakpoint-debug-fun* df))) (setf *possible-breakpoints* (possible-breakpoints df))) (let ((continue-at (sb!di:frame-code-location *current-frame*))) - (let ((active (location-in-list *default-breakpoint-debug-function* - *breakpoints* :function-start)) + (let ((active (location-in-list *default-breakpoint-debug-fun* + *breakpoints* :fun-start)) (here (sb!di:code-location= - (sb!di:debug-function-start-location - *default-breakpoint-debug-function*) continue-at))) + (sb!di:debug-fun-start-location + *default-breakpoint-debug-fun*) continue-at))) (when (or active here) - (format t "::FUNCTION-START ") + (format t "::FUN-START ") (when active (format t " *Active*")) (when here (format t " *Continue here*")))) @@ -1423,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))) @@ -1440,9 +1420,9 @@ argument") (not prev-location) (not (eq (sb!di:code-location-debug-source code-location) (sb!di:code-location-debug-source prev-location))) - (not (eq (sb!di:code-location-top-level-form-offset + (not (eq (sb!di:code-location-toplevel-form-offset code-location) - (sb!di:code-location-top-level-form-offset + (sb!di:code-location-toplevel-form-offset prev-location))) (not (eq (sb!di:code-location-form-number code-location) (sb!di:code-location-form-number prev-location)))) @@ -1451,10 +1431,10 @@ argument") (incf this-num)))) - (when (location-in-list *default-breakpoint-debug-function* + (when (location-in-list *default-breakpoint-debug-fun* *breakpoints* - :function-end) - (format t "~&::FUNCTION-END *Active* ")))) + :fun-end) + (format t "~&::FUN-END *Active* ")))) (!def-debug-command-alias "LL" "LIST-LOCATIONS") @@ -1467,7 +1447,7 @@ argument") (print-functions nil) (function nil) (bp) - (place *default-breakpoint-debug-function*)) + (place *default-breakpoint-debug-fun*)) (flet ((get-command-line () (let ((command-line nil) (unique '(nil))) @@ -1485,27 +1465,27 @@ argument") (:break (setf break (pop command-line))) (:function (setf function (eval (pop command-line))) - (setf *default-breakpoint-debug-function* - (sb!di:function-debug-function function)) - (setf place *default-breakpoint-debug-function*) + (setf *default-breakpoint-debug-fun* + (sb!di:fun-debug-fun function)) + (setf place *default-breakpoint-debug-fun*) (setf *possible-breakpoints* (possible-breakpoints - *default-breakpoint-debug-function*)))))) - (setup-function-start () - (let ((code-loc (sb!di:debug-function-start-location place))) + *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 place - :kind :function-start)) + :kind :fun-start)) (setf break (sb!di:preprocess-for-eval break code-loc)) (setf condition (sb!di:preprocess-for-eval condition code-loc)) (dolist (form print) (push (cons (sb!di:preprocess-for-eval form code-loc) form) print-functions)))) - (setup-function-end () + (setup-fun-end () (setf bp (sb!di:make-breakpoint #'main-hook-function place - :kind :function-end)) + :kind :fun-end)) (setf break ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..) ;; forms should be converted to shiny new (LAMBDA ..) forms. @@ -1537,9 +1517,9 @@ argument") (set-vars-from-command-line (get-command-line)) (cond ((or (eq index :start) (eq index :s)) - (setup-function-start)) + (setup-fun-start)) ((or (eq index :end) (eq index :e)) - (setup-function-end)) + (setup-fun-end)) (t (setup-code-location))) (sb!di:activate-breakpoint bp) @@ -1591,8 +1571,8 @@ argument") (!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) - (debug-fun (sb!di:code-location-debug-function curloc)) - (function (sb!di:debug-function-function debug-fun))) + (debug-fun (sb!di:code-location-debug-fun curloc)) + (function (sb!di:debug-fun-fun debug-fun))) (if function (describe function) (format t "can't figure out the function for this frame"))))