1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Package: TRIVIAL-BACKTRACE; Base: 10; -*-
(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 &optional context)
(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)))))))))
#+clasp
(defun impl-map-backtrace (func)
(clasp-debug:with-stack (stack)
(clasp-debug:map-stack
#'(lambda(current-frame)
(funcall func
(let ((source (clasp-debug:frame-source-position current-frame)))
(make-frame :func (clasp-debug:frame-function current-frame)
:source-filename (if source (clasp-debug:code-source-line-pathname source) nil)
:source-pos (if source (clasp-debug:code-source-line-line-number source) nil)
:vars (let ((index 0))
(mapcar #'(lambda(argument)
(prog1
(make-var :name (format nil "Arg-~a" index) :value argument)
(incf index)))
(clasp-debug:frame-arguments current-frame)))))))
stack)))
#-(or ccl sbcl clasp)
(defun impl-map-backtrace (func)
(declare (ignore func))
(warn "unable to map backtrace for ~a" (lisp-implementation-type)))
|
