├── .github └── pull_request_template.md ├── .gitignore ├── LICENSE ├── README.org ├── guix.scm ├── source ├── description.lisp ├── fields.lisp └── package.lisp └── trivial-inspect.asd /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | # Description 2 | 3 | Please include a summary of the change and a link to which issue is fixed. Please also include relevant motivation and context. List any dependencies that are required for this change. 4 | 5 | Fixes # (issue) 6 | 7 | # Discussion 8 | 9 | Mention there any suspicious parts of the new code, or the ideas that you'd like to discuss in regards to this change. 10 | 11 | # Checklist: 12 | Everything in this checklist is required for each PR. Please do not approve a PR that does not have all of these items. 13 | 14 | - [ ] Git hygiene: 15 | - I have pulled from main/master before submitting this PR 16 | - There are no merge conflicts. 17 | - [ ] I've added the new dependencies as: 18 | - ASDF dependencies, 19 | - Git submodules, 20 | ```sh 21 | cd /path/to/trivial-inspect/checkout 22 | git submodule add https://gitlab.common-lisp.net/nyxt/py-configparser _build/py-configparser 23 | ``` 24 | - and Guix dependencies. 25 | - [ ] My code follows the style guidelines for Common Lisp code. See: 26 | - [Norvig & Pitman's Tutorial on Good Lisp Programming Style (PDF)](https://www.cs.umd.edu/~nau/cmsc421/norvig-lisp-style.pdf) 27 | - [Google Common Lisp Style Guide](https://google.github.io/styleguide/lispguide.xml) 28 | - [ ] I have performed a self-review of my own code. 29 | - [ ] My code has been reviewed by at least one peer. (The peer review to approve a PR counts. The reviewer must download and test the code.) 30 | - [ ] Documentation: 31 | - All my code has docstrings and `:documentation`s written in the aforementioned style. (It's OK to skip the docstring for really trivial parts.) 32 | - I have updated the existing documentation to match my changes. 33 | - I have commented my code in hard-to-understand areas. 34 | - [ ] Compilation and tests: 35 | - My changes generate no new warnings. 36 | - I have added tests that prove my fix is effective or that my feature works. (If possible.) 37 | - I ran the tests locally (`(asdf:test-system :trivial-inspect)`) and they pass. 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore compiled lisp files 2 | *.FASL 3 | *.fasl 4 | *.fas 5 | *.lisp-temp 6 | *.dfsl 7 | *.pfsl 8 | *.d64fsl 9 | *.p64fsl 10 | *.lx64fsl 11 | *.lx32fsl 12 | *.dx64fsl 13 | *.dx32fsl 14 | *.fx64fsl 15 | *.fx32fsl 16 | *.sx64fsl 17 | *.sx32fsl 18 | *.wx64fsl 19 | *.wx32fsl 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2024-2025, Artyom Bologov 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE:trivial-inspect 2 | 3 | *A portable toolkit for building inspectors* 4 | 5 | ~trivial-inspect~ exposes a set of utils useful in building inspectors 6 | akin to standard ~inspect~ and ~describe~. The goal is to provide as 7 | much information as possible. Including the implementation-specific 8 | info. 9 | 10 | * Getting Started 11 | Clone the Git repository: 12 | #+begin_src sh 13 | git clone --recursive https://github.com/aartaka/trivial-inspect ~/common-lisp/ 14 | #+end_src 15 | 16 | And then load ~:trivial-inspect~ in the REPL: 17 | #+begin_src lisp 18 | (asdf:load-system :trivial-inspect) 19 | ;; or, if you use Quicklisp 20 | (ql:quickload :trivial-inspect) 21 | #+end_src 22 | 23 | You can also use the bundled ~guix.scm~ to install it on Guix. 24 | 25 | * APIs 26 | Two main entry points of this library are ~fields~ and ~description~: 27 | 28 | ** fields (object) -> fields 29 | 30 | ~fields~ returns a list of inspect properties for a given object 31 | Each property is a list of 32 | - Index 33 | - Property name (either index, keyword, or some standard library symbol, usually a getter function) 34 | - Value of the property 35 | - And optional setter to override this property. A function of two arguments—new value and old value. 36 | 37 | #+begin_src lisp 38 | (trivial-inspect:fields #'identity) 39 | ;; ((0 :self #) (1 :id 1407351035) 40 | ;; (2 class-of # #) 41 | ;; (3 type-of compiled-function) (4 :name identity) (5 :arguments (sb-impl::thing)) 42 | ;; (6 compiled-function-p t) (7 :ftype (function # #)) 43 | ;; (8 :expression nil) 44 | ;; (9 lambda-list-keywords (&allow-other-keys &aux &body &environment &key sb-int:&more &optional &rest &whole)) 45 | ;; (10 call-arguments-limit 1073741824) (11 lambda-parameters-limit 1073741824)) 46 | (trivial-inspect:fields nil) 47 | ;; ((0 :self nil) (1 :id 1342177559) 48 | ;; (2 class-of # nil) 49 | ;; (3 type-of null) (4 length 0) 50 | ;; (5 symbol-name "NIL") (6 symbol-package #) 51 | ;; (7 :visibility :external #) 52 | ;; (8 symbol-value nil #) (9 symbol-plist nil)) 53 | (trivial-inspect:fields (find-class 'standard-object)) 54 | ;; ((0 :self #) (1 :id 68721940739) 55 | ;; (2 class-of # 56 | ;; #) 57 | ;; (3 :slot-definitions 58 | ;; (# # ..))) 59 | #+end_src 60 | 61 | ** description (object &optional stream) 62 | 63 | ~description~ returns/prints a human-readable description of the given object. 64 | Quite opinionated, but optimized for maximum useful info (if you have an idea for a better format, I'm open to discussion!) 65 | Usually includes type and printable representation, possibly followed by prettified ~fields~ and other info. 66 | 67 | #+begin_src lisp 68 | (trivial-inspect:description #'+ t) 69 | ;; Compiled-function + (&REST NUMBERS) 70 | ;; : (&REST NUMBER) -> (VALUES NUMBER &OPTIONAL) 71 | ;; Return the sum of its arguments. With no args, returns 0. 72 | (trivial-inspect:description 'standard-class t) 73 | ;; Symbol STANDARD-CLASS (EXTERNAL to COMMON-LISP) [class] 74 | (trivial-inspect:description (find-class 'standard-class) t) 75 | ;; Standard-class # 76 | #+end_src 77 | -------------------------------------------------------------------------------- /guix.scm: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Artyom Bologov 2 | ;;;; SPDX-License-Identifier: BSD-2 Clause 3 | 4 | ;;; Commentary: 5 | ;; 6 | ;; GNU Guix development package. To build and install, clone this repository, 7 | ;; switch directory to here and run: 8 | ;; 9 | ;; guix package --install-from-file=guix.scm 10 | ;; 11 | ;; To use as the basis for a development environment, run: 12 | ;; 13 | ;; guix shell --container -D -f guix.scm 14 | ;; 15 | ;; Replace --container by --pure if you still want ASDF to see external 16 | ;; libraries in ~/common-lisp, etc. 17 | ;; 18 | ;;; Code: 19 | 20 | (use-modules (guix packages) 21 | ((guix licenses) #:prefix license:) 22 | (guix gexp) 23 | (guix git-download) 24 | (guix build-system asdf) 25 | (gnu packages) 26 | (gnu packages lisp) 27 | (gnu packages lisp-check) 28 | (gnu packages lisp-xyz)) 29 | 30 | (define-public sbcl-trivial-inspect 31 | (package 32 | (name "sbcl-trivial-inspect") 33 | (version "0.0.0") 34 | (source 35 | (local-file (dirname (current-filename)) #:recursive? #t) 36 | ;;;; Or this, in case of contributing to Guix. 37 | ;; (origin 38 | ;; (method git-fetch) 39 | ;; (uri (git-reference 40 | ;; (url "https://github.com/aartaka/trivial-inspect") 41 | ;; (commit version))) 42 | ;; (file-name (git-file-name "cl-trivial-inspect" version)) 43 | ;; (sha256 44 | ;; (base32 45 | ;; "SPECIFY-HASH"))) 46 | ) 47 | (build-system asdf-build-system/sbcl) 48 | ;; We use `cl-*' inputs and not `sbcl-*' ones so that CCL users can also use 49 | ;; this Guix manifests. 50 | ;; 51 | ;; Another reason is to not fail when an input dependency is found in 52 | ;; ~/common-lisp, which would trigger a rebuild of the SBCL input in the 53 | ;; store, which is read-only and would thus fail. 54 | ;; 55 | ;; The official Guix package should use `sbcl-*' inputs though. 56 | (native-inputs (list cl-lisp-unit2 sbcl)) 57 | (inputs (list cl-trivial-arguments)) 58 | (synopsis "Portability library for building interactive inspectors.") 59 | (home-page "https://github.com/aartaka/trivial-inspect") 60 | (description "trivial-inspect provides building blocks 61 | for interactive inspectors. 62 | Two main functions it exports are: 63 | @itemize 64 | @item @code{fields} to get a list of inspect fields for an object. 65 | @item @code{description} for a concise description of an object to stream. 66 | @end itemize") 67 | (license license:bsd-3))) 68 | 69 | (define-public cl-trivial-inspect 70 | (sbcl-package->cl-source-package sbcl-trivial-inspect)) 71 | 72 | (define-public ecl-trivial-inspect 73 | (sbcl-package->ecl-package sbcl-trivial-inspect)) 74 | 75 | cl-trivial-inspect 76 | -------------------------------------------------------------------------------- /source/description.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Artyom Bologov 2 | ;;;; SPDX-License-Identifier: BSD-2 Clause 3 | 4 | (in-package :trivial-inspect) 5 | 6 | (defgeneric description (object &optional stream) 7 | (:method :before (object &optional stream) 8 | (let* ((type (first (uiop:ensure-list (type-of object))))) 9 | (format stream "~&~@(~a~) " type))) 10 | (:method (object &optional stream) 11 | (format stream "~s" object)) 12 | (:documentation "Print human-readable description of OBJECT to STREAM. 13 | 14 | Methods should include the most useful information and things that are 15 | not suitable for the `fields' key-value format.")) 16 | 17 | (defmethod description ((object symbol) &optional stream) 18 | (if (keywordp object) 19 | (format stream "~a" object) 20 | (format stream 21 | "~a (~a~@[ to ~a~]~@[, ~{~a: ~s~^, ~}~])~@[~* [bound]~]~@[~* [fbound]~]~@[~* [class]~]" 22 | object 23 | (symbol-visibility object) (ignore-errors (package-name (symbol-package object))) 24 | (symbol-plist object) 25 | (boundp object) (fboundp object) (ignore-errors (find-class object nil))))) 26 | 27 | ;; TODO: integer binary layout (two's complement?). 28 | (defmethod description ((object integer) &optional stream) 29 | (format stream 30 | "~s (~a bit~:p): 31 | #b~b, #o~o, #x~x~ 32 | ~{~&Universal time: ~2,'0d:~2,'0d:~2,'0d ~ 33 | ~[~;Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~ 34 | ~a~[th~;st~;nd~;rd~:;th~], year ~a.~} ~ 35 | ~{~&Approximate UNIX time: ~2,'0d:~2,'0d:~2,'0d ~ 36 | ~[~;Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~ 37 | ~a~[th~;st~;nd~;rd~:;th~], year ~a.~}" 38 | object (integer-length object) 39 | object object object 40 | (when (>= object 0) 41 | (multiple-value-bind (second minute hour date month year) 42 | (decode-universal-time object) 43 | (list hour minute second month date (mod date 10) year))) 44 | ;; FIXME: Doesn't account for leap seconds. 45 | (when (>= object 0) 46 | (let* ((unix-epoch (encode-universal-time 0 0 0 1 1 1970)) 47 | (unadjusted-time (+ object unix-epoch))) 48 | (multiple-value-bind (usecond uminute uhour udate umonth uyear?) 49 | (decode-universal-time unadjusted-time) 50 | (declare (ignorable usecond uminute uhour udate umonth)) 51 | ;; Leap seconds, one per year. 52 | (multiple-value-bind (usecond uminute uhour udate umonth uyear) 53 | (decode-universal-time (+ unadjusted-time (- uyear? 1970))) 54 | (list uhour uminute usecond umonth udate (mod udate 10) uyear))))))) 55 | 56 | ;; TODO: float/double etc. binary layout 57 | (defmethod description ((object float) &optional stream) 58 | (let ((general (format nil "~s" object)) 59 | (exponential (format nil "~e" object))) 60 | (format stream "~s ~:[(~e)~;~]" object (equal general exponential) object))) 61 | 62 | (defmethod description ((object ratio) &optional stream) 63 | (format stream "~s (~:[~@[-~*~]~d+~s or ~;~2*~]~e)~:[~*~; ~f%~]" 64 | object 65 | (zerop (floor (abs object))) (minusp (signum object)) 66 | (floor (abs object)) (mod (abs object) 1) 67 | object (<= (abs object) 1) (* 100 (coerce object 'float)))) 68 | 69 | (defmethod description ((object complex) &optional stream) 70 | (format stream "~s (~a+~ai)" object (realpart object) (imagpart object))) 71 | 72 | (defmethod description ((object character) &optional stream) 73 | (if (not (graphic-char-p object)) 74 | (format stream "~s (~d/#x~x)" object (char-code object) (char-code object)) 75 | (format stream "~a (~d/#x~x/~a, ~:[punctuation~;~:[alphabetic~;numeric~]~])" 76 | object 77 | (char-code object) (char-code object) (char-name object) 78 | (alphanumericp object) 79 | (digit-char-p object)))) 80 | 81 | (defmethod description ((object cons) &optional stream) 82 | (if (not (consp (cdr object))) 83 | (format stream "(~s . ~s)" (car object) (cdr object)) 84 | (call-next-method))) 85 | 86 | ;; TODO: ECL lists shadowed symbols and used-by list 87 | (defmethod description ((object package) &optional stream) 88 | (format stream "~a~@[/~{~a~^/~}~] [exports ~a/~a~:[~*~;, uses ~{~a~^, ~}~]]~@[: ~a~]" 89 | (package-name object) 90 | (package-nicknames object) 91 | (length (external-symbols object)) 92 | (length (all-symbols object)) 93 | (package-use-list object) 94 | (mapcar #'package-name (package-use-list object)) 95 | (documentation object t))) 96 | 97 | (defmethod description ((object restart) &optional stream) 98 | (format stream "~s~@[~* (interactive)~]~@[: 99 | ~a~]" 100 | (restart-name object) (restart-interactive object) 101 | object)) 102 | 103 | (defmethod description ((object condition) &optional stream) 104 | (format stream "~s: 105 | ~a" 106 | object object)) 107 | 108 | (defmethod description ((object hash-table) &optional stream) 109 | (format stream "[~a, ~d/~d]~:[ 110 | ~s~;~*~]" 111 | (let ((test (hash-table-test object))) 112 | (typecase test 113 | (function (nth-value 2 (function-lambda-expression test))) 114 | (t test))) 115 | (hash-table-count object) (hash-table-size object) 116 | (zerop (hash-table-count object)) 117 | (loop for key being the hash-key in object 118 | using (hash-value val) 119 | collect (list key val)))) 120 | 121 | (defmethod description ((object array) &optional stream) ; string too 122 | (format stream "~{~a~^ ~}[~{~d~^×~}~@[/~d~]]~@[ ~s~]" 123 | (uiop:ensure-list (array-element-type object)) 124 | (array-dimensions object) (ignore-errors (fill-pointer object)) 125 | object)) 126 | 127 | (defmethod description ((object stream) &optional stream) 128 | (labels ((directions (object) 129 | (uiop:ensure-list 130 | (cond 131 | ((typep object 'echo-stream) :echo) 132 | ((typep object 'broadcast-stream) 133 | (mapcar (constantly :out) 134 | (broadcast-stream-streams object))) 135 | ((typep object 'concatenated-stream) 136 | (mapcar (constantly :in) 137 | (concatenated-stream-streams object))) 138 | ((typep object 'synonym-stream) 139 | (cons :synonym 140 | (reduce #'append (mapcar #'directions 141 | (symbol-value (synonym-stream-symbol object)))))) 142 | ((typep object 'two-way-stream) (list :in :out)) 143 | ((input-stream-p object) :in) 144 | ((output-stream-p object) :out))))) 145 | (format stream "~{~a~^+~}~@[~a~]~:[~3*~; 146 | ~@[ ~a~]~@[#L~d~]~@[-~d~]~]" 147 | (directions object) 148 | (uiop:ensure-list (ignore-errors (stream-external-format object))) 149 | (uiop:file-stream-p object) 150 | (ignore-errors (pathname object)) 151 | (ignore-errors (file-position object)) 152 | (ignore-errors (file-length object))))) 153 | 154 | (defmethod description ((object pathname) &optional stream) 155 | (format stream "~a~@[ -~*~a-> ~2:*~a~]" 156 | object 157 | (cond 158 | ((uiop:logical-pathname-p object) 159 | (translate-logical-pathname object)) 160 | ((and (ignore-errors (uiop:native-namestring object)) 161 | (not (equal (namestring object) 162 | (uiop:native-namestring object)))) 163 | (uiop:native-namestring object)) 164 | ((wild-pathname-p object) 165 | (wild-pathname-p object)) 166 | (t (ignore-errors 167 | (unless (equal (truename object) object) 168 | (truename object))))) 169 | (cond 170 | ((uiop:logical-pathname-p object) :logical) 171 | ((wild-pathname-p object) :wild) 172 | ((not (equal object (truename object))) :link)))) 173 | 174 | (defmethod description ((object function) &optional stream) 175 | (let ((name (nth-value 2 (function-lambda-expression object)))) 176 | (format stream "~:[λ~*~;~a ~](~:[?~*~;~{~a~^ ~}~])~:[~2*~; 177 | : ~a -> ~a~]~:[~*~; 178 | ↑ ~s~]~@[ 179 | ~a~]" 180 | (and name (symbolp name)) 181 | name 182 | (not (eq :unknown (trivial-arguments:arglist object))) 183 | (trivial-arguments:arglist object) 184 | (not (eq :unknown (trivial-arguments:argtypes object))) 185 | (nth-value 0 (trivial-arguments:argtypes object)) 186 | (nth-value 1 (trivial-arguments:argtypes object)) 187 | (consp (function-closure-p object)) 188 | (function-closure-p object) 189 | (documentation object t)))) 190 | 191 | (-> object-description ((or standard-object structure-object) (or stream boolean))) 192 | (defun object-description (object stream) 193 | (format stream "~s~@[ 194 | ~a~]" 195 | object (or (documentation (class-name (class-of object)) 'type) 196 | (documentation (class-name (class-of object)) 'structure)))) 197 | 198 | (defmethod description ((object standard-object) &optional stream) 199 | (object-description object stream)) 200 | 201 | (defmethod description ((object structure-object) &optional stream) 202 | (object-description object stream)) 203 | -------------------------------------------------------------------------------- /source/fields.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Artyom Bologov 2 | ;;;; SPDX-License-Identifier: BSD-2 Clause 3 | 4 | (in-package :trivial-inspect) 5 | 6 | ;; Stolen from Serapeum. 7 | (defmacro -> (name (&rest arg-types) &optional return-type) 8 | "Shorter ftype declaration for NAME." 9 | `(declaim (ftype (function (,@arg-types) ,@(when return-type 10 | (list return-type))) 11 | ,name))) 12 | 13 | ;; Stolen from Nyxt: 14 | (-> scalar-p (t) boolean) 15 | (defun scalar-p (object) 16 | "Return true if OBJECT is of one of the following types: 17 | - symbol, 18 | - character, 19 | - string, 20 | - non-complex number." 21 | (typep object '(or symbol character string real))) 22 | 23 | (-> id (t) integer) 24 | (defun id (object) 25 | #+sbcl (sb-kernel:get-lisp-obj-address object) 26 | #+clozure (ccl:%address-of object) 27 | #+ecl (si:pointer object) 28 | #+abcl (system::identity-hash-code object) 29 | #+clisp (system::address-of object) 30 | #+gcl (system:address object) 31 | #+allegro (excl:lispval-to-address object) 32 | #-(or sbcl clozure ecl abcl clisp gcl allegro) (sxhash object)) 33 | 34 | #+sbcl 35 | (defvar sbcl-props-to-ignore 36 | (list 37 | ;; Package 38 | 'sb-impl::%name 'sb-impl::%used-by 'sb-impl::internal-symbols 39 | 'sb-impl::external-symbols 'sb-impl::doc-string 'sb-impl::%local-nicknames 40 | ;; Readtable 41 | 'sb-impl::%readtable-normalization 'sb-impl::%readtable-case 42 | 'sb-impl::%readtable-string-preference 'sb-impl::%readtable-symbol-preference 43 | ;; Pathname 44 | 'sb-impl::host 'sb-impl::device 'sb-impl::name 'sb-impl::version 'type 'namestring 45 | ;; Hash-table 46 | 'sb-impl::test 'sb-impl::rehash-size 'sb-impl::rehash-threshold 'sb-impl::%count 47 | ;; Stream 48 | 'sb-impl::file 'sb-impl::element-type 'sb-impl::dual-channel-p 'sb-impl::pathname)) 49 | 50 | #+sbcl 51 | (defun except-sbcl-props (object) 52 | (mapcar #'(lambda (cons) 53 | (list (car cons) (cdr cons))) 54 | (set-difference 55 | (nth-value 2 (sb-impl::inspected-parts object)) 56 | sbcl-props-to-ignore 57 | :key (lambda (x) 58 | (typecase x 59 | (cons (car x)) 60 | (symbol x) 61 | (string x))) 62 | :test #'equal))) 63 | 64 | #+clozure 65 | (defun get-ccl-props (object &rest props) 66 | (mapcar 67 | (lambda (prop) 68 | (list prop 69 | (typecase object 70 | (function 71 | (ccl::nth-immediate object (symbol-value prop))) 72 | (t (ccl:uvref object (symbol-value prop)))))) 73 | props)) 74 | 75 | #+abcl 76 | (defun abcl-props-except (object &rest except) 77 | (loop for (name . value) in (system:inspected-parts object) 78 | unless (member name except :test #'string=) 79 | collect (list (intern name :keyword) value))) 80 | 81 | #+allegro 82 | (defun value (def object) 83 | (let ((type (inspect::field-def-type def)) 84 | (name (inspect::field-def-name def)) 85 | (access (inspect::field-def-access def))) 86 | (ecase type 87 | ((:unsigned-word :unsigned-byte :unsigned-natural 88 | :unsigned-long :unsigned-half-long 89 | :unsigned-3byte :unsigned-long32) 90 | (list name (inspect::component-ref-v object access type))) 91 | ((:lisp :value :func) 92 | (list name (inspect::component-ref object access))) 93 | (:indirect 94 | (destructuring-bind (prefix count ref set) access 95 | (declare (ignore set prefix)) 96 | (loop for i below (funcall count object) 97 | append (list (format nil "~A-~D" name i) 98 | (funcall ref object i)))))))) 99 | 100 | #+allegro 101 | (defun all-allegro-fields (o) 102 | (ignore-errors 103 | (loop for (d dd) on (inspect::inspect-ctl o) 104 | for (name value) = (value d o) 105 | for keyword = (make-keyword name) 106 | until (eq d dd) 107 | collect (list keyword value)))) 108 | 109 | #+allegro 110 | (defun allegro-fields (o &rest fields) 111 | (remove-if-not 112 | (lambda (field) 113 | (member (first field) fields)) 114 | (all-allegro-fields o))) 115 | 116 | (-> field-indices (list) list) 117 | (defun field-indices (fields) 118 | "Map integer indices to every property in FIELDS. 119 | Implies that FIELDS have a (KEY VALUE . ARGS) structure 120 | Non-trivial, because some of the FIELDS have integer keys." 121 | (loop with taken = (remove-if-not #'integerp (mapcar #'first fields)) 122 | for (name) in fields 123 | when (integerp name) 124 | collect name 125 | else 126 | collect (loop for i from 0 127 | while (member i taken) 128 | finally (return (prog1 129 | i 130 | (push i taken)))))) 131 | 132 | (defun reverse-append-index (&rest lists) 133 | (let ((fields (remove-duplicates (reduce #'append (nreverse lists)) 134 | :key #'first 135 | :from-end t))) 136 | (mapcar #'cons (field-indices fields) 137 | fields))) 138 | 139 | (define-method-combination reverse-append-index 140 | :identity-with-one-argument t) 141 | 142 | (defgeneric fields (object &key &allow-other-keys) 143 | (:method-combination reverse-append-index) 144 | (:documentation "Return a list of OBJECT fields to inspect. 145 | Every property is a list of (INDEX NAME VALUE &optional SETTER) lists, where 146 | 147 | - INDEX is an integer showing the index by which to choose 148 | property. Non-trivial, because sequences have their own indices 149 | interfering with simple incrementing indices for inspect fields. 150 | 151 | - NAME is a thing (preferably symbol) naming the property. 152 | 153 | - VALUE is the contents of the property. 154 | 155 | - And SETTER is a function of two arguments (new-value old-value) to 156 | modify the property. For slots, this setter will likely be setting the 157 | `slot-value'.")) 158 | 159 | (-> symbol-visibility (symbol) (or null (member :inherited :external :internal :uninterned))) 160 | (defun symbol-visibility (symbol) 161 | (if (symbol-package symbol) 162 | (nth-value 1 (find-symbol (symbol-name symbol) (symbol-package symbol))) 163 | :uninterned)) 164 | 165 | (defmacro deffields ((name specifier) &body fields) 166 | `(defmethod fields reverse-append-index ((,name ,specifier) &key &allow-other-keys) 167 | ;; Don't want to duplicate fields for MOP-inspectable objects. 168 | ,@fields)) 169 | 170 | (defmacro deffield (specifier name function) 171 | `(defmethod fields reverse-append-index ((object ,specifier) &key &allow-other-keys) 172 | (list (list ,name (,function object))))) 173 | 174 | (deffields (object symbol) 175 | `((symbol-name ,(symbol-name object)) 176 | (symbol-package ,(symbol-package object)) 177 | (:visibility ,(symbol-visibility object) 178 | ,(unless (member (symbol-visibility object) '(nil :uninterned :inherited)) 179 | (lambda (new-value _) 180 | (declare (ignorable _)) 181 | (typecase new-value 182 | ((or (eql :external) 183 | (eql t)) 184 | (export object (symbol-package object))) 185 | ((or (eql :internal) 186 | null) 187 | (unexport object (symbol-package object))) 188 | ((eql :uninterned) 189 | (uiop:unintern* object (symbol-package object) nil)))))) 190 | ,@(when (fboundp object) 191 | (cond 192 | ((special-operator-p object) 193 | `((special-operator-p t))) 194 | ((macro-function object) 195 | `((macro-function ,(macro-function object)))) 196 | ((fboundp object) 197 | `((symbol-function 198 | ,(symbol-function object) 199 | ,(lambda (new-value _) 200 | (declare (ignorable _)) 201 | ;; `compile'? 202 | (setf (fdefinition object) new-value))) 203 | ,@(when (compiler-macro-function object) 204 | `((:compiler-macro-binding ,(compiler-macro-function object)))))))) 205 | ,@(when (boundp object) 206 | `((symbol-value 207 | ,(symbol-value object) 208 | ,(lambda (new-value _) 209 | (declare (ignorable _)) 210 | (setf (symbol-value object) new-value))))) 211 | ,@(when (ignore-errors (find-class object nil)) 212 | `((class ,(ignore-errors (find-class object nil))))) 213 | ,@(when (uiop:find-package* object nil) 214 | `((package ,(uiop:find-package* object nil)))) 215 | (symbol-plist ,(symbol-plist object)))) 216 | 217 | (-> dotted-p (list) boolean) 218 | (defun dotted-p (cons) 219 | (not (null (cdr (last cons))))) 220 | 221 | ;; TODO: Extensible sequences' features? 222 | (deffields (object sequence) 223 | (unless (and (consp object) 224 | (dotted-p object)) 225 | `((length ,(length object))))) 226 | 227 | (deffields (object cons) 228 | (append 229 | (loop for i from 0 230 | for elem in (butlast object) 231 | collect (let ((i i) 232 | (elem elem)) 233 | (list i elem (lambda (new-value _) 234 | (declare (ignorable _)) 235 | (setf (nth i object) new-value))))) 236 | (let ((last-index (length (butlast object)))) 237 | `((,last-index ,(car (last object)) 238 | ,(lambda (new-value _) 239 | (declare (ignorable _)) 240 | (setf (car (last object)) new-value))))) 241 | (when (dotted-p object) 242 | `((cdr ,(cdr (last object)) 243 | ,(lambda (new-value _) 244 | (declare (ignorable _)) 245 | (setf (cdr (last object)) new-value))))))) 246 | 247 | 248 | (deffields (object complex) 249 | `((imagpart ,(imagpart object)) 250 | (realpart ,(realpart object)))) 251 | 252 | (deffields (object ratio) 253 | `((numerator ,(numerator object)) 254 | (denominator ,(denominator object)) 255 | (round ,(round object)))) 256 | 257 | (deffields (object float) 258 | (multiple-value-bind (significand exponent sign) 259 | (integer-decode-float object) 260 | `((:exponent ,exponent) 261 | (:mantissa ,significand) 262 | (:sign ,sign) 263 | (float-radix ,(float-radix object)) 264 | (float-precision ,(float-precision object)) 265 | ,@(when (typep object 'short-float) 266 | `((most-positive-short-float ,most-positive-short-float) 267 | (most-negative-short-float ,most-negative-short-float))) 268 | ,@(when (typep object 'single-float) 269 | `((most-positive-single-float ,most-positive-single-float) 270 | (most-negative-single-float ,most-negative-single-float))) 271 | ,@(when (typep object 'double-float) 272 | `((most-positive-double-float ,most-positive-double-float) 273 | (most-negative-double-float ,most-negative-double-float))) 274 | ,@(when (typep object 'long-float) 275 | `((most-positive-long-float ,most-positive-long-float) 276 | (most-negative-long-float ,most-negative-long-float))) 277 | (:nearest-integer ,(round object))))) 278 | 279 | (deffields (object integer) 280 | (append 281 | `((integer-length ,(integer-length object))) 282 | (when (typep object 'fixnum) 283 | `((most-positive-fixnum ,most-positive-fixnum) 284 | (most-negative-fixnum ,most-negative-fixnum))) 285 | #+sbcl 286 | (when (and (typep object '(unsigned-byte 64)) 287 | (ignore-errors (sb-kernel:%make-lisp-obj object))) 288 | `((:object ,(sb-kernel:%make-lisp-obj object)))))) 289 | 290 | (-> all-symbols ((or package symbol)) list) 291 | (defun all-symbols (package) 292 | (loop for sym being the present-symbol in package 293 | collect sym)) 294 | 295 | (-> external-symbols ((or package symbol)) list) 296 | (defun external-symbols (package) 297 | (loop for sym being the external-symbol in package 298 | collect sym)) 299 | 300 | (-> internal-symbols ((or package symbol)) list) 301 | (defun internal-symbols (package) 302 | (loop for sym being the present-symbol in package 303 | when (eql (symbol-visibility sym) :internal) 304 | collect sym)) 305 | 306 | (-> inherited-symbols ((or package symbol)) list) 307 | (defun inherited-symbols (package) 308 | (loop for sym being the present-symbol in package 309 | when (eql (symbol-visibility sym) :inherited) 310 | collect sym)) 311 | 312 | (deffields (object package) 313 | `((package-name ,(package-name object)) 314 | (documentation ,(documentation object t)) 315 | (package-nicknames ,(package-nicknames object)) 316 | (:external-symbols ,(external-symbols object)) 317 | (:internal-symbols ,(internal-symbols object)) 318 | (:inherited-symbols ,(inherited-symbols object)) 319 | (package-used-by-list ,(package-used-by-list object)) 320 | (package-use-list ,(package-use-list object)) 321 | #+(or sb-package-locks package-locks allegro) 322 | (locked #+sbcl ,(sb-ext:package-locked-p object) 323 | #+ecl ,(ext:package-locked-p object) 324 | #+allegro ,(cadadr (allegro-fields object :lock)) 325 | ,(lambda (new-value _) 326 | (declare (ignorable _)) 327 | (if new-value 328 | #+sbcl (sb-ext:lock-package object) 329 | #+ecl (ext:lock-package object) 330 | #+sbcl (sb-ext:unlock-package object) 331 | #+ecl (ext:unlock-package object)))) 332 | #+(or sb-ext clozure ext ext ext hcl excl) 333 | (:local-nicknames ,(package-local-nicknames object)) 334 | #+clozure 335 | ,@(get-ccl-props 336 | object 'ccl::pkg.itab 'ccl::pkg.etab 'ccl::pkg.shadowed 'ccl::pkg.lock 'ccl::pkg.intern-hook) 337 | #+sbcl 338 | ,@(except-sbcl-props object) 339 | #+allegro 340 | ,@(allegro-fields 341 | object :tables :mode :direct-parent :direct-children :foreign-protocol :flat))) 342 | 343 | (deffields (object readtable) 344 | `((readtable-case 345 | ,(readtable-case object) 346 | ,(lambda (new-value _) 347 | (declare (ignorable _)) 348 | (setf (readtable-case object) new-value))) 349 | ;; Adapted from https://gist.github.com/sebastiancarlos/eb8ad9061767ad8bfc1e76130a9dd4ec 350 | (:macro-characters (,@(loop for i upto 255 351 | for char = (code-char i) 352 | for fn = (get-macro-character char object) 353 | when fn 354 | collect (cons char fn)))) 355 | #+sbcl 356 | (:normalization 357 | ,(sb-ext::readtable-normalization object) 358 | ,(lambda (new-value _) 359 | (declare (ignorable _)) 360 | (setf (sb-ext::readtable-normalization object) new-value))) 361 | #+sbcl 362 | (:symbol-preference ,(sb-impl::%readtable-symbol-preference object)) 363 | #+sbcl 364 | (:string-preference ,(sb-impl::%readtable-string-preference object)) 365 | #+clozure 366 | ,@(get-ccl-props object 'ccl::rdtab.ttab 'ccl::rdtab.macros) 367 | #+sbcl 368 | ,@(except-sbcl-props object) 369 | #+allegro 370 | ,@(allegro-fields object :attr :macros :dispatch))) 371 | 372 | (deffields (object random-state) 373 | `(#+clozure 374 | ,@(get-ccl-props object 'ccl::random.mrg31k3p-state) 375 | #+sbcl 376 | ,@(except-sbcl-props object) 377 | #+allegro 378 | ,@(allegro-fields object :smplocker :mti :fixseed))) 379 | 380 | (deffields (object character) 381 | `((char-code ,(char-code object)) 382 | (char-name ,(char-name object)) 383 | (digit-char-p ,(digit-char-p object)) 384 | (alpha-char-p ,(alpha-char-p object)) 385 | (graphic-char-p ,(graphic-char-p object)) 386 | (alphanumericp ,(alphanumericp object)) 387 | (char-code-limit ,char-code-limit) 388 | ,@(when (get-macro-character object) 389 | `((:reader 390 | ,(get-macro-character object) 391 | ,(lambda (new _) 392 | (declare (ignorable _)) 393 | (set-macro-character object new))))) 394 | ,@(when (get-dispatch-macro-character #\# object) 395 | `((:sharp-reader 396 | ,(get-dispatch-macro-character #\# object) 397 | ,(lambda (new _) 398 | (declare (ignorable _)) 399 | (set-dispatch-macro-character #\# object new))))))) 400 | 401 | (deffields (object string) 402 | `((:uppercase ,(every #'upper-case-p object)) 403 | (:lowercase ,(every #'lower-case-p object)) 404 | (:graphic ,(every #'graphic-char-p object)))) 405 | 406 | (deffields (object array) 407 | `((array-dimensions 408 | ,(array-dimensions object) 409 | ,(when (adjustable-array-p object) 410 | (lambda (new-value _) 411 | (declare (ignorable _)) 412 | (adjust-array object new-value)))) 413 | (array-rank ,(array-rank object)) 414 | (array-element-type ,(array-element-type object)) 415 | (upgraded-array-element-type ,(upgraded-array-element-type (type-of object))) 416 | ,@(when (array-displacement object) 417 | (multiple-value-bind (displaced-to offset) 418 | (array-displacement object) 419 | `((:displaced-to ,displaced-to) 420 | (:offset ,offset)))) 421 | ,@(when (array-has-fill-pointer-p object) 422 | `((fill-pointer 423 | ,(fill-pointer object) 424 | (lambda (new-value _) 425 | (declare (ignorable _)) 426 | (setf (fill-pointer object) new-value))))) 427 | ,@(loop for elt across object 428 | for i from 0 429 | collect (list i elt 430 | (lambda (new-value _) 431 | (declare (ignorable _)) 432 | (setf (elt object i) new-value)))))) 433 | 434 | (deffield logical-pathname 435 | :translation translate-logical-pathname) 436 | 437 | (deffields (object pathname) 438 | (let ((logical-p (uiop:logical-pathname-p object)) 439 | (link-p (not (equal (truename object) object)))) 440 | `((wild-pathname-p ,(wild-pathname-p object)) 441 | (namestring ,(namestring object)) 442 | ,@(unless (or logical-p 443 | (string= (namestring object) 444 | (uiop:native-namestring object))) 445 | `((:native-namestring ,(uiop:native-namestring object)))) 446 | ,@(when link-p 447 | `((truename ,(truename object)))) 448 | (pathname-host ,(pathname-host object)) 449 | (pathname-device ,(pathname-device object)) 450 | (pathname-directory ,(pathname-directory object)) 451 | (pathname-name ,(pathname-name object)) 452 | (pathname-type ,(pathname-type object)) 453 | (pathname-version ,(pathname-version object)) 454 | ;; Other namestrings: host, file, enough. 455 | (directory-namestring ,(directory-namestring object)) 456 | ,@(when (uiop:file-pathname-p object) 457 | `((file-author ,(file-author object)) 458 | (file-write-date ,(file-write-date object)))) 459 | ,@(when (member (pathname-type object) 460 | '("cl" "lsp" "lisp") 461 | :test #'string-equal) 462 | `((compile-file-pathname ,(compile-file-pathname object)))) 463 | ,@(when (uiop:directory-pathname-p object) 464 | `((:files ,(uiop:directory-files object)) 465 | (:subdirectories ,(uiop:subdirectories object)))) 466 | (user-homedir-pathname ,(user-homedir-pathname)) 467 | (:cwd ,(uiop:getcwd)) 468 | #+sbcl 469 | ,@(except-sbcl-props object) 470 | #+allegro 471 | ,@(allegro-fields object :dir-namestring)))) 472 | 473 | (deffields (object hash-table) 474 | `((hash-table-test ,(hash-table-test object)) 475 | (hash-table-size ,(hash-table-size object)) 476 | (hash-table-count ,(hash-table-count object)) 477 | (hash-table-rehash-size ,(hash-table-rehash-size object)) 478 | (hash-table-rehash-threshold ,(hash-table-rehash-threshold object)) 479 | #+(or sbcl ecl clozure abcl) 480 | (:weakness 481 | #+ecl ,(si:hash-table-weakness object) 482 | #+sbcl ,(sb-impl::hash-table-weakness object) 483 | #+clozure ,(ccl:hash-table-weak-p object) 484 | #+abcl ,(system:hash-table-weakness object)) 485 | #+clozure 486 | ,@(get-ccl-props 487 | object 488 | 'ccl::nhash.keytransF 'ccl::nhash.compareF 'ccl::nhash.rehash-bits 'ccl::nhash.vector 489 | 'ccl::nhash.lock 'ccl::nhash.owner 'ccl::nhash.grow-threshold 'ccl::nhash.puthash-count 490 | 'ccl::nhash.exclusion-lock 'ccl::nhash.find 'ccl::nhash.find-new 'ccl::nhash.read-only 491 | 'ccl::nhash.min-size) 492 | #+sbcl 493 | ,@(except-sbcl-props object) 494 | ,@(loop for key being the hash-key in object 495 | using (hash-value val) 496 | when (scalar-p key) 497 | collect (list key val 498 | (lambda (new-value _) 499 | (declare (ignorable _)) 500 | (setf (gethash key object) 501 | new-value))) 502 | into inline-props 503 | else 504 | collect key into complex-props 505 | and collect val into complex-props 506 | finally (return (append inline-props 507 | (list (list 'other-pairs complex-props))))))) 508 | 509 | (deffields (object two-way-stream) 510 | `((:input ,(two-way-stream-input-stream object)) 511 | (:output ,(two-way-stream-output-stream object)))) 512 | 513 | ;; On SBCL, echo-stream is an instance of two-way-stream... 514 | (deffields (object echo-stream) 515 | `((:echo-input ,(echo-stream-input-stream object)) 516 | (:echo-output ,(echo-stream-output-stream object)))) 517 | 518 | (deffield concatenated-stream :concatenates concatenated-stream-streams) 519 | (deffield broadcast-stream :broadcasts broadcast-stream-streams) 520 | (deffield synonym-stream :synonym synonym-stream-symbol) 521 | ;; TODO: string-stream. Somehow `get-output-stream-string` without 522 | ;; clearing the stream. Maybe get the string and then re-output it to 523 | ;; the stream? 524 | 525 | (deffields (object file-stream) 526 | `((pathname ,(pathname object)) 527 | (file-position ,(file-position object)) 528 | (file-length (file-length object)) 529 | (probe-file ,(probe-file object) 530 | ,(lambda (new-value old-value) 531 | (let* ((file (pathname object)) 532 | (exists-p old-value)) 533 | (cond 534 | ((and exists-p (null new-value)) 535 | (delete-file file) 536 | (close object)) 537 | ((and new-value (not exists-p)) 538 | (open file 539 | :direction :probe 540 | :if-does-not-exist :create)))))) 541 | #+clozure 542 | ,@(get-ccl-props object 'ccl::basic-file-stream.actual-filename))) 543 | 544 | (deffields (object stream) 545 | `((:direction ,(cond 546 | ((typep object 'two-way-stream) :io) 547 | ((input-stream-p object) :input) 548 | ((output-stream-p object) :output))) 549 | (interactive-stream-p ,(interactive-stream-p object)) 550 | #+abcl 551 | ,@`((:offset ,(system::stream-offset object)) 552 | (:line-number ,(system::stream-line-number object)) 553 | (:system ,(system::system-stream-p object)) 554 | (:url ,(typep object 'system:url-stream)) 555 | (:jar ,(typep object 'system:jar-stream)) 556 | ,@(when (output-stream-p object) 557 | `((:charpos ,(system::stream-charpos object))))) 558 | (open-stream-p 559 | ,(open-stream-p object) 560 | ,(lambda (new-value old-value) 561 | (when old-value 562 | (case new-value 563 | ((nil) (close object)) 564 | (:abort (close object :abort t)))))) 565 | (stream-element-type ,(stream-element-type object)) 566 | (stream-external-format ,(stream-external-format object)) 567 | #+sbcl 568 | ,@(except-sbcl-props object))) 569 | 570 | (-> function-closure-p ((or function generic-function standard-method)) (or boolean list)) 571 | (defun function-closure-p (function) 572 | ;; TODO: ECL returns closures somehow, but the implementation is 573 | ;; terribly obscure... 574 | (let ((function (if (typep function 'standard-method) 575 | (method-generic-function function) 576 | function))) 577 | (declare (ignorable function)) 578 | #+clozure 579 | (and (typep function 'ccl:compiled-lexical-closure) 580 | ;; Convert to alist. 581 | (loop for (name value) in (ccl::closure-closed-over-values function) 582 | collect (cons name value))) 583 | #+(or cmucl scl) 584 | (and (= (kernel:get-type function) vm:closure-header-type) 585 | (loop for i below (- (kernel:get-closure-length function) 586 | #+cmucl 1 587 | #+scl (1- vm:closure-info-offset)) 588 | collect (cons i (kernel:%closure-index-ref function i)))) 589 | #+sbcl 590 | (and (sb-kernel:closurep function) 591 | ;; Is that the right one? 592 | (loop for i below (1- (sb-kernel:get-closure-length function)) 593 | collect (cons i (sb-kernel:%closure-index-ref function i)))) 594 | #+abcl 595 | (let ((environment (nth-value 1 (function-lambda-expression function)))) 596 | (cond 597 | ((and environment 598 | (typep environment 'system::environment)) 599 | (system:environment-variables environment)) 600 | (environment environment) 601 | (t nil))) 602 | #+allegro 603 | (let* ((closure (nth-value 1 (function-lambda-expression function)))) 604 | (cond 605 | ((typep closure 'sys::augmentable-environment) 606 | (let ((ht (sys::ha$h-table-ht 607 | (slot-value (sys::augmentable-environment-base closure) 608 | 'system::variable-hashtable)))) 609 | (typecase ht 610 | (cons 611 | (cons (car ht) (caadr (cadadr ht)))) 612 | (hash-table 613 | (loop for key being the hash-key in ht 614 | using (hash-value val) 615 | collect (cons key (caar (cdadar val)))))))) 616 | ;; FIXME: There should be a way to crack this one! 617 | ((typep closure 'excl::closure) 618 | t))) 619 | #+clisp 620 | ;; TODO: venv fenv benv genv denv 621 | (let ((closure (nth-value 1 (funcall old-function-lambda-expression function)))) 622 | (when (arrayp closure) 623 | (loop for (name value) 624 | on (coerce (elt closure 0) 'list) 625 | by #'cddr 626 | while name 627 | collect (cons name value)))) 628 | #-(or clozure cmucl scl sbcl abcl allegro clisp ecl) 629 | t)) 630 | 631 | ;; Generic function-specific things: method listing, method combination 632 | ;; Method-specific thing: specializers, qualifiers 633 | (deffields (object function) 634 | (multiple-value-bind (expression closure-p name) 635 | (function-lambda-expression object) 636 | `((:name ,name) 637 | (:arguments ,(trivial-arguments:arglist object)) 638 | (compiled-function-p ,(compiled-function-p object)) 639 | ,@(when (not (eq :unknown (trivial-arguments:argtypes object))) 640 | `((:ftype (function ,@(multiple-value-list (trivial-arguments:argtypes object)))))) 641 | (:closure-p ,closure-p) 642 | ,@(when closure-p 643 | `(:closed-over ,(function-closure-p object))) 644 | (:expression ,expression) 645 | #+allegro 646 | ,@(allegro-fields object :start :code :gc-info :immed-args :locals) 647 | (lambda-list-keywords ,lambda-list-keywords) 648 | (call-arguments-limit ,call-arguments-limit) 649 | (lambda-parameters-limit ,lambda-parameters-limit)))) 650 | 651 | (-> restart-interactive (restart)) 652 | (defun restart-interactive (restart) 653 | (declare (ignorable restart)) 654 | #+clozure (ccl::%restart-interactive restart) 655 | #+sbcl (sb-kernel::restart-interactive-function restart) 656 | #+ecl (si::restart-interactive-function restart) 657 | #-(or clozure sbcl ecl) nil) 658 | 659 | (deffields (object restart) 660 | `((restart-name ,(restart-name object)) 661 | (:interactive ,(restart-interactive object)) 662 | (:test 663 | #+clozure ,(ccl::%restart-test object) 664 | #+sbcl ,(sb-kernel::restart-test-function object) 665 | #+ecl ,(si::restart-test-function object) 666 | #-(or clozure sbcl ecl) nil) 667 | (:action 668 | #+clozure ,(ccl::%restart-action object) 669 | #+sbcl ,(sb-kernel::restart-function object) 670 | #+ecl ,(si::restart-function object) 671 | #-(or clozure sbcl ecl) nil) 672 | (:report 673 | #+clozure ,(ccl::%restart-report object) 674 | #+sbcl ,(sb-kernel::restart-report-function object) 675 | #+ecl ,(si::restart-report-function object) 676 | #-(or clozure sbcl ecl) nil))) 677 | 678 | (deffields (object condition) 679 | `((compute-restarts ,(compute-restarts object)) 680 | (continue ,(find 'continue (compute-restarts object) :key #'restart-name)))) 681 | 682 | (deffields (object simple-condition) 683 | `((:format-control ,(simple-condition-format-control object)) 684 | (:format-arguments ,(simple-condition-format-arguments object)))) 685 | 686 | (deffields (object arithmetic-error) 687 | `((:operation ,(arithmetic-error-operation object)) 688 | (:operands ,(arithmetic-error-operands object)))) 689 | 690 | (deffield cell-error :name cell-error-name) 691 | (deffield package-error :package package-error-package) 692 | (deffield stream-error :stream stream-error-stream) 693 | (deffield print-not-readable :object print-not-readable-object) 694 | (deffield unbound-slot :instance unbound-slot-instance) 695 | (deffield file-error :pathname file-error-pathname) 696 | 697 | (deffields (object type-error) 698 | `((:datum ,(type-error-datum object)) 699 | (:expected ,(type-error-expected-type object)))) 700 | 701 | (-> object-slots ((or standard-object structure-object)) list) 702 | (defun object-slots (object) 703 | (mapcar #'slot-definition-name 704 | (class-slots (class-of object)))) 705 | 706 | (-> inspect-slots ((or standard-object structure-object)) list) 707 | (defun inspect-slots (object) 708 | (append 709 | #+clozure 710 | (get-ccl-props 711 | object 712 | 'ccl::instance.hash 'ccl::instance.slots) 713 | (mapcar (lambda (name) 714 | (list name (if (slot-boundp object name) 715 | (slot-value object name) 716 | :unbound) 717 | (lambda (new-value _) 718 | (declare (ignorable _)) 719 | (setf (slot-value object name) new-value)))) 720 | (set-difference (object-slots object) 721 | #+sbcl sbcl-props-to-ignore 722 | #+allegro '(excl::plist excl::flags) 723 | #-(or sbcl allegro) nil)))) 724 | 725 | (deffields (object standard-object) 726 | (inspect-slots object)) 727 | 728 | (deffields (object structure-object) 729 | (inspect-slots object)) 730 | 731 | (defmethod fields reverse-append-index (object &key &allow-other-keys) 732 | (let ((slot-defs (ignore-errors (class-slots (class-of object))))) 733 | `((:self ,object) ;; Inspired by CCL. 734 | (:id ,(id object)) 735 | (class-of 736 | ,(class-of object) 737 | ,(unless (typep (class-of object) 'built-in-class) 738 | (lambda (new-value _) 739 | (declare (ignorable _)) 740 | (change-class object (find-class new-value))))) 741 | ,@(when slot-defs 742 | (list (list :slot-definitions slot-defs))) 743 | (type-of ,(type-of object)) 744 | #+clozure 745 | (:wrapper ,(ccl::%class-own-wrapper (class-of object))) 746 | #+allegro 747 | ,@(allegro-fields :lock-index :hash :type :flags :xflags :excl-type :plist)))) 748 | -------------------------------------------------------------------------------- /source/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Artyom Bologov 2 | ;;;; SPDX-License-Identifier: BSD-2 Clause 3 | 4 | (uiop:define-package :trivial-inspect 5 | (:use :common-lisp) 6 | (:export #:fields #:description) 7 | (:import-from 8 | #+sbcl #:sb-ext 9 | #+clozure #:ccl 10 | #+ecl #:ext 11 | #+abcl #:ext 12 | #+clasp #:ext 13 | #+lispworks #:hcl 14 | #+allegro #:excl 15 | #:package-local-nicknames) 16 | (:import-from 17 | #+abcl #:mop 18 | #+allegro #:mop 19 | #+clisp #:clos 20 | #+clozure #:ccl 21 | #+cmu #:clos-mop 22 | #+ecl #:clos 23 | #+clasp #:clos 24 | #+lispworks #:clos 25 | #+mcl #:ccl 26 | #+sbcl #:sb-mop 27 | #+scl #:clos 28 | #+mezzano #:mezzano.clos 29 | #+sicl #:sicl-clos 30 | #:class-slots 31 | #:slot-definition-name 32 | #:method-generic-function) 33 | (:documentation "`trivial-inspect' provides building blocks for interactive inspectors. 34 | Two main functions it exports are: 35 | - `fields' to get a list of inspect fields for an object. 36 | - `description' for a concise description of an object to stream.")) 37 | -------------------------------------------------------------------------------- /trivial-inspect.asd: -------------------------------------------------------------------------------- 1 | ;;;; SPDX-FileCopyrightText: Artyom Bologov 2 | ;;;; SPDX-License-Identifier: BSD-2 Clause 3 | 4 | (asdf:defsystem "trivial-inspect" 5 | :description "Portable toolkit for interactive inspectors." 6 | :author "Artyom Bologov" 7 | :homepage "https://github.com/aartaka/trivial-inspect" 8 | :bug-tracker "https://github.com/aartaka/trivial-inspect/issues" 9 | :source-control (:git "https://github.com/aartaka/trivial-inspect.git") 10 | :license "BSD-2 Clause" 11 | :version "0.0.0" 12 | :serial t 13 | :depends-on ("trivial-arguments") 14 | :pathname "source/" 15 | :components ((:file "package") 16 | (:file "fields") 17 | (:file "description"))) 18 | --------------------------------------------------------------------------------