about summary refs log tree commit diff
path: root/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp')
-rw-r--r--third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp105
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