├── .gitattributes ├── dissect-logo.png ├── doc ├── dissect-logo.png └── index.html ├── .travis.yml ├── README.md ├── package.lisp ├── LICENSE ├── dissect.asd ├── backend ├── clasp.lisp ├── ccl.lisp ├── ecl.lisp ├── allegro.lisp ├── sbcl.lisp ├── abcl.lisp └── clisp.lisp ├── toolkit.lisp ├── interface.lisp └── documentation.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | doc/ linguist-vendored -------------------------------------------------------------------------------- /dissect-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/dissect/HEAD/dissect-logo.png -------------------------------------------------------------------------------- /doc/dissect-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/dissect/HEAD/doc/dissect-logo.png -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: required 3 | 4 | env: 5 | matrix: 6 | - LISP=abcl 7 | - LISP=allegro 8 | - LISP=ccl 9 | - LISP=clisp 10 | - LISP=ecl 11 | - LISP=sbcl 12 | 13 | install: 14 | # CL 15 | - curl https://raw.githubusercontent.com/luismbo/cl-travis/master/install.sh | bash 16 | 17 | script: 18 | - cl -e '(ql:quickload :dissect)' 19 | 20 | notifications: 21 | email: 22 | - shinmera@tymoon.eu -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shinmera.com/projects/dissect)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shinmera.com/projects/dissect) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:dissect 2 | (:use #:cl) 3 | (:nicknames #:org.tymoonnext.dissect) 4 | (:shadow #:restart) 5 | ;; interface.lisp 6 | (:export 7 | #:stack 8 | #:restarts 9 | #:with-truncated-stack 10 | #:with-capped-stack 11 | #:present 12 | #:present-object 13 | 14 | #:restart 15 | #:name 16 | #:report 17 | #:restart 18 | #:object 19 | #:invoke 20 | 21 | #:unknown-arguments 22 | #:unavailable-argument 23 | 24 | #:call 25 | #:pos 26 | #:call 27 | #:args 28 | #:locals 29 | #:file 30 | #:line 31 | #:form 32 | 33 | #:environment 34 | #:environment-condition 35 | #:environment-stack 36 | #:environment-restarts 37 | #:environment-thread 38 | #:capture-environment)) 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /dissect.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem dissect 2 | :name "Dissect" 3 | :version "1.0.0" 4 | :license "zlib" 5 | :author "Yukari Hafner " 6 | :maintainer "Yukari Hafner " 7 | :description "A lib for introspecting the call stack and active restarts." 8 | :homepage "https://shinmera.com/docs/dissect/" 9 | :bug-tracker "https://shinmera.com/project/dissect/issues" 10 | :source-control (:git "https://shinmera.com/project/dissect.git") 11 | :serial T 12 | :components ((:file "package") 13 | (:file "toolkit") 14 | (:file "interface") 15 | (:module "backend" 16 | :components 17 | (#+abcl (:file "abcl") 18 | #+allegro (:file "allegro") 19 | #+ccl (:file "ccl") 20 | #+clasp (:file "clasp") 21 | #+clisp (:file "clisp") 22 | #+ecl (:file "ecl") 23 | #+sbcl (:file "sbcl"))) 24 | (:file "documentation")) 25 | :depends-on (#+clisp :cl-ppcre)) 26 | -------------------------------------------------------------------------------- /backend/clasp.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is part of Dissect 3 | Author: Bike 4 | |# 5 | 6 | (in-package #:org.tymoonnext.dissect) 7 | 8 | (setf (fdefinition 'stack) 9 | (lambda () 10 | (let ((stack nil)) 11 | (clasp-debug:map-indexed-backtrace 12 | (lambda (frame index) 13 | (let ((csl (clasp-debug:frame-function-source-position frame))) 14 | (push (make-instance 'call 15 | :pos index 16 | :call (or (clasp-debug:frame-function-name frame) 17 | (clasp-debug:frame-function frame)) 18 | :args (clasp-debug:frame-arguments frame) 19 | :locals (clasp-debug:frame-locals frame) 20 | :form (clasp-debug:frame-function-form frame) 21 | :file (and csl (clasp-debug:code-source-line-pathname csl)) 22 | :line (and csl (clasp-debug:code-source-line-line-number csl))) 23 | stack)))) 24 | (nreverse stack)))) 25 | 26 | (defclass clasp-restart (restart) 27 | ((conditions :initarg :conditions :accessor conditions))) 28 | 29 | (defun make-restart (restart) 30 | (make-instance 'clasp-restart 31 | :name (restart-name restart) 32 | :report (write-to-string restart :escape nil :readably nil) 33 | :restart (ext:restart-function restart) 34 | :object restart 35 | :interactive (ext:restart-interactive-function restart) 36 | :test (ext:restart-test-function restart) 37 | :conditions (ext:restart-associated-conditions restart))) 38 | 39 | 40 | (setf (fdefinition 'restarts) 41 | (lambda (&optional condition) 42 | (mapcar #'make-restart (compute-restarts condition)))) 43 | 44 | (defmacro with-capped-stack (&body body) 45 | `(clasp-debug:with-capped-stack () ,@body)) 46 | 47 | (defmacro with-truncated-stack (&body body) 48 | `(clasp-debug:with-truncated-stack () ,@body)) 49 | -------------------------------------------------------------------------------- /backend/ccl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass ccl-call (call) 4 | ((source-note :initarg :source-note :accessor source-note))) 5 | 6 | (defun resolve-file-slots (call) 7 | (let* ((source-note (source-note call)) 8 | (file (ccl:source-note-filename source-note)) 9 | (pos (ccl:source-note-start-pos source-note))) 10 | (setf (slot-value call 'line) (when (and file pos) (newlines-until-pos file pos)) 11 | (slot-value call 'form) (when (and file pos) (read-source-form file pos)))) 12 | call) 13 | 14 | (macrolet ((define-resolvent (name) 15 | `(defmethod ,name ((call ccl-call)) 16 | (unless (slot-boundp call ',name) 17 | (resolve-file-slots call)) 18 | (call-next-method)))) 19 | (define-resolvent line) 20 | (define-resolvent form)) 21 | 22 | (defun make-call (i pointer context) 23 | (let* ((function (ccl:frame-function pointer context)) 24 | (source-note (ccl:function-source-note function)) 25 | (args (ccl:frame-supplied-arguments 26 | pointer context :unknown-marker (make-instance 'unavailable-argument))) 27 | (args (if (listp args) args (make-instance 'unknown-arguments)))) 28 | (make-instance 29 | 'ccl-call 30 | :pos i 31 | :call (or (ccl:function-name function) function) 32 | :args args 33 | :locals (loop for (name . value) in (ccl:frame-named-variables pointer context) 34 | collect (cons name value)) 35 | :file (when (ccl:source-note-filename source-note) 36 | (translate-logical-pathname (ccl:source-note-filename source-note))) 37 | :source-note source-note))) 38 | 39 | (setf (fdefinition 'stack) 40 | (lambda () 41 | (let ((i 0) 42 | (stack ())) 43 | (ccl:map-call-frames 44 | #'(lambda (pointer context) 45 | (push (make-call i pointer context) stack) 46 | (incf i)) 47 | :start-frame-number 1) 48 | (chop-stack (nreverse stack))))) 49 | 50 | (defclass ccl-restart (restart) 51 | ()) 52 | 53 | (defun make-restart (restart) 54 | (make-instance 55 | 'ccl-restart 56 | :name (ccl::%restart-name restart) 57 | :restart (ccl::%restart-action restart) 58 | :report (let* ((*print-readably* NIL) 59 | (report (ccl::%restart-report restart))) 60 | (typecase report 61 | (function (with-output-to-string (stream) 62 | (funcall report stream))) 63 | (T report))) 64 | :interactive (ccl::%restart-interactive restart) 65 | :test (ccl::%restart-test restart) 66 | :object restart)) 67 | 68 | 69 | (setf (fdefinition 'restarts) 70 | (lambda (&optional condition) 71 | (mapcar #'make-restart (compute-restarts condition)))) 72 | -------------------------------------------------------------------------------- /backend/ecl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass ecl-call (call) 4 | ((file-pos :initarg :file-pos :accessor file-pos))) 5 | 6 | (defun resolve-file-slots (call) 7 | (setf (slot-value call 'line) (when (file call) (newlines-until-pos (file call) (file-pos call))) 8 | (slot-value call 'form) (when (file call) (read-source-form (file call) (file-pos call)))) 9 | call) 10 | 11 | (macrolet ((define-resolvent (name) 12 | `(defmethod ,name ((call ecl-call)) 13 | (unless (slot-boundp call ',name) 14 | (resolve-file-slots call)) 15 | (call-next-method)))) 16 | (define-resolvent line) 17 | (define-resolvent form)) 18 | 19 | (defun function-name (function) 20 | (typecase function 21 | (generic-function (clos:generic-function-name function)) 22 | (function (system:compiled-function-name function)))) 23 | 24 | (defun make-call (i function environment) 25 | (multiple-value-bind (file position) (system::bc-file function) 26 | (make-instance 27 | 'ecl-call 28 | :pos i 29 | :call (typecase function 30 | (symbol function) 31 | (T (function-name function))) 32 | :args (let ((variables ()) 33 | (frame (si::decode-ihs-env environment))) 34 | (dolist (record (remove-if-not #'consp frame)) 35 | (let* ((record0 (car record)) 36 | (record1 (cdr record))) 37 | (when (or (symbolp record0) (stringp record0)) 38 | (push record1 variables)))) 39 | variables) 40 | :file (when file (translate-logical-pathname file)) 41 | :file-pos position))) 42 | 43 | (setf (fdefinition 'stack) 44 | (lambda () 45 | (chop-stack 46 | (loop for ihs downfrom (1- (system::ihs-top)) above 0 47 | for i from 0 48 | collect (make-call 49 | i 50 | (system::ihs-fun ihs) 51 | (system::ihs-env ihs)))))) 52 | 53 | (defclass ecl-restart (restart) 54 | ()) 55 | 56 | (defun make-restart (restart) 57 | (make-instance 58 | 'ecl-restart 59 | :name (system::restart-name restart) 60 | :report (let* ((*print-readably* NIL) 61 | (report (system::restart-report-function restart))) 62 | (typecase report 63 | (function (with-output-to-string (stream) 64 | (funcall report stream))) 65 | (T report))) 66 | :restart (system::restart-function restart) 67 | :object restart 68 | :interactive (system::restart-interactive-function restart) 69 | :test (system::restart-test-function restart))) 70 | 71 | (setf (fdefinition 'restarts) 72 | (lambda (&optional condition) 73 | (mapcar #'make-restart (compute-restarts condition)))) 74 | -------------------------------------------------------------------------------- /backend/allegro.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass acl-call (call) 4 | ()) 5 | 6 | (defun fspec-definition-location (fspec) 7 | (if (and (listp fspec) (eq (car fspec) :internal)) 8 | (fspec-definition-locations (second fspec)) 9 | (let ((defs (excl::find-source-file fspec))) 10 | (when (and (null defs) (listp fspec) (string= (car fspec) '#:method)) 11 | ;; If methods are defined in a defgeneric form, the source location is 12 | ;; recorded for the gf but not for the methods. Therefore fall back to 13 | ;; the gf as the likely place of definition. 14 | (setf defs (excl::find-source-file (second fspec)))) 15 | (third (car defs))))) 16 | 17 | (defun make-call (i frame) 18 | (make-instance 19 | 'acl-call 20 | :pos i 21 | :call (xref::object-to-function-name (debugger:frame-function frame)) 22 | :args (loop for i from 0 below (debugger:frame-number-vars frame) 23 | unless (eq :local (debugger:frame-var-type frame i)) 24 | collect (debugger:frame-var-value frame i)) 25 | :locals (loop for i from 0 below (debugger:frame-number-vars frame) 26 | collect (cons (debugger:frame-var-name frame i) 27 | (debugger:frame-var-value frame i))) 28 | :file (fspec-definition-location (debugger:frame-function frame)) 29 | :line NIL)) 30 | 31 | (defun next-frame (frame) 32 | (let ((next (excl::int-next-older-frame frame))) 33 | (and next (if (debugger:frame-visible-p next) 34 | next (next-frame next))))) 35 | 36 | (defun top-frame () 37 | (let ((magic-symbol (make-symbol "FOO")) 38 | (top-frame (excl::int-newest-frame (excl::current-thread)))) 39 | (loop for frame = top-frame then (next-frame frame) 40 | repeat 30 41 | while frame 42 | do (when (eq (debugger:frame-name frame) magic-symbol) 43 | (return (next-frame frame))) 44 | finally (return top-frame)))) 45 | 46 | (setf (fdefinition 'stack) 47 | (lambda () 48 | (chop-stack 49 | (loop for frame = (next-frame (next-frame (top-frame))) 50 | then (next-frame frame) 51 | for i from 0 52 | while frame 53 | collect (make-call i frame))))) 54 | 55 | (defclass acl-restart (restart) 56 | ()) 57 | 58 | (defun make-restart (restart) 59 | (make-instance 60 | 'acl-restart 61 | :name (excl::restart-name restart) 62 | :restart (excl::restart-function restart) 63 | :report (let* ((*print-readably* NIL) 64 | (report (excl::restart-report-function restart))) 65 | (typecase report 66 | (function (with-output-to-string (stream) 67 | (funcall report stream))) 68 | (T report))) 69 | :interactive (excl::restart-interactive-function restart) 70 | :test (excl::restart-test-function restart) 71 | :object restart)) 72 | 73 | (setf (fdefinition 'restarts) 74 | (lambda (&optional condition) 75 | (mapcar #'make-restart (compute-restarts condition)))) 76 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defun read-source-form (file start) 4 | (ignore-errors 5 | (with-open-file (stream file) 6 | (file-position stream start) 7 | (read stream)))) 8 | 9 | (defun read-source-form-at-line (file line) 10 | (ignore-errors 11 | (with-open-file (stream file) 12 | (loop for char = (read-char stream NIL NIL) 13 | while char 14 | do (when (char= #\Newline char) 15 | (decf line)) 16 | (when (= line 0) 17 | (return (read stream))))))) 18 | 19 | (defun newlines-until-pos (file position) 20 | (ignore-errors 21 | (with-open-file (stream file) 22 | (1+ (loop until (>= (file-position stream) position) 23 | count (char= (read-char stream) #\Newline)))))) 24 | 25 | (defun read-toplevel-form (stream) 26 | (loop for char = (read-char stream NIL NIL) 27 | while char until (char= char #\()) 28 | (when (peek-char NIL stream NIL NIL) 29 | (with-output-to-string (output) 30 | (write-char #\( output) 31 | (loop with level = 1 32 | for char = (read-char stream NIL NIL) 33 | while char until (<= level 0) 34 | do (write-char char output) 35 | (case char 36 | (#\( (incf level)) 37 | (#\) (decf level))))))) 38 | 39 | (defun %print-as-hopefully-in-source (stream thing &rest arg) 40 | (declare (ignore arg)) 41 | (write-string (print-as-hopefully-in-source thing) stream)) 42 | 43 | (defun print-as-hopefully-in-source (thing) 44 | (typecase thing 45 | (symbol (symbol-name thing)) 46 | (string (prin1-to-string thing)) 47 | (list (format NIL "(~{~/dissect::%print-as-hopefully-in-source/~^ ~})" thing)) 48 | (T (princ-to-string thing)))) 49 | 50 | (defun find-definition-in-file (call file) 51 | (let ((definition (print-as-hopefully-in-source call))) 52 | (with-open-file (stream file) 53 | (loop with min = () 54 | for pos = (file-position stream) 55 | for top = (read-toplevel-form stream) 56 | while top 57 | do (let ((searchpos (search definition top :test #'char-equal))) 58 | (when (and searchpos (or (not min) (<= searchpos (third min)))) 59 | (setf min (list pos top searchpos)))) 60 | finally (return (values (first min) (second min))))))) 61 | 62 | (defun chop-stack (stack) 63 | "Look for stack truncations and cappings and chop it down accordingly." 64 | (flet ((frame= (frame func) 65 | (or (eql (call frame) func) 66 | (eql (call frame) (fdefinition func))))) 67 | (loop with start = 0 68 | for i from 0 69 | for frame in stack 70 | until (frame= frame 'stack-truncator) 71 | collect frame into final-stack 72 | do (when (frame= frame 'stack-capper) 73 | (setf start (1+ i))) 74 | finally (return (nthcdr start final-stack))))) 75 | 76 | ;; Copied over from bordeaux-threads. 77 | (eval-when (:compile-toplevel :load-toplevel :execute) 78 | #+allegro (require :smputil) 79 | #+corman (require :threads)) 80 | 81 | (eval-when (:compile-toplevel :load-toplevel :execute) 82 | #+(or armedbear 83 | (and allegro multiprocessing) 84 | (and clisp mt) 85 | (and openmcl openmcl-native-threads) 86 | (and cmu mp) 87 | corman 88 | (and ecl threads) 89 | mkcl 90 | lispworks 91 | (and digitool ccl-5.1) 92 | (and sbcl sb-thread) 93 | scl) 94 | (pushnew :thread-support *features*)) 95 | 96 | (defun current-thread () 97 | (or 98 | (when (find-package :bt) (funcall (find-symbol (string :current-thread) :bt))) 99 | #+thread-support 100 | (or 101 | #+abcl (threads:current-thread) 102 | #+allegro mp:*current-process* 103 | #+clisp (mt:current-thread) 104 | #+ccl ccl:*current-process* 105 | #+cmucl mp:*current-process* 106 | #+corman threads:*current-thread* 107 | #+ecl mp::*current-process* 108 | #+lispworks (mp:get-current-process) 109 | #+digitool ccl:*current-process* 110 | #+mkcl mt::*thread* 111 | #+sbcl sb-thread:*current-thread* 112 | #+scl thread:*thread* 113 | NIL))) 114 | -------------------------------------------------------------------------------- /backend/sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass sbcl-call (call) 4 | ((info :initarg :info :accessor info) 5 | (frame :initarg :frame :accessor frame))) 6 | 7 | (defun frame-location (frame) 8 | (let* ((code-location (sb-di:frame-code-location frame)) 9 | (debug-source (ignore-errors 10 | (sb-di:code-location-debug-source code-location)))) 11 | (cond #+#.(cl:when (cl:find-symbol (cl:string 'core-debug-source-p) "SB-C") :sbcl) 12 | ((sb-c::core-debug-source-p debug-source) 13 | (values NIL NIL (sb-c::core-debug-source-form debug-source))) 14 | (debug-source 15 | (let* ((file (let ((file (sb-di:debug-source-namestring debug-source))) 16 | (and file (probe-file file))))) 17 | (when file 18 | (multiple-value-bind (pos found-form) 19 | (find-definition-in-file (sb-debug::frame-call frame) file) 20 | (values file (newlines-until-pos file pos) found-form)))))))) 21 | 22 | (defun resolve-file-slots (call) 23 | (multiple-value-bind (file line form) (frame-location (frame call)) 24 | (setf (slot-value call 'file) (when file (translate-logical-pathname file)) 25 | (slot-value call 'line) line 26 | (slot-value call 'form) form)) 27 | call) 28 | 29 | (macrolet ((define-resolvent (name) 30 | `(defmethod ,name ((call sbcl-call)) 31 | (unless (slot-boundp call ',name) 32 | (resolve-file-slots call)) 33 | (call-next-method)))) 34 | (define-resolvent file) 35 | (define-resolvent line) 36 | (define-resolvent form)) 37 | 38 | (defun debug-var-info (var) 39 | (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di))) 40 | (when (and s (fboundp s)) 41 | (funcall s var)))) 42 | 43 | (defun frame-locals (frame) 44 | (let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))) 45 | (loc (sb-di:frame-code-location frame)) 46 | ;; FIXME: Is discarding invalid vars necessary? Is there any 47 | ;; use in them? 48 | (vars (remove-if (lambda (var) 49 | (ecase (sb-di:debug-var-validity var loc) 50 | (:valid nil) 51 | ((:invalid :unknown) t))) 52 | all-vars)) 53 | (more-context (find :more-context vars :key #'debug-var-info)) 54 | (more-count (find :more-count vars :key #'debug-var-info))) 55 | (when vars 56 | (append 57 | (loop for var across vars 58 | collect (cons 59 | (sb-di:debug-var-symbol var) 60 | (sb-di:debug-var-value var frame))) 61 | (when (and more-context more-count) 62 | (list (cons 'sb-debug::more 63 | (multiple-value-list 64 | (sb-c:%more-arg-values (sb-di:debug-var-value more-context frame) 65 | 0 66 | (sb-di:debug-var-value more-count frame)))))))))) 67 | 68 | (defun make-call (frame) 69 | (multiple-value-bind (call args info) (sb-debug::frame-call frame) 70 | (make-instance 71 | 'sbcl-call 72 | :frame frame 73 | :pos (sb-di:frame-number frame) 74 | :call call 75 | :args args 76 | :locals (frame-locals frame) 77 | :info info))) 78 | 79 | (setf (fdefinition 'stack) 80 | (lambda () 81 | (chop-stack 82 | (loop for frame = (or (sb-debug::resolve-stack-top-hint) 83 | (sb-di:frame-down (sb-di:top-frame))) 84 | then (sb-di:frame-down frame) 85 | while frame 86 | collect (make-call frame))))) 87 | 88 | (defclass sbcl-restart (restart) 89 | ((conditions :initarg :conditions :accessor conditions))) 90 | 91 | (defun make-restart (restart) 92 | (make-instance 93 | 'sbcl-restart 94 | :name (restart-name restart) 95 | :report (let* ((*print-readably* NIL) 96 | (report (sb-kernel::restart-report-function restart))) 97 | (typecase report 98 | (function (with-output-to-string (stream) 99 | (funcall report stream))) 100 | (T report))) 101 | :restart (sb-kernel::restart-function restart) 102 | :object restart 103 | :interactive (sb-kernel::restart-interactive-function restart) 104 | :test (sb-kernel::restart-test-function restart) 105 | :conditions (sb-kernel:restart-associated-conditions restart))) 106 | 107 | (setf (fdefinition 'restarts) 108 | (lambda (&optional condition) 109 | (mapcar #'make-restart (compute-restarts condition)))) 110 | 111 | (setf (fdefinition 'stack-capper) 112 | (lambda (function) 113 | (declare (optimize (debug 3))) 114 | (funcall function))) 115 | 116 | (setf (fdefinition 'stack-truncator) 117 | (lambda (function) 118 | (declare (optimize (debug 3))) 119 | (funcall function))) 120 | 121 | (defmacro %with-truncated-stack (() &body body) 122 | `(stack-truncator (sb-int:named-lambda with-truncated-stack-lambda () ,@body))) 123 | (setf (macro-function 'with-truncated-stack) (macro-function '%with-truncated-stack)) 124 | -------------------------------------------------------------------------------- /interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (declaim (ftype (function () list) stack) 4 | (notinline stack)) 5 | (defun stack ()) 6 | 7 | (declaim (ftype (function (&optional (or null condition)) list) restarts) 8 | (notinline restarts)) 9 | (defun restarts (&optional condition)) 10 | 11 | (declaim (notinline stack-truncator)) 12 | (defun stack-truncator (function) 13 | (funcall function)) 14 | 15 | (defmacro with-truncated-stack (() &body body) 16 | `(stack-truncator (lambda () ,@body))) 17 | 18 | (declaim (notinline stack-capper)) 19 | (defun stack-capper (function) 20 | (funcall function)) 21 | 22 | (defmacro with-capped-stack (() &body body) 23 | `(stack-capper (lambda () ,@body))) 24 | 25 | (defun present (thing &optional (destination T)) 26 | (with-capped-stack () 27 | (etypecase destination 28 | ((eql T) (present thing *standard-output*)) 29 | ((eql NIL) (with-output-to-string (stream) 30 | (present thing stream))) 31 | (stream (present-object thing destination))))) 32 | 33 | (defgeneric present-object (thing stream)) 34 | 35 | (defmethod present-object ((condition condition) stream) 36 | (format stream "~a" condition) 37 | (format stream "~& [Condition of type ~s]" (type-of condition)) 38 | (format stream "~&~%") 39 | (present-object T stream)) 40 | 41 | (defmethod present-object ((thing (eql T)) stream) 42 | (present-object (capture-environment) stream)) 43 | 44 | (defmethod present-object ((list list) stream) 45 | (when list 46 | (etypecase (first list) 47 | (restart (format stream "~&Available restarts:") 48 | (loop for i from 0 49 | for item in list 50 | do (format stream "~& ~d: " i) 51 | (present-object item stream))) 52 | (call (format stream "~&Backtrace:") 53 | (loop for item in list 54 | do (format stream "~& ") 55 | (present-object item stream)))))) 56 | 57 | (defclass restart () 58 | ((name :initarg :name :reader name) 59 | (report :initarg :report :reader report) 60 | (restart :initarg :restart :reader restart) 61 | (object :initarg :object :reader object) 62 | (interactive :initarg :interactive :reader interactive) 63 | (test :initarg :test :reader test))) 64 | 65 | (defmethod print-object ((restart restart) stream) 66 | (print-unreadable-object (restart stream :type T) 67 | (format stream "[~s] ~s" 68 | (name restart) (report restart)))) 69 | 70 | (defmethod present-object ((restart restart) stream) 71 | (format stream "[~a] ~a" (name restart) (report restart))) 72 | 73 | (defgeneric invoke (restart &rest args)) 74 | 75 | (defmethod invoke ((restart restart) &rest args) 76 | (if (restart restart) 77 | (apply (restart restart) args) 78 | (apply #'invoke-restart (name restart) args))) 79 | 80 | (defclass unknown-arguments () 81 | ()) 82 | 83 | (defmethod print-object ((args unknown-arguments) stream) 84 | (format stream "#")) 85 | 86 | (defclass unavailable-argument () 87 | ()) 88 | 89 | (defmethod print-object ((arg unavailable-argument) stream) 90 | (format stream "#")) 91 | 92 | (defclass call () 93 | ((pos :initarg :pos :reader pos) 94 | (call :initarg :call :reader call) 95 | (args :initarg :args :reader args) 96 | (file :initarg :file :reader file) 97 | (line :initarg :line :reader line) 98 | (form :initarg :form :reader form) 99 | (locals :initform NIL :initarg :locals :reader locals))) 100 | 101 | (defmethod print-object ((call call) stream) 102 | (print-unreadable-object (call stream :type T) 103 | (format stream "[~a] ~a~@[ | ~a~@[:~a~]~]" 104 | (pos call) (call call) (file call) (line call)))) 105 | 106 | (defmethod present-object ((call call) stream) 107 | (let ((*print-pretty* NIL) 108 | (*print-readably* NIL) 109 | (args (args call))) 110 | (format stream "~d: ~:[(~s ~s)~;(~s~{ ~a~})~]" 111 | (pos call) 112 | ;; If args is a list then they will be listed 113 | ;; separated by spaces. 114 | (listp args) 115 | (call call) 116 | (if (listp args) 117 | (loop for arg in args 118 | collect (or (ignore-errors (princ-to-string arg)) 119 | "")) 120 | args)))) 121 | 122 | (defclass environment () 123 | ((condition :initarg :condition :reader environment-condition) 124 | (stack :initarg :stack :reader environment-stack) 125 | (restarts :initarg :restarts :reader environment-restarts) 126 | (thread :initarg :thread :reader environment-thread)) 127 | (:default-initargs 128 | :condition NIL 129 | :stack (stack) 130 | :restarts (restarts) 131 | :thread (current-thread))) 132 | 133 | (declaim (inline capture-environment)) 134 | (defun capture-environment (&optional condition) 135 | (with-capped-stack () 136 | (make-instance 'environment :condition condition))) 137 | 138 | (defmethod present-object ((env environment) stream) 139 | (with-slots ((condition condition) (stack stack) (restarts restarts) (thread thread)) env 140 | (format stream "~a" env) 141 | (format stream "~& [Environment~@[ of thread ~a~]]" thread) 142 | (when condition 143 | (format stream "~&~%") 144 | (format stream "~a" condition) 145 | (format stream "~& [Condition of type ~s]" (type-of condition))) 146 | (when restarts 147 | (format stream "~&~%") 148 | (present-object restarts stream)) 149 | (when stack 150 | (format stream "~&~%") 151 | (present-object stack stream)))) 152 | -------------------------------------------------------------------------------- /backend/abcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass abcl-call (call) 4 | ((frame :initarg :frame :accessor frame))) 5 | 6 | (defun resolve-file-slots (call) 7 | (multiple-value-bind (file line form) (source-location (frame call)) 8 | (setf (slot-value call 'file) file 9 | (slot-value call 'line) line 10 | (slot-value call 'form) form)) 11 | call) 12 | 13 | (macrolet ((define-resolvent (name) 14 | `(defmethod ,name ((call abcl-call)) 15 | (unless (slot-boundp call ',name) 16 | (resolve-file-slots call)) 17 | (call-next-method)))) 18 | (define-resolvent file) 19 | (define-resolvent line) 20 | (define-resolvent form)) 21 | 22 | (defun function-name (function) 23 | (nth-value 2 (function-lambda-expression function))) 24 | 25 | (defgeneric source-location (object)) 26 | 27 | (defmethod source-location ((symbol symbol)) 28 | (when (pathnamep (ext:source-pathname symbol)) 29 | (let* ((file (ext:source-pathname symbol)) 30 | (pos (ext:source-file-position symbol)) 31 | (exists (probe-file file))) 32 | (values file 33 | (when exists (newlines-until-pos file pos)) 34 | (when exists (read-source-form file pos)))))) 35 | 36 | (defmethod source-location ((frame sys::java-stack-frame)) 37 | (destructuring-bind (&key class method file line) (sys:frame-to-list frame) 38 | (declare (ignore method)) 39 | (let ((file (or (find-file-in-path file *source-path*) 40 | (let ((f (format nil "~{~a/~}~a" 41 | (butlast (split-string class "\\.")) 42 | file))) 43 | (find-file-in-path f *source-path*))))) 44 | (and file 45 | (values file line))))) 46 | 47 | (defmethod source-location ((frame sys::lisp-stack-frame)) 48 | (let ((operator (first (sys:frame-to-list frame)))) 49 | (etypecase operator 50 | (list nil) 51 | (function (source-location operator)) 52 | (symbol (source-location operator))))) 53 | 54 | (defmethod source-location ((fun function)) 55 | (let ((name (function-name fun))) 56 | (and name (source-location name)))) 57 | 58 | (defun translate-class-name (symbol) 59 | ()) 60 | 61 | (defun system-property (name) 62 | (java:jstatic "getProperty" "java.lang.System" name)) 63 | 64 | (defun pathname-parent (pathname) 65 | (make-pathname :directory (butlast (pathname-directory pathname)))) 66 | 67 | (defun pathname-absolute-p (pathname) 68 | (eq (car (pathname-directory pathname)) ':absolute)) 69 | 70 | (defun split-string (string regexp) 71 | (coerce 72 | (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String") string regexp) 73 | 'list)) 74 | 75 | (defun path-separator () 76 | (java:jfield "java.io.File" "pathSeparator")) 77 | 78 | (defun search-path-property (prop-name) 79 | (let ((string (system-property prop-name))) 80 | (and string (remove nil (mapcar #'truename (split-string string (path-separator))))))) 81 | 82 | (defun jdk-source-path () 83 | (let* ((jre-home (truename (system-property "java.home"))) 84 | (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home))) 85 | (truename (probe-file src-zip))) 86 | (and truename (list truename)))) 87 | 88 | (defun class-path () 89 | (append (search-path-property "java.class.path") 90 | (search-path-property "sun.boot.class.path"))) 91 | 92 | (defvar *source-path* 93 | (append (search-path-property "user.dir") 94 | (jdk-source-path)) 95 | "List of directories to search for source files.") 96 | 97 | (defun zipfile-contains-p (zipfile-name entry-name) 98 | (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile" "java.lang.String") zipfile-name))) 99 | (java:jcall (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String") zipfile entry-name))) 100 | 101 | (defun find-file-in-path (filename path) 102 | (labels ((try (dir) 103 | (cond ((not (pathname-type dir)) 104 | (let ((f (probe-file (merge-pathnames filename dir)))) 105 | (and f `(:file ,(namestring f))))) 106 | ((equal (pathname-type dir) "zip") 107 | (try-zip dir)) 108 | (t (error "strange path element: ~s" path)))) 109 | (try-zip (zip) 110 | (let* ((zipfile-name (namestring (truename zip)))) 111 | (and (zipfile-contains-p zipfile-name filename) 112 | `(:dir ,zipfile-name ,filename))))) 113 | (cond ((pathname-absolute-p filename) (probe-file filename)) 114 | (t 115 | (loop for dir in path 116 | if (try dir) return it))))) 117 | 118 | (defun make-call (i frame) 119 | (destructuring-bind (function . args) (sys:frame-to-list frame) 120 | (make-instance 121 | 'abcl-call 122 | :pos i 123 | :call function 124 | :args args 125 | :frame frame))) 126 | 127 | (setf (fdefinition 'stack) 128 | (lambda () 129 | (chop-stack 130 | (loop for frame in (cddr (sys:backtrace)) 131 | for i from 0 132 | collect (make-call i frame))))) 133 | 134 | (defclass abcl-restart (restart) 135 | ((interactive :initarg :interactive :accessor interactive) 136 | (test :initarg :test :accessor test))) 137 | 138 | (defun make-restart (restart) 139 | (make-instance 140 | 'abcl-restart 141 | :name (system::restart-name restart) 142 | :restart (system::restart-function restart) 143 | :report (let* ((*print-readably* NIL) 144 | (report (system::restart-report-function restart))) 145 | (typecase report 146 | (function (with-output-to-string (stream) 147 | (funcall report stream))) 148 | (T report))) 149 | :interactive (system::restart-interactive-function restart) 150 | :test (system::restart-test-function restart) 151 | :object restart)) 152 | 153 | (setf (fdefinition 'restarts) 154 | (lambda (&optional condition) 155 | (mapcar #'make-restart (compute-restarts condition)))) 156 | -------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defmacro setdocs (&body pairs) 4 | `(progn 5 | ,@(loop for (type var doc) in pairs 6 | collect `(setf (documentation ',var ',type) ,doc)))) 7 | 8 | (setdocs 9 | (function stack 10 | "Returns a list of CALL objects describing the stack from the point where this function was called. 11 | 12 | This excludes the call to STACK itself. 13 | Any calls above a WITH-CAPPED-STACK form, and below a WITH-TRUNCATED-STACK 14 | form are also excluded. 15 | 16 | Returns an empty list on unsupported platforms. 17 | 18 | See CALL 19 | See WITH-TRUNCATED-STACK 20 | See WITH-CAPPED-STACK") 21 | 22 | (function restarts 23 | "Returns a list of RESTART objects describing the currently available restarts. 24 | 25 | If CONDITION is provided, only return restarts associated with this condition. 26 | 27 | Returns an empty list on unsupported platforms. 28 | 29 | See RESTART") 30 | 31 | (function with-truncated-stack 32 | "Calls BODY in an environment where a call to STACK will not report frames further down. 33 | 34 | See STACK") 35 | 36 | (function with-capped-stack 37 | "Calls BODY in an environment where a call to STACK will not report frames further up. 38 | 39 | See STACK") 40 | 41 | (function present 42 | "Prints a neat representation of THING to DESTINATION. 43 | 44 | DESTINATION can be one of the following types: 45 | (eql NIL) --- The representation is printed and returned as a string. 46 | (eql T) --- The representation is printed to *STANDARD-OUTPUT*. 47 | STREAM --- The representation is printed to the stream. 48 | 49 | THING can be one of the following types: 50 | RESTART --- Restarts are presented as: 51 | [NAME] REPORT 52 | CALL --- Calls are presented as: 53 | POS (CALL ARGS..) 54 | ENVIRONMENT --- Environments are presented as a multiline description 55 | of all the parts it references (condition, stack, 56 | restarts, thread). 57 | CONDITION --- Conditions are presented as: 58 | CONDITION 59 | [Condition of type TYPE] 60 | (EQL T) --- Presents the environment at point using 61 | CAPTURE-ENVIRONMENT. 62 | LIST --- The list can contain either restarts or calls. In both 63 | cases the behaviour is to output a header line, followed 64 | by the presentation of each item in the list on its own 65 | line. 66 | 67 | Internally the function PRESENT-OBJECT is used to perform the actual 68 | printing. 69 | 70 | See RESTART 71 | See CALL 72 | See ENVIRONMENT 73 | See CONDITION 74 | See CAPTURE-ENVIRONMENT 75 | See PRESENT-OBJECT") 76 | 77 | (function present-object 78 | "Internal generic function for pretty printing. 79 | 80 | See PRESENT")) 81 | 82 | (setdocs 83 | (type restart 84 | "Class container for restart information. 85 | 86 | See NAME 87 | See REPORT 88 | See RESTART 89 | See OBJECT 90 | See INTERACTIVE 91 | See TEST 92 | See INVOKE") 93 | 94 | (function name 95 | "Returns the restart's symbol. Use this for INVOKE-RESTART. 96 | 97 | See RESTART") 98 | 99 | (function report 100 | "Returns the report string describing the restart's effects. 101 | 102 | See RESTART") 103 | 104 | (function restart 105 | "Returns a symbol to the restart-function or a direct function-object. 106 | 107 | See RESTART") 108 | 109 | (function object 110 | "Returns the platform-internal restart object. 111 | 112 | See RESTART") 113 | 114 | (function interactive 115 | "Returns the interactive restart function. 116 | 117 | See RESTART") 118 | 119 | (function test 120 | "Returns the restart test function. 121 | 122 | See RESTART") 123 | 124 | (function invoke 125 | "Invoke the restart that the restart object references. 126 | 127 | See RESTART")) 128 | 129 | (setdocs 130 | (type unknown-arguments 131 | "Used to represent an unknown list of arguments. 132 | 133 | Instances of this class are printed as #") 134 | 135 | (type unavailable-argument 136 | "Used to represent an argument that isn't available in the environment. 137 | 138 | Instances of this class are printed as #")) 139 | 140 | (setdocs 141 | (type call 142 | "Class container for stack frame information. 143 | 144 | See POS 145 | See CALL 146 | See ARGS 147 | See FILE 148 | See LINE 149 | See FORM") 150 | 151 | (function pos 152 | "Returns the position of the call on the stack. 153 | 154 | See CALL") 155 | 156 | (function call 157 | "Returns the stack call function. 158 | 159 | Can be either a function object or the name of a global function. 160 | 161 | See CALL") 162 | 163 | (function args 164 | "Returns a list of arguments that were used in the frame call. 165 | 166 | If the arguments list is not available, this may also return an instance 167 | of UNKNOWN-ARGUMENTS. The values in the list may be instances of 168 | UNAVAILABLE-ARGUMENT if the argument is unknown or could not be captured 169 | for some reason. 170 | 171 | See UNKNOWN-ARGUMENTS 172 | See UNAVAILABLE-ARGUMENT 173 | See CALL") 174 | 175 | (function locals 176 | "Returns a dotted alist of locals bound in the frame call. 177 | 178 | If the locals are not available, returns NIL. 179 | 180 | See CALL") 181 | 182 | (function file 183 | "If possible, returns the file the called function is defined in. 184 | 185 | See CALL") 186 | 187 | (function line 188 | "If possible, returns the line number in the file where the function is defined. 189 | 190 | See CALL") 191 | 192 | (function form 193 | "If possible, returns the actual definition form of the function. 194 | 195 | See CALL")) 196 | 197 | (setdocs 198 | (type environment 199 | "Container class for a current \"environment\". 200 | 201 | An instance of this class is intended to represent most of the runtime 202 | environment present at a particular point. It is useful for stashing away 203 | debug information for inspection at a later date. 204 | 205 | See CAPTURE-ENVIRONMENT 206 | See ENVIRONMENT-CONDITION 207 | See ENVIRONMENT-STACK 208 | See ENVIRONMENT-RESTARTS 209 | See ENVIRONMENT-THREAD") 210 | 211 | (function environment-condition 212 | "Returns the condition stored in the environment (if any). 213 | 214 | See CL:CONDITION 215 | See ENVIRONMENT") 216 | 217 | (function environment-stack 218 | "Returns a list of calls stored in the environment (if any). 219 | 220 | See CALL 221 | See ENVIRONMENT") 222 | 223 | (function environment-restarts 224 | "Returns a list of restarts stored in the environment (if any). 225 | 226 | See CL:RESTART 227 | See ENVIRONMENT") 228 | 229 | (function environment-thread 230 | "Returns the thread stored in the environment (if any). 231 | 232 | See SB-THREAD:THREAD 233 | See THREADS:THREAD 234 | See MP:PROCESS 235 | See MT:THREAD 236 | See CCL:PROCESS 237 | See PROCESS:PROCESS 238 | See THREAD:THREAD 239 | See ENVIRONMENT") 240 | 241 | (function capture-environment 242 | "Capture the current environment into an environment object. 243 | 244 | See ENVIRONMENT")) 245 | -------------------------------------------------------------------------------- /backend/clisp.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.tymoonnext.dissect) 2 | 3 | (defclass clisp-call (call) 4 | ((spec :initarg :spec :accessor spec) 5 | (frame-type :initarg :frame-type :accessor frame-type))) 6 | 7 | (defmethod print-object ((call clisp-call) stream) 8 | (print-unreadable-object (call stream :type T) 9 | (format stream "[~a] ~s ~s~@[ | ~a~@[:~a~]~]" 10 | (pos call) (frame-type call) (call call) (file call) (line call)))) 11 | 12 | (defun resolve-file-slots (call) 13 | (let ((file (file call)) 14 | (name (car (spec call))) 15 | (line (cdr (spec call)))) 16 | (if file 17 | (multiple-value-bind (line form) 18 | (if line 19 | (values line (read-source-form-at-line file line)) 20 | (multiple-value-bind (pos form) (find-definition-in-file file name) 21 | (values (newlines-until-pos file pos) form))) 22 | (setf (slot-value call 'line) line) 23 | (setf (slot-value call 'form) form)) 24 | (setf (slot-value call 'line) NIL 25 | (slot-value call 'form) NIL))) 26 | call) 27 | 28 | (macrolet ((define-resolvent (name) 29 | `(defmethod ,name ((call clisp-call)) 30 | (unless (slot-boundp call ',name) 31 | (resolve-file-slots call)) 32 | (call-next-method)))) 33 | (define-resolvent line) 34 | (define-resolvent form)) 35 | 36 | (defun definition-file (name) 37 | (let* ((fspec (first (documentation name 'sys::file))) 38 | (file (if (consp fspec) 39 | (second fspec) 40 | fspec)) 41 | (line (if (consp fspec) 42 | (third fspec)))) 43 | (when (and file (member (pathname-type file) custom:*compiled-file-types* :test #'equal)) 44 | (setf file (loop for suffix in custom:*source-file-types* 45 | thereis (probe-file (make-pathname :defaults file :type suffix))))) 46 | (when file 47 | (values (ignore-errors (truename file)) 48 | (cons name line))))) 49 | 50 | (defparameter *frame-prefixes* 51 | '(("\\[[0-9]+\\] frame binding variables" :bind-var) 52 | ("\\[[0-9]+\\] EVAL frame" :eval) 53 | ("\\[[0-9]+\\] compiled tagbody frame" :compiled-tagbody) 54 | ("\\[[0-9]+\\] compiled block frame" :compiled-block) 55 | ("\\[[0-9]+\\] unwind-protect frame" :unwind-protect) 56 | ("\\[[0-9]+\\] frame binding environments" :bind-env) 57 | ("\\[[0-9]+\\] catch frame" :catch) 58 | ("\\[[0-9]+\\] handler frame" :handler) 59 | ("<1(/[0-9]*)?> # # # " :fun) 63 | ("<2(/[0-9]*)?> " :2nd-frame) 64 | ("APPLY frame" :apply) 65 | ("block frame" :block) 66 | ("nested block frame" :block) 67 | ("tagbody frame" :tagbody) 68 | ("nested tagbody frame" :tagbody) 69 | ("driver frame" :driver) 70 | ("CALLBACK frame" :callback) 71 | ("- " :stack-value))) 72 | 73 | (defun starts-with-p (regexp string) 74 | (not (null (cl-ppcre:scan (concatenate 'string "^" regexp) string)))) 75 | 76 | (defun string-match (pattern string &optional (group 0)) 77 | (let ((match (nth-value 1 (cl-ppcre:scan-to-strings pattern string)))) 78 | (when match (elt match group)))) 79 | 80 | (defun trim-whitespace (string) 81 | (string-trim #(#\newline #\space #\tab) string)) 82 | 83 | (defun ensure-frame-string (frame) 84 | (etypecase frame 85 | (string frame) 86 | (#+NIL system::frame-pointer 87 | T 88 | ;; Note about the above kludge: 89 | ;; According to the hyperspec (typep o (type-of o)) 90 | ;; always has to return true, but in the case of 91 | ;; frame-pointers and clisp, it always errors, saying 92 | ;; that it isn't a valid type specifier. 93 | ;; We fall back to just using describe-frame by 94 | ;; default, which is less nice. 95 | (with-output-to-string (stream) 96 | (sys::describe-frame stream frame))))) 97 | 98 | (defmethod frame-type ((frame T)) 99 | ;; again as above, we can't test better than this. 100 | (frame-type (ensure-frame-string frame))) 101 | 102 | (defmethod frame-type ((frame string)) 103 | (loop for (pattern type) in *frame-prefixes* 104 | do (when (starts-with-p pattern frame) 105 | (return type)))) 106 | 107 | (defun unneeded-frame-p (frame) 108 | (find (frame-type frame) '(:stack-value :bind-var :bind-env :compiled-tagbody :compiled-block))) 109 | 110 | (defun split-frame-string (string) 111 | (let ((regex (format nil "~%\\(~{~A~^\\|~}\\)" (mapcar #'first *frame-prefixes*)))) 112 | (loop for pos = 0 then (1+ (regexp:match-start match)) 113 | for match = (regexp:match regex string :start pos) 114 | collect (if match 115 | (subseq string pos (regexp:match-start match)) 116 | (subseq string pos)) 117 | while match))) 118 | 119 | (defun extract-function-name (frame) 120 | (let ((frame-string (ensure-frame-string frame))) 121 | (let ((first (first (split-frame-string frame-string)))) 122 | (or (string-match (format nil "^<1(/[0-9]*)?>[ ~%]*#<[-A-Za-z]* (.*)>") first 1) 123 | (string-match (format nil "^<1(/[0-9]*)?>[ ~%]*(.*)") first 1) 124 | first)))) 125 | 126 | (defun extract-frame-line (frame) 127 | (let ((frame-string (ensure-frame-string frame))) 128 | (let ((name (case (frame-type frame-string) 129 | ((:eval :special-op) 130 | (string-match "EVAL frame .*?for form ([\\s\\S]*)" frame-string)) 131 | (:apply 132 | (string-match "APPLY frame .*?for call ([\\s\\S]*)" frame-string)) 133 | ((:compiled-fun :sys-fun :fun) 134 | (extract-function-name frame-string)) 135 | (:catch 'catch) 136 | (:handler 'handler-bind) 137 | (:unwind-protect 'unwind-protect) 138 | (T frame-string)))) 139 | (or (ignore-errors (read-from-string name)) name)))) 140 | 141 | (defun frame-venv (frame) 142 | (let ((env (sys::eval-at frame '(sys::the-environment)))) 143 | (svref env 0))) 144 | 145 | (defun next-venv (venv) 146 | (svref venv (1- (length venv)))) 147 | 148 | (defun venv-ref (env i) 149 | (let ((idx (* i 2))) 150 | (if (< idx (1- (length env))) 151 | (values (svref env idx) (svref env (1+ idx))) 152 | (venv-ref (next-venv env) (- i (/ (1- (length env)) 2)))))) 153 | 154 | (defun parse-stack-values (frame) 155 | (labels ((next (frame) (sys::frame-down 1 frame 1)) 156 | (parse (frame accumulator) 157 | (let ((string (ensure-frame-string frame))) 158 | (case (frame-type frame) 159 | (:stack-value 160 | (parse (next frame) (cons string accumulator))) 161 | (:fun 162 | (dolist (string (rest (split-frame-string string))) 163 | (when (eql (frame-type string) :stack-value) 164 | (push string accumulator))) 165 | (nreverse accumulator)) 166 | (T (parse (next frame) accumulator)))))) 167 | (parse (next frame) ()))) 168 | 169 | (defun frame-var-count (frame) 170 | (cond ((sys::eval-frame-p frame) 171 | (loop for venv = (frame-venv frame) then (next-venv venv) 172 | while venv 173 | sum (/ (1- (length venv)) 2))) 174 | ((member (frame-type frame) '(:compiled-fun :sys-fun :fun :special-op)) 175 | (length (parse-stack-values frame))) 176 | (T NIL))) 177 | 178 | (defun frame-var-name (frame i) 179 | (cond ((sys::eval-frame-p frame) 180 | (venv-ref (frame-venv frame) i)) 181 | (t (format nil "~D" i)))) 182 | 183 | (defun frame-var-value (frame i) 184 | (cond ((sys::eval-frame-p frame) 185 | (let ((name (venv-ref (frame-venv frame) i))) 186 | (ignore-errors 187 | (sys::eval-at frame name)))) 188 | ((member (frame-type frame) '(:compiled-fun :sys-fun :fun :special-op)) 189 | (let ((str (nth i (parse-stack-values frame)))) 190 | (trim-whitespace (subseq str 2)))))) 191 | 192 | (defun make-call (i frame) 193 | (let* ((type (frame-type frame)) 194 | (call (extract-frame-line frame)) 195 | (locals (let ((count (frame-var-count frame))) 196 | (when count 197 | (loop for i from 0 below count 198 | collect (cons (frame-var-name frame i) 199 | (frame-var-value frame i)))))) 200 | (args (case type 201 | ((:eval :apply) 202 | (when (listp call) (cdr call))) 203 | (T (or (and locals 204 | (mapcar #'cdr locals)) 205 | (make-instance 'unknown-arguments))))) 206 | (call (if (and (find type '(:eval :apply)) (listp call)) 207 | (first call) 208 | call))) 209 | (multiple-value-bind (file spec) (definition-file call) 210 | (make-instance 211 | 'clisp-call 212 | :pos i 213 | :call call 214 | :args args 215 | :locals locals 216 | :frame-type type 217 | :file file 218 | :spec spec)))) 219 | 220 | (setf (fdefinition 'stack) 221 | (lambda () 222 | (chop-stack 223 | (let ((mode 2 #|all-stack-elements|#)) 224 | (loop with i = -1 225 | for last = NIL then frame 226 | for frame = (sys::the-frame) 227 | then (sys::frame-up 1 frame mode) 228 | until (eq frame last) 229 | unless (unneeded-frame-p frame) 230 | collect (make-call (incf i) frame)))))) 231 | 232 | ;;;;; 233 | ;; Restarts 234 | 235 | (defclass clisp-restart (restart) 236 | ()) 237 | 238 | (defun make-restart (restart) 239 | (make-instance 240 | 'clisp-restart 241 | :name (system::restart-name restart) 242 | :report (let* ((*print-readably* NIL) 243 | (report (system::restart-report restart))) 244 | (typecase report 245 | (function (with-output-to-string (stream) 246 | (funcall report stream))) 247 | (T report))) 248 | :restart (system::restart-invoke-function restart) 249 | :object restart 250 | :interactive (system::restart-interactive restart) 251 | :test (system::restart-test restart))) 252 | 253 | (setf (fdefinition 'restarts) 254 | (lambda (&optional condition) 255 | (mapcar #'make-restart (compute-restarts condition)))) 256 | -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 | Dissect

dissect

1.0.0

A lib for introspecting the call stack and active restarts.

About Dissect Build Status

Dissect is a small library for introspecting the call stack and active restarts.

Supported Implementations

Since the call stack and restart inspection are not part of ANSI CL, pretty much all of Dissect is implementation-dependant. Currently the following implementations are supported:

  • ABCL
  • Allegro
  • CCL
  • CLISP
  • ECL
  • SBCL

How To

Retrieving a list of restart objects is done through restarts. Similarly, the current stack can be seen with stack. Returned by both are a list of objects, from which you can read out information. Depending on the implementation, additional slots may be included.

(dissect:stack)
  2 | ; => (#<CCL-CALL [0] CALL-CHECK-REGS | ccl:l1;l1-readloop.lisp.newest:827> #<CCL-CALL [1] CHEAP-EVAL | ...)
  3 | 
  4 | (dissect:restarts)
  5 | ; => (#<CCL-RESTART [SWANK::RETRY] "Retry SLIME REPL evaluation request."> #<CCL-RESTART [ABORT] ...)
  6 | 
  7 | (dissect:form (first (dissect:stack)))
  8 | ; => (DEFUN CALL-CHECK-REGS (FN &REST ARGS) ...)
  9 | 
 10 | (dissect:restart (first (dissect:restarts)))
 11 | ; => CCL:SIMPLE-RESTART
 12 |

You can also get a fancy print of calls, restarts, conditions, or the current state using present:

(dissect:present T)
 13 | 
 14 | (handler-bind ((error #'dissect:present))
 15 |   (error "Hello!"))
 16 |

Sometimes having the full stack shown gives you a lot of noise and uninteresting information. To limit this --and thus make the stacks dissect returns cleaner-- you can use with-truncated-stack and with-capped-stack. Those will ensure that only frames above and below the respective macros are shown. Similarly, those can easily lead to completely empty stack reports, so make sure to only use them where you are absolutely sure that you will not need the information anymore.

When you need to capture the current environment because for later processing, you can use capture-environment. This will return an object that contains the current stack, restarts, thread, and an optional condition object. Using this, the entire environment surrounding an error can be saved. present also works with an environment object.

System Information

1.0.0
Nicolas Hafner
Artistic
https://github.com/Shinmera/dissect

Definition Index

  • DISSECT

    • ORG.TYMOONNEXT.DISSECT
    Source
    No documentation provided.
    • EXTERNAL CLASS

      UNAVAILABLE-ARGUMENT

          Source 
          Used to represent an argument that isn't available in the environment.
 42 | 
 43 | Instances of this class are printed as #<Unavailable>
        • EXTERNAL CLASS

          UNKNOWN-ARGUMENTS

              Source 
              Used to represent an unknown list of arguments.
 44 | 
 45 | Instances of this class are printed as #<Unknown Arguments>
            • EXTERNAL FUNCTION

              PRESENT

                • THING
                • &OPTIONAL
                • (DESTINATION T)
                Source 
                Prints a neat representation of THING to DESTINATION.
 48 | 
 49 | DESTINATION can be one of the following types:
 50 |   (eql NIL)  --- The representation is printed and returned as a string.
 51 |   (eql T)    --- The representation is printed to *STANDARD-OUTPUT*.
 52 |   STREAM     --- The representation is printed to the stream.
 53 | 
 54 | THING can be one of the following types:
 55 |   RESTART      --- Restarts are presented as:
 56 |                      [NAME] REPORT
 57 |   CALL         --- Calls are presented as:
 58 |                      POS (CALL ARGS..)
 59 |   ENVIRONMENT  --- Environments are presented as a multiline description
 60 |                    of all the parts it references (condition, stack,
 61 |                    restarts, thread).
 62 |   CONDITION    --- Conditions are presented as:
 63 |                      CONDITION
 64 |                        [Condition of type TYPE]
 65 |   (EQL T)      --- Presents the environment at point using
 66 |                    CAPTURE-ENVIRONMENT.
 67 |   LIST         --- The list can contain either restarts or calls. In both
 68 |                    cases the behaviour is to output a header line, followed
 69 |                    by the presentation of each item in the list on its own
 70 |                    line.
 71 | 
 72 | Internally the function PRESENT-OBJECT is used to perform the actual
 73 | printing.
 74 | 
 75 | See RESTART
 76 | See CALL
 77 | See ENVIRONMENT
 78 | See CONDITION
 79 | See CAPTURE-ENVIRONMENT
 80 | See PRESENT-OBJECT
              • EXTERNAL FUNCTION

                RESTARTS

                    Source 
                    Returns a list of RESTART objects describing the currently available restarts.
 81 | 
 82 | Returns an empty list on unsupported platforms.
 83 | 
 84 | See RESTART
                  • EXTERNAL FUNCTION

                    STACK

                        Source 
                        Returns a list of CALL objects describing the stack from the point where this function was called.
 85 | 
 86 | This excludes the call to STACK itself.
 87 | Any calls above a WITH-CAPPED-STACK form, and below a WITH-TRUNCATED-STACK
 88 | form are also excluded.
 89 | 
 90 | Returns an empty list on unsupported platforms.
 91 | 
 92 | See CALL
 93 | See WITH-TRUNCATED-STACK
 94 | See WITH-CAPPED-STACK
                      • EXTERNAL GENERIC-FUNCTION

                        ARGS

                          • OBJECT
                          Returns a list of arguments that were used in the frame call.
 95 | 
 96 | If the arguments list is not available, this may also return an instance
 97 | of UNKNOWN-ARGUMENTS. The values in the list may be instances of
 98 | UNAVAILABLE-ARGUMENT if the argument is unknown or could not be captured
 99 | for some reason.
100 | 
101 | See UNKNOWN-ARGUMENTS
102 | See UNAVAILABLE-ARGUMENT
103 | See CALL
                        • EXTERNAL GENERIC-FUNCTION

                          CALL

                            • OBJECT
                            Returns the stack call function.
104 | 
105 | Can be either a function object or the name of a global function.
106 | 
107 | See CALL
                          • EXTERNAL GENERIC-FUNCTION

                            ENVIRONMENT-THREAD

                              • OBJECT
                              Returns the thread stored in the environment (if any).
117 | 
118 | See SB-THREAD:THREAD
119 | See THREADS:THREAD
120 | See MP:PROCESS
121 | See MT:THREAD
122 | See CCL:PROCESS
123 | See PROCESS:PROCESS
124 | See THREAD:THREAD
125 | See ENVIRONMENT
                            • EXTERNAL GENERIC-FUNCTION

                              FILE

                                • OBJECT
                                If possible, returns the file the called function is defined in.
126 | 
127 | See CALL
                              • EXTERNAL GENERIC-FUNCTION

                                FORM

                                  • OBJECT
                                  If possible, returns the actual definition form of the function.
128 | 
129 | See CALL
                                • EXTERNAL GENERIC-FUNCTION

                                  INVOKE

                                    • RESTART
                                    • &REST
                                    • ARGS
                                    Source 
                                    Invoke the restart that the restart object references.
130 | 
131 | See RESTART
                                  • EXTERNAL GENERIC-FUNCTION

                                    LINE

                                      • OBJECT
                                      If possible, returns the line number in the file where the function is defined.
132 | 
133 | See CALL
                                    • EXTERNAL GENERIC-FUNCTION

                                      NAME

                                        • OBJECT
                                        Returns the restart's symbol. Use this for INVOKE-RESTART.
134 | 
135 | See RESTART
                                      • EXTERNAL GENERIC-FUNCTION

                                        OBJECT

                                          • OBJECT
                                          Returns the platform-internal restart object.
136 | 
137 | See RESTART
                                        • EXTERNAL GENERIC-FUNCTION

                                          POS

                                            • OBJECT
                                            Returns the position of the call on the stack.
138 | 
139 | See CALL
                                          • EXTERNAL GENERIC-FUNCTION

                                            REPORT

                                              • OBJECT
                                              Returns the report string describing the restart's effects.
142 | 
143 | See RESTART
                                            • EXTERNAL GENERIC-FUNCTION

                                              RESTART

                                                • OBJECT
                                                Returns a symbol to the restart-function or a direct function-object.
144 | 
145 | See RESTART
                                              • EXTERNAL MACRO

                                                WITH-CAPPED-STACK

                                                  • &BODY
                                                  • BODY
                                                  Source 
                                                  Calls BODY in an environment where a call to STACK will not report frames further up.
146 | 
147 | See STACK
                                                • EXTERNAL MACRO

                                                  WITH-TRUNCATED-STACK

                                                    • &BODY
                                                    • BODY
                                                    Source 
                                                    Calls BODY in an environment where a call to STACK will not report frames further down.
148 | 
149 | See STACK
                                                --------------------------------------------------------------------------------