;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: ZL-USER; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Written by Gregor, 8/02/87 14:45:18
;;; while running on SPIFF from FEP0:>Inc-Genera-7-1-from-Genera-7-1.load.1
;;; with Genera 7.1, Experimental Ether 3.21, IP-TCP 52.16, Local-Mods 5.1,
;;; microcode 3670-XSQ-MIC 396, FEP 127, FEP0:>v127-lisp.flod(55),
;;; FEP0:>v127-loaders.flod(55), FEP0:>v127-debug.flod(34), FEP0:>v127-info.flod(55).
(NOTE-PRIVATE-PATCH
"Changes to make rel 7 debugger know about associate the name of a
closure with the actual closure (its environment) rather than the closure
function.")
;;;
;;; The general idea is to make the debugger associate the name of a closure
;;; with the actual closure, not with the closure function. In this hack
;;; implementation, this is done using a hash-table which associates closure
;;; environments with closure names.
;;;
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer 3600-low.lisp
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defvar *closure-names* (lisp:make-hash-table :test #'eq :size 500))
;;;
;;; This code is adapted from frame-lexical-environment.
;;;
(defun function-name-for-debugger (frame)
(let ((function (frame-function frame)))
(or
;; if this is a closure and we can get its environment and there
;; is an entry for that environment in *closure-names*, return
;; that. Otherwise just return the name of the closure function.
(and (not (zerop (frame-lexical-called frame)))
(lisp:compiled-function-p function)
(let* ((local-map
(assq :local-map
(si:compiled-function-debugging-info function)))
;; Closures over (flavors) methods put the environment
;; into local 2, otherwise local 0 (actually arg 0) is
;; the environment.
(env-local
(car (rassq 'compiler:.lexical-environment-pointer.
(cdr local-map))))
;; Use NIL for the environment if something went wrong
;; or if this is a closure over a flavors method.
(env (and (zerop env-local)
(frame-local-value frame env-local))))
(and env
(gethash env *closure-names*))))
(function-name function))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun error-reporter-frame-p (frame)
;; An error here would probably cause an infinite recursion of errors, so just return NIL
;; so we can get into the Debugger. I realize this might paper over problems.
(ignore-errors
(let ((function (frame-function frame)))
(or (assq 'error-reporter (debugging-info function))
(let ((function-spec (function-name-for-debugger frame)))
(loop while (and (listp function-spec) (eq (first function-spec) ':internal)) do
(setq function-spec (second function-spec)))
(typecase function-spec
(:symbol (get function-spec :error-reporter))
(:list (and (validate-function-spec function-spec)
(or (si:function-spec-get function-spec :error-reporter)
(selectq (car function-spec)
((flavor:method flavor:whopper flavor:combined)
;; There must be a better way to do this
(eq (flavor:method-generic function-spec) 'signal-condition))
(otherwise nil)))))))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
;; True if frame is not just an internal frame of an interpreted function
(defun frame-interesting-p (frame
&optional (censor-invisible-frames *censor-invisible-frames*))
(labels ((uninternalize-fspec (fspec)
;; Internal functions of uninteresting functions are uninteresting
(if (and (listp fspec) (eq (first fspec) :internal))
(if (and (or (eq (fourth fspec) 'si:with-process-interactive-priority-body)
(eq (fourth fspec) 'si:with-process-non-interactive-priority-body))
(not (memq :process-priority *invisible-frame-types-to-show*)))
;; These things aren't interesting
(return-from frame-interesting-p nil)
(uninternalize-fspec (second fspec)))
fspec)))
(if (and censor-invisible-frames
(frame-invisible-p frame))
nil
(let* ((function (frame-function frame))
(fspec (uninternalize-fspec (function-name-for-debugger frame))))
(and (neq fspec function) ;Not an unnamed LAMBDA expression
(not (member fspec *uninteresting-functions*))
(not (member fspec si:*digested-special-forms*)))))))
(defprop invisible-frame t si:debug-info)
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun frame-invisible-p (frame)
(if (or (null frame)
(eq *invisible-frame-types-to-show* t))
nil ;user said no frames are invisible
(labels ((invisible-p (function frame)
(let* ((invisible-property
(assq 'invisible-frame (debugging-info function)))
(invisible-p (second invisible-property)))
(cond ((null invisible-property)
;; If there is no INVISIBLE-FRAME property, then look
;; at the parent function
(let ((fspec (if frame
(function-name-for-debugger frame)
(function-name function))))
(if (and (listp fspec) (eq (first fspec) :internal))
(invisible-p (si:valid-function-definition (second fspec))
nil)
nil)))
((eq invisible-p nil) nil)
((eq invisible-p t) t)
(t (null (memq invisible-p *invisible-frame-types-to-show*)))))))
(invisible-p (frame-function frame) frame))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
;;; Functions to extract the argument and local variable values from a frame.
;; Return list of the function and args that were invoked (as best as it can).
;; Note that this tries to get the original name of the function so that
;; if it has been redefined and you are doing c-m-R the new version will be called.
;; On the a machine doesn't work for functions which modify their arguments.
(defun get-frame-function-and-args (frame)
(let* ((*printing-monitor-message* t)
(frame-function-name (function-name-for-debugger frame))
(args (loop for i from 0 below (frame-number-of-visible-args frame)
collect (frame-arg-value frame i))))
(multiple-value-bind (nil rest-arg-value nil lexpr-call)
(decode-frame-rest-arg frame)
;; NCONC the rest arg if any was supplied separately from the regular args
(and lexpr-call (setq args (nconc (nbutlast args) (copylist rest-arg-value)))))
(if (or (special-form-p frame-function-name)
(macro-function frame-function-name))
;; The real form given to the special form or macro, second arg is ENV
(car args)
(cons frame-function-name args))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun fun ()
(let ((*printing-monitor-message* t))
(function-name-for-debugger *frame*)))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun present-stack-frame (frame &optional (stream standard-output))
(let ((frame-object (cons frame *error*))
(name (function-name-for-debugger frame)))
;; Using a single box gives an easier target to hit
(dw:with-output-as-presentation (:stream stream
:object frame-object
:type 'stack-frame
:allow-sensitive-inferiors nil)
;; This will give useful behavior even when we're not in the Debugger any more
(dw:with-output-as-presentation (:stream stream
:object name
:type 'sys:function-spec)
(let ((prinlevel nil)
(prinlength nil))
(prin1 name stream))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun print-function-and-args (frame &optional show-pc-p show-source-file-p
show-local-if-different present-as-function)
(let ((*printing-monitor-message* t)
(prinlevel *function-prinlevel*)
(prinlength *function-prinlength*)
(function (frame-function frame)))
(print-carefully "function name"
(terpri)
(and (closurep function)
(princ "Closure of "))
(with-character-style (*emphasis-character-style*)
(if present-as-function
(present (function-name-for-debugger frame) 'sys:function-spec)
(present-stack-frame frame)))
(tyo #\:)
(when (and show-pc-p
(typep function :compiled-function))
(let ((pc-now (frame-relative-exit-pc frame)))
(if pc-now (format t " (P.C. = ~O)" pc-now))))
(with-character-style (*deemphasis-character-style*)
(loop for func = function then (fsymeval (cadr encaps))
for delimiter = " (encapsulated for " then ", "
as encaps = (and (legitimate-function-p func)
(assq 'si:encapsulated-definition (debugging-info func)))
while encaps
do (princ delimiter)
(princ (caddr encaps))
finally (or (eq func function)
(princ ")"))))
(when show-source-file-p
(print-function-source-file function)))
(terpri)
(print-frame-args frame 3 show-local-if-different)))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
;;; Show commands
;; This is how the error message is printed when the error handler starts up.
;; Give error message, context, and warnings about screwed-up environment
(defun show (&optional (show-proceed-options t) already-printed)
(unless already-printed (terpri))
(print-error-message (and (not already-printed) *error*) nil *show-backtrace* t)
(unless (typep *error* 'stepper-break)
(show-function-and-args)
(when show-proceed-options
(show-proceed-options)))
(and *reason-debugger-entered*
(format t "~& Debugger was entered because ~A" *reason-debugger-entered*))
;; If we interrupted PROCESS-LOCK, PROCESS-ENQUEUE, or PROCESS-WAIT waiting
;; for a lock, show the user what process owns the lock and what it's doing
(let* ((curr-frame *current-frame*)
(curr-func (frame-function curr-frame)))
(when (eq (function-name-for-debugger curr-frame) 'process-wait)
(setq curr-frame (frame-previous-frame curr-frame)
curr-func (frame-function curr-frame)))
(when (or (eq (function-name-for-debugger curr-frame) 'process-lock)
(eq (function-name-for-debugger curr-frame) 'si:process-enqueue))
(let ((arg0 (frame-arg-value curr-frame 0))
(proc))
(cond ((eq (function-name-for-debugger curr-frame) 'si:process-enqueue)
(setq proc (aref arg0 (si:process-queue-current-pointer arg0)))
(format t "~& You are waiting for a locked queue"))
(t
(setq proc (cdr arg0))
(format t "~& You are waiting for a lock")))
(if (typep proc 'si:process)
(format t " held by process ~A, which is in state ~A.~%"
(process-name proc) (process-whostate proc))
(format t ".~%")))))
;; Print any useful warnings
(or (eq base ibase)
(format t "~& Warning: BASE is ~D. but IBASE is ~D.~%" base ibase))
(let ((dca (symeval-in-error-environment 'default-cons-area)))
(or (eq dca working-storage-area)
(format t "~& Warning: The default cons area is ~A, not working-storage-area.~%"
(area-name dca))))
(when (symeval-in-error-environment 'inhibit-scheduling-flag)
(format t "~& Warning: ~INHIBIT-SCHEDULING-FLAG is set. You are probably in the ~
middle of a program~@
that did not expect to be interrupted. Things may be inconsistent.~~%"))
nil)
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun show-all-compiled (&optional show-source-file-p)
(let* ((*printing-monitor-message* t)
(frame *current-frame*)
(function (frame-function frame)))
(format t "~V~S~" *emphasis-character-style* (function-name-for-debugger frame))
(when show-source-file-p
(print-function-source-file function))
(format t "~2%")
;; Print the arguments, including the rest-arg which is a local
(let ((local-start (print-frame-args *current-frame* 1 t)))
(cond ((frame-active-p *current-frame*)
;; Print the rest of the locals, if the frame is active
(print-frame-locals *current-frame* local-start 1)
(format t "~%~VDisassembled code:~" *deemphasis-character-style*)
(show-all-compiled-1 frame function)
;; This kludge is to prevent the prompt from triggering a **MORE**
;; when it comes out on the bottom line of the window
(if (memq :notice (send standard-output :which-operations))
(send standard-output :notice :input-wait)))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun find-frame-internal (string &optional exact reverse-p skip-invisible)
(flet ((move-frame (frame)
(loop for f = (if reverse-p
(frame-next-open-frame frame)
(frame-previous-open-frame frame))
then (if reverse-p
(frame-next-open-frame f)
(frame-previous-open-frame f))
until (or (not skip-invisible)
(not (frame-invisible-p f)))
finally (return f))))
;; STRING can really be a function or a function-spec, too
(loop with function-to-search-for = (si:valid-function-definition string t)
for frame = (move-frame *current-frame*) then (move-frame frame)
until (null frame)
as frame-function = (frame-function frame)
when (or (and function-to-search-for
(eq function-to-search-for frame-function))
(and (not exact)
(let ((name (function-name-for-debugger frame)))
(string-search string (cond ((stringp name) name)
((symbolp name) (string name))
(t (format nil "~S" name)))))))
do (setq *current-frame* frame)
(return frame)
finally
(format t "~&Search failed.~%")
(return nil))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
;; Print only the names of the functions, as many per line as will fit.
(defun short-backtrace (&optional (n 10000.) internal-flag continuations)
(send standard-output :fresh-line)
(if (null continuations)
(scl:filling-output (t :fill-on-spaces nil)
(let ((printed-something nil)
(pending-parents nil))
(print-backtrace n 0 internal-flag
(lambda (frame index)
(let* ((function (function-name-for-debugger frame))
(continued (memq function pending-parents))
;; The parent can either be the nominal function-parent
;; for this function, or whatever function owns this
;; :INTERNAL function
(parent (if (and (listp function)
(eq (first function) ':internal))
(second function)
(multiple-value-bind (fspec type)
(function-parent function)
(and (eq type 'defun) fspec)))))
(when continued
;; If we have just printed a pending parent, remove it
;; from the list
(setq pending-parents (delq function pending-parents)))
(if (and parent
(loop for i from index below n
for fr = frame then (frame-previous-frame fr) while fr
as fr-name = (function-name-for-debugger fr)
when (equal fr-name parent)
do (setq parent fr-name)
(return t)))
;; If this function has a parent which will eventually get
;; printed, save it away for later
(push parent pending-parents)
;; Here is where we can print something, finally
(when printed-something
(send standard-output :conditional-string-out " ")
(cl:write-char (if continued #\ #\))
(cl:write-char #\space))
(present-stack-frame frame)
(setq printed-something t)))))))
;;--- When DW filling-streams are faster, always use them
;;--- Perhaps a "flatsize" stream would be a useful addition to DW?
(let ((current-font (send-if-handles debug-io :current-font)))
(if (or (null current-font) ;watch out for cold-load stream
(null (tv:font-char-width-table current-font)))
;; I know that this is not in the new idiom, but it's up to 50% faster than
;; the version below for fixed-width fonts
(let* ((line-length (or (send-if-handles standard-output :size-in-characters) 95.))
(chars-left line-length))
(print-backtrace n 0 internal-flag
(lambda (frame count)
(let* ((name (function-name-for-debugger frame))
(name-length (+ (if (plusp count) 3 0) (flatsize name))))
(when (and (> name-length chars-left)
( name-length line-length))
(terpri)
(setq chars-left line-length))
(when (plusp count) (princ " "))
(present-stack-frame frame)
(decf chars-left name-length)))))
;; For variable-width fonts, use the slow (but more elegant) implementation
(formatting-textual-list (t :separator " "
:filled :before
:after-line-break " ")
(print-backtrace n 0 internal-flag
(lambda (frame ignore)
(formatting-textual-list-element ()
(present-stack-frame frame)))))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defun print-backtrace (n skip internal-flag frame-printer-function)
(macrolet ((move-frame (frame)
`(if internal-flag
(frame-previous-active-frame ,frame)
(frame-previous-interesting-active-frame ,frame))))
(loop with cl:*print-pretty* = nil ;two things filling is too many
for frame = *current-frame* then (move-frame frame)
for i upfrom (- skip) below n
until (null frame)
do (unless (minusp i)
;; In backtraces, always censor uninteresting frames, no
;; matter what c-N or c-P will do
(when (or internal-flag
(frame-interesting-p frame))
(funcall frame-printer-function frame i))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(define-presentation-to-command-translator edit-frame-function
(stack-frame
:tester ((frame &rest ignore)
;; Don't accept stale stack frames
(let ((error (cdr frame)))
(and (variable-boundp *error*)
(eq error *error*)
(neq (condition-status error)
:signalled))))
:documentation "Edit this frame's function"
:gesture :edit-function)
(frame)
`(com-edit-function ,(function-name-for-debugger (car frame))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(cp:define-command (com-return :command-table "Debugger"
:provide-output-destination-keyword nil)
()
(cond ((not (frame-active-p *current-frame*))
(princ "~&This frame has not yet been activated; you cannot return from it"))
((null (frame-previous-active-frame *current-frame*))
(princ "~&This is the bottom frame; you cannot return from it"))
(t
(let* ((name (function-name-for-debugger *current-frame*))
(values (multiple-value-bind (type maxvals)
(frame-real-value-disposition *current-frame*)
(selectq type
(:ignore
(format t "~&The caller is not interested in any values")
(or (fquery nil "Return from ~S? " name)
(throw 'quit t))
nil)
(:single
(format t "~&Return a value from the function ~S.~%" name)
(list (read-and-verify-expression t nil nil
"New value to return")))
(:multiple
;; If multiple-value-list, allow specification of as many as
;; wanted.
(format t (if maxvals
"~&The caller expects ~R values"
"~&The caller expects any number of values")
maxvals)
(if (eql maxvals 0)
(fquery nil "Return from ~S? " name)
(multiple-value-bind (nil values-names)
(let ((function (frame-function *current-frame*)))
(and (legitimate-function-p function)
(arglist function)))
(accumulate-multiple-return-values
"~&Enter values, ending with "
"Value #~S~@[ (~A)~]" maxvals values-names))))))))
(return-from-frame *current-frame* values)))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
;;; Other informational commands.
(cp:define-command (com-show-arglist :command-table "Debugger"
:provide-output-destination-keyword nil)
()
(let* ((function (frame-function *current-frame*))
(arglist (arglist function)))
(format t "~&The argument list for ~S is ~S" (function-name-for-debugger *current-frame*) arglist)))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(cp:define-command (com-edit-function :command-table "Global"
:provide-output-destination-keyword nil
:explicit-arglist
(&optional (function nil function-supplied-p)))
((function 'stack-frame-or-function-spec
:default
(if (variable-boundp *current-frame*)
(function-name-for-debugger *current-frame*))))
(let* ((function (if function-supplied-p
function
(and (variable-boundp *current-frame*)
(function-name-for-debugger *current-frame*)))))
(cond ((presentation-frame-p function)
(setq function (function-name-for-debugger (car function))))
((and (listp function) (memq (car function) flavor::*accessor-method-types*))
(format t "~&The accessor for ~S is defined by the flavor ~S"
(flavor::accessor-instance-variable function)
(flavor:method-flavor function))
(return-from com-edit-function
(ed `(zwei:edit-definition ,(flavor:method-flavor function) (defflavor))))))
(let* ((real-function (si:valid-function-definition function t))
(function (and real-function (function-name function))))
(if (typep real-function :compiled-function)
(multiple-value-bind (bp definition-type)
(and (not function-supplied-p)
(variable-boundp *current-frame*)
(frame-exit-source-locator-bp *current-frame*))
(if bp
(ed `(zwei:function-at-bp ,function ,bp ,definition-type))
(ed function)))
(if (null function)
(format t "~&There is no function for this frame")
(ed function))))))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(cp:define-command (com-show-source-code :command-table "Global"
:provide-output-destination-keyword nil
:explicit-arglist
(&optional (function nil function-supplied-p)))
((function 'compiled-function-spec
:default
(if (variable-boundp *current-frame*)
(function-name-for-debugger *current-frame*)
nil)))
(let* ((function (if function-supplied-p
function (function-name-for-debugger *current-frame*)))
(frame (if function-supplied-p nil *current-frame*)))
(show-frame-source frame function)))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defmethod (:bug-report-recipient-system condition) ()
(loop for frame = *innermost-interesting-frame*
then (frame-previous-frame frame)
until (null frame)
as function = (function-name-for-debugger frame)
as bug-report = (or (assq 'bug-report-recipient-system (debugging-info function))
(assq function *function-bug-report-alist*))
do (when bug-report
(return (cdr bug-report)))
finally (return *default-bug-report-recipient-system*)))
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
; From buffer debugger.lisp >rel-7>debugger BD: (552)
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Mode: LISP; Package: Debugger; Base: 8; Lowercase: Yes -*-")
(defmethod (:bug-report-description condition) (standard-output n-frames)
(let ((*error* self) ;need this to print backtraces
(current-frame *current-frame*))
;; Encourage users to include complete information in their bug reports
(when (%pointer-lessp current-frame *innermost-interesting-frame*)
(when (fquery () "The current frame, for ~S, is in the middle of the stack.~@
Do you want the stack trace in your bug report to start at ~
the top of the stack,~%at the frame for ~S, instead? "
(function-name-for-debugger current-frame)
(function-name-for-debugger *innermost-interesting-frame*))
(setq current-frame *innermost-interesting-frame*)))
;; N-FRAMES could be an actual frame!
(when (presentation-frame-p n-frames)
(setq n-frames (1+ (loop for frame = current-frame then (frame-previous-frame frame)
until (or (null frame) (eq frame (car n-frames)))
count 1))))
(let* ((total-frames (loop for frame = current-frame
then (frame-previous-active-frame frame)
until (null frame)
count t)))
;; NFRAMES = NIL all frames, NFRAMES = T ask
(cond ((null n-frames)
(setq n-frames total-frames))
((not (numberp n-frames))
(setq n-frames *default-backtrace-depth*)
(when
(and (> total-frames n-frames)
(fquery ()
"There are a total of ~D frames in the stack. By default only~@
information for the top ~D frames is included. Would you prefer~@
to include detailed information for every frame instead? "
total-frames n-frames))
(setq n-frames total-frames)))))
(let ((*error-message-prinlevel* *bug-report-prinlevel*)
(*error-message-prinlength* *bug-report-prinlength*)
(*current-frame* current-frame)
(*censor-invisible-frames* nil))
(terpri)
(print-error-message self nil t t)
(let ((package (symeval-globally 'package)))
(format t "~%The condition signalled was ~S~%" (typep self)))
(let ((tc (symeval-in-error-environment 'trace-conditions
*innermost-interesting-frame*)))
(when tc
(format t "TRACE-CONDITIONS was set to ~S~%" tc)))
(let ((interesting-specials (find-all-special-usages
(frame-function current-frame)))
(prinlevel *error-message-prinlevel*)
(prinlength *error-message-prinlength*))
;; Print the backtrace, including "interesting" specials at the point
;; where they were last bound
(print-backtrace n-frames 0 nil
(lambda (frame i)
(let ((local-start (print-function-and-args frame t t t)))
(when (and (zerop i)
(frame-active-p frame))
(print-frame-locals frame local-start 3))
(let ((frame-bindings (collect-frame-bindings frame)))
(loop for (sym val unbound-p) in frame-bindings
do (when (memq sym interesting-specials)
(format t " Special ~S: ~S~%"
sym (if unbound-p "unbound" val))
(setq interesting-specials
(delq sym interesting-specials))))))))
;; If there are any more "interesting" specials (which have global
;; values but are not otherwise bound), display them
(when interesting-specials
(terpri)
(loop for spec in interesting-specials
do (format t " Special ~S: ~S~%"
spec (if (boundp spec) (symeval spec) "unbound")))))
(multiple-value-bind (*current-frame* more-stack)
(frame-next-nth-interesting-active-frame current-frame (- n-frames))
(when more-stack
(format t "~2&~VRest of stack:~" *deemphasis-character-style*)
(print-backtrace 10000. 0 nil
(lambda (frame ignore)
(let ((prinlevel *function-prinlevel*)
(prinlength *function-prinlength*)
(function (frame-function frame)))
(print-carefully "function name"
(terpri)
(and (closurep function)
(princ "Closure of "))
(format t "~V~S~:"
*emphasis-character-style* (function-name function))
(when (typep function :compiled-function)
(let ((pc-now (frame-relative-exit-pc frame)))
(if pc-now (format t " (P.C. = ~O)" pc-now))))
(with-character-style (*deemphasis-character-style*)
(print-function-source-file function)))))))))))