Skip to content
Snippets Groups Projects
Commit 9ee5c342 authored by wlott's avatar wlott
Browse files

Changed print-frame-call-1 to generate a list and then print it so that

the pretty-printer can have a chance at doing something with it.
Nuked Robs-backtrace.
parent d446f66e
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.10 1990/08/24 18:22:50 wlott Exp $ ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.11 1990/10/04 19:19:03 wlott Exp $
;;; ;;;
;;; CMU Common Lisp Debugger. This is a very basic command-line oriented ;;; CMU Common Lisp Debugger. This is a very basic command-line oriented
;;; debugger. ;;; debugger.
...@@ -151,6 +151,13 @@ ...@@ -151,6 +151,13 @@
(eval-when (compile eval) (eval-when (compile eval)
;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal. ;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
(defstruct (unprintable-object
(:constructor make-unprintable-object (string))
(:print-function (lambda (x s d)
(declare (ignore d))
(format s "#<~A>"
(unprintable-object-string x)))))
string)
;;; ;;;
;;; This is a convenient way to express what to do for each type of lambda-list ;;; This is a convenient way to express what to do for each type of lambda-list
...@@ -170,125 +177,47 @@ ...@@ -170,125 +177,47 @@
(t ,other))))) (t ,other)))))
(format s "#<~A>" (format s "#<~A>"
(unprintable-object-string x))))) (unprintable-object-string x)))))
;;; This prints frame with verbosity level 1. This pays attention to string)
;;; *print-length*, and if we hit a rest-arg before the length runs out, then
;;; print as many of the values as possible, punting the loop over lambda-list ;;; PRINT-FRAME-CALL-1 -- Internal.
;;; variables since any other arguments will be in the rest-arg's list of ;;;
;;; values.
;;; This prints frame with verbosity level 1. If we hit a rest-arg, ;;; This prints frame with verbosity level 1. If we hit a rest-arg,
(defun print-frame-call-1 (frame) (defun print-frame-call-1 (frame)
(handler-case ;;; punting the loop over lambda-list variables since any other arguments
(let* ((d-fun (di:frame-debug-function frame)) ;;; will be in the rest-arg's list of values.
(loc (di:frame-code-location frame)) ;;;
(count (or *print-length* most-positive-fixnum))) (defun print-frame-call-1 (frame)
(terpri)
(write-char #\()
(prin1 (di:debug-function-name d-fun))
(let* ((d-fun (di:frame-debug-function frame)) (let* ((d-fun (di:frame-debug-function frame))
(write-char #\space)
(when (zerop count)
;; We know there are more arguments to print since we haven't
;; printed ele on this iteration yet.
(write-string "...")
(return))
(loc (di:frame-code-location frame)) (loc (di:frame-code-location frame))
:required ((print-frame-call-arg ele loc frame)) (results (list (di:debug-function-name d-fun))))
:optional ((print-frame-call-arg (second ele) loc frame)) (handler-case
:keyword ((prin1 (second ele)) (dolist (ele (di:debug-function-lambda-list d-fun))
(write-char #\space) (lambda-list-element-dispatch ele
(print-frame-call-arg (third ele) loc frame) :required ((push (frame-call-arg ele loc frame) results))
;; Extra decrement for printing two items.
(decf count))
:deleted ((print-frame-call-arg ele loc frame))
:optional ((push (frame-call-arg (second ele) loc frame) results)) :optional ((push (frame-call-arg (second ele) loc frame) results))
(write-string "<unused-rest-arg> ...") :keyword ((push (second ele) results)
(let ((values (di:debug-variable-value (second ele) frame))) (push (frame-call-arg (third ele) loc frame) results))
(prin1 (car values)) :deleted ((push (frame-call-arg ele loc frame) results))
(dolist (value (cdr values)) :rest ((lambda-var-dispatch (second ele) loc
(write-char #\space) nil
(when (zerop count) (progn
(write-string "...") (setf results
(return)) (append (reverse (di:debug-variable-value
(prin1 value) (second ele) frame))
(decf count))) results))
(write-string "<unavaliable-rest-arg> ...")) (return))
(return))) (push (make-unprintable-object "unavaliable-rest-arg")
(decf count)) (print (nreverse results))
(write-char #\)) ()
(when (di:debug-function-kind d-fun) (push (make-unprintable-object "lambda-list-unavailable") results)))
(write-string " [") (prin1 (nreverse results))
(prin1 (di:debug-function-kind d-fun)) (when (di:debug-function-kind d-fun)
(write-char #\])))
(di:lambda-list-unavailable () (prin1 (di:debug-function-kind d-fun))
(let ((d-fun (di:frame-debug-function frame)))
(format t " <lambda-list-unavailable>)~@[ [~S]~]"
(di:debug-function-kind d-fun))))))
(defun print-frame-call-arg (var location frame)
(write-char #\])))) (write-char #\]))))
(write-string "<unused-arg>") ;;;
(prin1 (di:debug-variable-value var frame)) (defun frame-call-arg (var location frame)
(write-string "<unavailable-arg>"))) (lambda-var-dispatch var location
;;;; ROBS-BACKTRACE.
#+nil
(defun robs-backtrace (&optional (frames most-positive-fixnum)
(*standard-output* *debug-io*))
"Show a listing of the call stack going down from the current frame. Frames
is how many frames to show."
(do ((callee (system:%primitive current-fp)
(di::stack-ref callee c::old-fp-save-offset))
(n 0 (1+ n)))
((or (not (di::cstack-pointer-valid-p callee))
(>= n frames))
(values))
(let* ((caller (di::stack-ref callee c::old-fp-save-offset))
(pc (di::stack-ref callee c::return-pc-save-offset)))
(unless (di::cstack-pointer-valid-p caller)
(return (values)))
(let ((env (di::stack-ref caller c::env-save-offset)))
(cond
((eql env 0)
(let ((env (di::escape-register caller c::env-offset)))
(cond ((eql (system:%primitive get-type env) system:%trap-type)
(format t "~%<undefined> ~S"
(di::escape-register caller c::call-name-offset))
(setq callee
(check-valid
(di::escape-register caller c::old-fp-offset))))
((di::env-valid-p env)
(format t "~%<escape frame> ")
(print-code-and-stuff
env
(di::escape-register caller c::return-pc-offset))
(setq callee
(check-valid
(di::stack-ref callee c::old-fp-save-offset))))
(t
(error "Escaping frame ENV invalid?")))))
((di::env-valid-p env)
(terpri)
(print-code-and-stuff env pc))
(t
(format t "~%<invalid frame>")))))))
#+nil
(defun print-code-and-stuff (env pc)
(let* ((code (system:%primitive header-ref env system:%function-code-slot))
(code-int (system:%primitive make-fixnum code)))
(format t "~A, Code = #x~X, PC = ~D"
(system:%primitive header-ref env system:%function-name-slot)
(logior code-int (ash system:%code-type 27))
(- (system:%primitive make-fixnum pc) code-int))))
#+nil
(defun check-valid (x)
(unless (di::cstack-pointer-valid-p x)
(error "Invalid control stack pointer."))
x)
(make-unprintable-object "unused-arg") (make-unprintable-object "unused-arg")
(di:debug-variable-value var frame) (di:debug-variable-value var frame)
(make-unprintable-object "unavailable-arg"))) (make-unprintable-object "unavailable-arg")))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment