diff options
Diffstat (limited to 'third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp')
-rw-r--r-- | third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp | 105 |
1 files changed, 0 insertions, 105 deletions
diff --git a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp deleted file mode 100644 index 43eddda47579..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp +++ /dev/null @@ -1,105 +0,0 @@ -(in-package #:trivial-backtrace) - -(defstruct frame - func - source-filename - source-pos - vars) - -(defstruct var - name - value) - -(defstruct pos-form-number - number) - -(defmethod print-object ((pos-form-number pos-form-number) stream) - (cond - (*print-readably* (call-next-method)) - (t - (format stream "f~A" (pos-form-number-number pos-form-number))))) - - -(defvar *trivial-backtrace-frame-print-specials* - '((*print-length* . 100) - (*print-level* . 20) - (*print-lines* . 5) - (*print-pretty* . t) - (*print-readably* . nil))) - -(defun print-frame (frame stream) - (format stream "~A:~@[~A:~] ~A: ~%" - (or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>") - (frame-source-pos frame) - (frame-func frame)) - (loop for var in (frame-vars frame) - do - (format stream " ~A = ~A~%" (var-name var) - (or (ignore-errors - (progv - (mapcar #'car *trivial-backtrace-frame-print-specials*) - (mapcar #'cdr *trivial-backtrace-frame-print-specials*) - (prin1-to-string - (var-value var)))) - "<error>")))) - -(defun map-backtrace (function) - (impl-map-backtrace function)) - -(defun print-map-backtrace (&optional (stream *debug-io*) &rest args) - (apply 'map-backtrace - (lambda (frame) - (print-frame frame stream)) args)) - -(defun backtrace-string (&rest args) - (with-output-to-string (stream) - (apply 'print-map-backtrace stream args))) - - -#+ccl -(defun impl-map-backtrace (func) - (ccl::map-call-frames (lambda (ptr) - (multiple-value-bind (lfun pc) - (ccl::cfp-lfun ptr) - (let ((source-note (ccl:function-source-note lfun))) - (funcall func - (make-frame :func (ccl::lfun-name lfun) - :source-filename (ccl:source-note-filename source-note) - :source-pos (let ((form-number (ccl:source-note-start-pos source-note))) - (when form-number (make-pos-form-number :number form-number))) - :vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc) - collect (make-var :name name :value value))))))))) - -#+sbcl -(defun impl-map-backtrace (func) - (loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f) - while f - do (funcall func - (make-frame :func - (ignore-errors - (sb-di:debug-fun-name - (sb-di:frame-debug-fun f))) - :source-filename - (ignore-errors - (sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f)))) - :source-pos - (ignore-errors ;;; XXX does not work - (let ((cloc (sb-di:frame-code-location f))) - (unless (sb-di:code-location-unknown-p cloc) - (format nil "tlf~Dfn~D" - (sb-di:code-location-toplevel-form-offset cloc) - (sb-di:code-location-form-number cloc))))) - :vars - (remove-if 'not - (map 'list (lambda(v) - (ignore-errors - (when (eq :valid - (sb-di:debug-var-validity v (sb-di:frame-code-location f))) - (make-var :name (sb-di:debug-var-symbol v) - :value (sb-di:debug-var-value v f))))) - (ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f))))))))) - -#-(or ccl sbcl) -(defun impl-map-backtrace (func) - (declare (ignore func)) - (warn "unable to map backtrace for ~a" (lisp-implementation-type))) \ No newline at end of file |