├── repl-utilities.asd ├── package.lisp ├── load.lisp ├── LICENSE ├── utils.lisp ├── README.md └── repl-utilities.lisp /repl-utilities.asd: -------------------------------------------------------------------------------- 1 | ;;;; repl-utilities.asd 2 | 3 | (asdf:defsystem #:repl-utilities 4 | :serial t 5 | :description "Ease common tasks at the REPL." 6 | :license "BSD 2-clause" 7 | :author "Matt Niemeir " 8 | :components ((:file "package") 9 | (:file "utils") 10 | (:file "repl-utilities"))) 11 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage :repl-utilities 4 | (:use :cl) 5 | (:export 6 | #:dev 7 | #:*dev-hooks* 8 | #:bring 9 | #:*bring-hooks* 10 | #:print-hash 11 | #:doc 12 | #:trace-package 13 | #:deflex 14 | #:lex 15 | #:readme 16 | #:summary 17 | #:package-apropos 18 | #-(or clisp ccl) ;; causes a symbol conflict 19 | #:arglist 20 | #:de 21 | #:nic 22 | #:dependency-locations 23 | #:dbgv 24 | #:repeatably 25 | #:rig 26 | #:exs 27 | #:exfns 28 | #:exvs 29 | #:excs 30 | #:exts 31 | #:mac 32 | #:shadowed-import)) 33 | -------------------------------------------------------------------------------- /load.lisp: -------------------------------------------------------------------------------- 1 | ;;;; load.lisp 2 | 3 | ;; To load repl-utilities into an image without asdf (an atypical use 4 | ;; case), load this file. 5 | 6 | ;; If you are using asdf or quicklisp (as typical) to load 7 | ;; repl-utilities, this file will not be loaded and can be safely 8 | ;; ignored. 9 | 10 | (in-package #:cl-user) 11 | 12 | (let ((path #.(or *compile-file-truename* 13 | *load-truename* 14 | *default-pathname-defaults*))) 15 | (flet ((compile-load (file) 16 | (load (compile-file 17 | (make-pathname :name file :type "lisp" :defaults path) 18 | :print () 19 | :verbose ()) 20 | :print () 21 | :verbose ()))) 22 | (when *load-verbose* 23 | (princ "; Loading REPL-UTILITIES" *standard-output*)) 24 | (mapc #'compile-load '("package" "utils" "repl-utilities")))) 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Matt Niemeir 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | 24 | The views and conclusions contained in the software and documentation are those 25 | of the authors and should not be interpreted as representing official policies, 26 | either expressed or implied, of the FreeBSD Project. 27 | -------------------------------------------------------------------------------- /utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utils.lisp 2 | 3 | (in-package #:repl-utilities) 4 | 5 | ;;;; Readtable for this file and repl-utilities.lisp 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | ;; The resolution of symbols at run time allows repl-utilities 9 | ;; compiled without quicklisp to call quicklisp at runtime, and a 10 | ;; fasl compiled with quicklisp to be loaded into an image without 11 | ;; quicklisp. 12 | 13 | (defvar *repl-utilities-rt* (copy-readtable ()) 14 | "A readtable where [ql quickload] reads as 15 | `(find-symbol ,(symbol-name 'quickload) ,(symbol-name 'ql))") 16 | 17 | (defun run-time-symbol-reader (stream char) 18 | (declare (ignore char)) 19 | (if *read-suppress* 20 | (read-delimited-list #\] stream) 21 | (destructuring-bind (package name) (read-delimited-list #\] stream) 22 | `(find-symbol ,(symbol-name name) ,(symbol-name package))))) 23 | 24 | (set-macro-character #\[ #'run-time-symbol-reader () *repl-utilities-rt*) 25 | (set-syntax-from-char #\] #\) *repl-utilities-rt*) 26 | (setq *readtable* *repl-utilities-rt*)) 27 | 28 | ;;;; General Utilities 29 | 30 | (defun ensure-unquoted (form) 31 | "If form is quoted, remove one level of quoting. Otherwise return form. 32 | This is a useful for defining convenience for macros which may be passed a 33 | quoted or unquoted symbol." 34 | (if (and (listp form) (eq (car form) 'cl:quote)) 35 | (second form) 36 | form)) 37 | 38 | (defmacro with-gensyms ((&rest names) &body body) 39 | `(let ,(loop for n in names collect 40 | ;; (SYMBOL-NAME #:SYMBOL-NAME-2983) 41 | `(,n (gensym ,(concatenate 'string (symbol-name n) "-")))) 42 | ,@body)) 43 | 44 | (defmacro first-form (&rest forms) 45 | "Return the first form; useful when you want one of multiple possible 46 | conditionally read forms." 47 | (first forms)) 48 | 49 | (defun string-sort (list) 50 | (sort (copy-list list) #'string<)) 51 | 52 | (defun first-line (string) 53 | (flet ((min-or-nil (&rest args) 54 | (let ((numbers (remove-if-not #'numberp args))) 55 | (if numbers (apply 'min numbers) nil)))) 56 | (subseq string 0 (min-or-nil (position #\ string) 57 | (position #\Newline string))))) 58 | 59 | (defun shadowed-import (symbols 60 | &optional (package *package*) (print-when-shadowed-p t)) 61 | "Import each symbol into PACKAGE, unless a symbol of the same name is present. 62 | If print-when-shadowed-p is true, print a message for each not-imported 63 | symbol indicating that it was not imported." 64 | (dolist (sym (if (consp symbols) symbols (list symbols)) t) 65 | (let ((found (find-symbol (symbol-name sym) package))) 66 | (if (not found) 67 | (import sym package) 68 | (when (and print-when-shadowed-p 69 | (not (eq found sym))) 70 | (format t "~&Left behind ~S to avoid symbol conflict.~%" sym)))))) 71 | 72 | (defun load-system-or-print (system-designator &optional control-string 73 | &rest format-args) 74 | (unless (find-package "ASDF") 75 | (return-from load-system-or-print 76 | (format t "I don't know how to load a system without asdf. ~ 77 | Attempting package manipulation anyway."))) 78 | (let ((quicklispp (find-package "QUICKLISP"))) 79 | (handler-bind ((error 80 | (lambda (c) 81 | (cond ((and quicklispp 82 | (typep c [quicklisp-client system-not-found])) 83 | (when (string-equal 84 | (funcall [ql system-not-found-name] c) 85 | system-designator) 86 | (return-from load-system-or-print 87 | (when control-string 88 | (apply #'format t control-string 89 | format-args))))) 90 | ((typep c `(and ,[asdf missing-component] 91 | (not ,[asdf missing-dependency]))) 92 | (return-from load-system-or-print 93 | (when control-string 94 | (apply #'format t control-string 95 | format-args)))))))) 96 | (if quicklispp 97 | (funcall [ql quickload] 98 | system-designator) 99 | (funcall [asdf load-system] system-designator))))) 100 | 101 | (defparameter *documentation-types* 102 | '(function setf type variable compiler-macro ;structure 103 | #-clisp method-combination) 104 | "Types that might work with (documentation obj type)") 105 | 106 | (defun specialp (x) 107 | (or (boundp x) 108 | (eval `(let (,x) 109 | (declare (ignorable ,x)) 110 | (boundp ',x))))) 111 | 112 | (defgeneric exists-as (symbol type) 113 | (:method ((symbol t) (type (eql 't))) 114 | t) 115 | (:method (symbol (type (eql 'function))) 116 | (fboundp symbol)) 117 | (:method (symbol (type (eql 'setf))) 118 | (handler-case (fdefinition (list 'setf symbol)) 119 | (undefined-function () ()))) 120 | (:method (symbol (type (eql 'type))) 121 | (type-specifier-p symbol)) 122 | (:method (symbol (type (eql 'class))) 123 | (find-class symbol nil)) 124 | (:method (symbol (type (eql 'variable))) 125 | (specialp symbol)) 126 | (:method (symbol (type (eql 'compiler-macro))) 127 | (compiler-macro-function symbol)) 128 | (:method ((symbol t) (type (eql 'method-combination))) 129 | ;; fixme 130 | ())) 131 | 132 | (defun print-asdf-description (package) 133 | (let ((description (ignore-errors 134 | (funcall [asdf system-description] 135 | (funcall [asdf find-system] 136 | (string-downcase (package-name 137 | package))))))) 138 | (when description 139 | (format t "~&~A > ASDF System~% ~<~A~%~%~>" 140 | (package-name package) description)))) 141 | 142 | (defun split-by (test sequence) 143 | (let (pass fail) 144 | (dolist (elt sequence (values (nreverse pass) 145 | (nreverse fail))) 146 | (if (funcall test elt) 147 | (push elt pass) 148 | (push elt fail))))) 149 | 150 | ;;;; Portability 151 | 152 | (define-condition unsupported () ()) 153 | 154 | (defun type-specifier-p (symbol) 155 | (let ((fn (cond ((find-package "SB-EXT") 156 | [sb-ext valid-type-specifier-p]) 157 | ((find-package "CCL") 158 | [ccl type-specifier-p])))) 159 | (if fn 160 | (funcall fn symbol) 161 | (signal 'unsupported)))) 162 | 163 | (defun require-once (string) 164 | (let ((tried (load-time-value 165 | (make-hash-table :test #'equal :size 8)))) 166 | (or (find-package string) 167 | (unless (gethash string tried) 168 | (setf (gethash string tried) t) 169 | (ignore-errors (require string)) 170 | (find-package string))))) 171 | 172 | (defun arglist (fname) 173 | "Return the arglist for the given function name. 174 | Implementations taken from slime." 175 | (first-form 176 | #+sbcl (if (require-once "SB-INTROSPECT") 177 | (funcall [sb-introspect function-lambda-list] fname) 178 | :failed-to-load-sb-introspect) 179 | #+ccl (multiple-value-bind (arglist binding) 180 | (let ((*break-on-signals* nil)) 181 | (ccl:arglist fname)) 182 | (declare (ignore binding)) 183 | arglist) 184 | #+clisp (block nil 185 | (or (ignore-errors 186 | (let ((exp (function-lambda-expression fname))) 187 | (and exp (return (second exp))))) 188 | (ignore-errors 189 | (return (ext:arglist fname))) 190 | :not-available)) 191 | :arglist-nonportable-patches-welcome)) 192 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | REPL-UTILITIES 2 | ============== 3 | 4 | A set of utilities which ease life at the repl. 5 | 6 | REPL-UTILITIES is tested on SBCL, CCL and CLISP, and further porting should be 7 | easy. 8 | 9 | The Big Ideas 10 | ------------- 11 | 12 | REPL-UTILITIES includes three sorts of features: __introspective__ procedures, 13 | __miscellaneous utility__ functions, and, __pulling them together__, methods to 14 | conveniently keep these symbols and optionally additional symbols available 15 | in whichever package you switch to. 16 | 17 | For best effect load this package and use-package it from your lisp's init file. 18 | 19 | If you wish to in-package another package at the repl in the course of 20 | developing it, you can retain access to these REPL-UTILITIES by using DEV 21 | to load and swap to the new package. DEV will import the REPL-UTILITIES 22 | symbols into the new package, if they won't cause name conflicts. 23 | 24 | DEV also maps funcall over \*DEV-HOOKS\* after changing the package. \*DEV-HOOKS\* 25 | is an empty list. I personally add hooks which import (via 26 | REPL-UTILITIES:SHADOWED-IMPORT) several functions from other packages which 27 | I always want available at the REPL, and to change the 28 | \*DEFAULT-PATHNAME-DEFAULTS\* and emacs default-directory to match the source 29 | location of the package just loaded. 30 | 31 | My favorite operator in here is DEFLEX, taken from Rob Warnock and aliased 32 | to LEX. It defines a global lexical variable -- this lets you use temporary 33 | test variables without earmuffs safely: 34 | 35 | (defvar *x* (list 1 2 3)) 36 | (mapcar #'print *x*) ; painful 37 | 38 | (lex x (list 1 2 3)) 39 | (mapcar #'print x) ; better 40 | 41 | Following the lead of CL:IN-PACKAGE, the package changing, loading, 42 | and renaming operators (BRING, DEV, and NIC) expand into an EVAL-WHEN so 43 | that they can take effect before later forms are read. 44 | 45 | The symbol and package introspection operators have been defined as macros 46 | to allow their arguments to be unquoted symbols. For convenience they 47 | automatically unquote quoted arguments. 48 | 49 | Features 50 | ======== 51 | 52 | The following is lightly edited output of 53 | 54 | (repl-utilities:summary repl-utilities) 55 | 56 | Introspective Procedures 57 | ------------------------ 58 | 59 | README: Print the documentation on the exported symbols of a package. 60 | SUMMARY: Print the exported symbols along with the first line of their docstrings. 61 | PACKAGE-APROPOS: Print all package names and nicknames which contain the given string. 62 | DOC: Print any documentation for the symbol. 63 | DEPENDENCY-LOCATIONS: Print the pathname of the system and of the systems needed to load it. 64 | EXFNS: Print the external fboundp symbols of a package. 65 | EXVS: Print the external globally special symbols of a package. 66 | EXCS: Print the external symbols for which find-class is truthy. 67 | EXTS: Print the external symbols which are type specifiers. 68 | EXS: Print the external symbols of package. 69 | NIC: Add an additional nickname to package. 70 | ARGLIST: Return the arglist for the given function name. 71 | DE: Shortening of describe. A Rob Warnock function. 72 | 73 | Miscellaneous Utilities 74 | ----------------------- 75 | 76 | TRACE-PACKAGE: Trace all of the symbols in *package*. 77 | DEFLEX: Define a top level (global) lexical VAR with initial value VAL, 78 | LEX: Shortening of deflex: define a global lexical variable. 79 | PRINT-HASH: Print the hash table as: Key, Value~% 80 | MAC: Bind *gensym-counter* to 0, Macroexpand-1 the form, pprint result. 81 | DBGV: Print WHERE, execute FORMS, and print each form and its result to the STREAM. 82 | RIG: Execute body with profiling and timing. 83 | REPEATABLY: Use the same random state seed for every execution. 84 | 85 | Pulling It Together 86 | ------------------- 87 | 88 | DEV: Load package and IN-PACKAGE it. SHADOWED-IMPORT REPL-UTILITIES exported symbols. 89 | *DEV-HOOKS*: List of functions to be funcalled after a package is loaded with DEV. 90 | BRING: Load package and import its exported symbols. 91 | *BRING-HOOKS*: List of functions to be funcalled after a package is loaded with BRING. 92 | SHADOWED-IMPORT: Import each symbol into PACKAGE, unless a symbol of the same name is present. 93 | 94 | To view full docstrings and argument lists type: 95 | 96 | (repl-utilities:readme repl-utilities) 97 | 98 | in your repl, or view the 99 | [api reference on quickdocs](http://quickdocs.org/repl-utilities/api). 100 | 101 | Examples of \*dev-hooks\* 102 | ======================= 103 | 104 | One of my primary motivations for introducting \*dev-hooks\* was to 105 | automate importing symbols that I always want available at the 106 | repl. For example, if you want to keep my much-todo library at hand, 107 | you can (from a context where it is already loaded) do the following: 108 | 109 | (defun todo-imports () 110 | (repl-utilities:shadowed-import 111 | (loop for s being the external-symbols of :much-todo 112 | collect s))) 113 | 114 | (pushnew 'todo-imports *dev-hooks*) 115 | 116 | The use of 'todo-imports instead of #'todo-imports is significant 117 | for appropriate behavior when todo-imports is redefined. 118 | 119 | This illustrates a reason I prefer importing to binding personal 120 | functions to keywords even though importing leaves the possibility of 121 | symbol conflicts: it encourages me to write code in a form that is 122 | suitable for sharing as an ASDF system. 123 | 124 | One hook I am quite fond of tries to sync the 125 | \*default-pathname-defaults\* and emacs default-directory with the 126 | package I am switching into. 127 | 128 | (defun d-p-d-package (&optional (package *package*)) 129 | "If the package's name is a homonym for an asdf system, change the *d-p-d* to its 130 | location on disk and, if (setq slime-enable-evaluate-in-emacs t) 131 | in emacs, set the slime repl's pathname default as well." 132 | ;; slime-enable-evaluate-in-emacs warns that it can be a security risk 133 | (let ((pathloc (ignore-errors (funcall (find-symbol "COMPONENT-PATHNAME" "ASDF") 134 | (funcall (find-symbol "FIND-SYSTEM" "ASDF") 135 | (intern (package-name package) 136 | :keyword)))))) 137 | (cond (pathloc 138 | (setq *default-pathname-defaults* pathloc) 139 | (when (find-package "SWANK") 140 | (funcall (find-symbol "EVAL-IN-EMACS" "SWANK") 141 | `(with-current-buffer (slime-output-buffer) 142 | (setq default-directory 143 | ,(namestring *default-pathname-defaults*))) 144 | :nowait))) 145 | (t (format t "~& Couldn't find a source location for ~A~%" 146 | package))))) 147 | 148 | (pushnew 'd-p-d-package *dev-hooks*) 149 | 150 | Installation 151 | ============ 152 | 153 | The most straightforward way to use REPL-UTILITIES, assuming you are 154 | using quicklisp, is to place the following in your lisp's init file 155 | after the quicklisp loading forms. 156 | 157 | (funcall (find-symbol (symbol-name '#:quickload) (symbol-name '#:ql)) 158 | '#:repl-utilities) 159 | (use-package '#:repl-utilities) 160 | 161 | Or, in a running image, you can simply QL:QUICKLOAD it. 162 | 163 | To load REPL-UTILITIES in an image without ASDF (an atypical use 164 | case), you can load it with the following: 165 | 166 | (load "/path/to/repl-utilities/load") 167 | (use-package '#:repl-utilities) 168 | 169 | The REPL-UTILITIES features relating to systems wrap ASDF and 170 | QUICKLISP functionality. When ASDF is unavailable they print a message 171 | indicating the limitation. 172 | -------------------------------------------------------------------------------- /repl-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;;; repl-utilities.lisp 2 | 3 | ;;; Main implementation of the repl utilities. 4 | 5 | ;;; Convention: FOO% function does the implementation work of the FOO 6 | ;;; macro. 7 | 8 | (in-package #:repl-utilities) 9 | 10 | (eval-when (:compile-toplevel :load-toplevel :execute) 11 | (setq *readtable* *repl-utilities-rt*)) 12 | 13 | ;;;; Package Utilities 14 | 15 | (defvar *dev-hooks* () 16 | "List of functions to be funcalled after a package is loaded with DEV. 17 | 18 | During execution of these functions *PACKAGE* is already set to the package 19 | being loaded, and the repl-utilities symbols which will be imported already 20 | are. The functions are called with no arguments.") 21 | 22 | (defmacro dev (package) 23 | "Attempt to ql:quickload or asfd:load-system a system with the same name as 24 | package, then swap to the package regardless of whether the load was 25 | successful. Import repl-utilities exported symbols that don't cause symbol 26 | conflicts into the newly swapped to package. 27 | Mnemonic for develop. 28 | 29 | After swapping to the package map funcall over *dev-hooks*. 30 | 31 | Expands to an EVAL-WHEN :compile-toplevel :load-toplevel :execute" 32 | `(eval-when (:compile-toplevel :load-toplevel :execute) 33 | (dev% ',(ensure-unquoted package)))) 34 | 35 | (defun dev% (package) 36 | (load-system-or-print 37 | package "~&Could not find system, attempting to in-package anyway.~%") 38 | (restart-case (progn (setq *package* (or (find-package package) 39 | (find-package (string-upcase 40 | (string package))) 41 | (error "No package named ~A found." 42 | package))) 43 | (do-external-symbols (sym (find-package 'repl-utilities)) 44 | (shadowed-import sym *package* t)) 45 | (map nil #'funcall *dev-hooks*)) 46 | (specify-other-package () 47 | :report "Specify an alternate package name: " 48 | (dev% (ensure-unquoted (read)))))) 49 | 50 | (defvar *bring-hooks* () 51 | "List of functions to be funcalled after a package is loaded with BRING. 52 | 53 | The functions are called with the package imported by bring as their only 54 | argument.") 55 | 56 | (defmacro bring (package &optional (shadowing-import-p nil)) 57 | "Attempt to ql:quickload or asdf:load-system a system with the same name as 58 | package. Regardless of whether the load was successful import the package's 59 | exported symbols into the current package. If shadowing-import is nil, only 60 | the symbols which won't cause a symbol conflict are imported. 61 | 62 | After importing the package funcall each element of *bring-hooks* with the 63 | designated package as its argument. 64 | 65 | Expands to an EVAL-WHEN :compile-toplevel :load-toplevel :execute" 66 | `(eval-when (:compile-toplevel :load-toplevel :execute) 67 | (bring% ',(ensure-unquoted package) ,shadowing-import-p))) 68 | 69 | (defun bring% (package-designator shadowing-import-p) 70 | (load-system-or-print 71 | package-designator 72 | "~&System not found, attempting to import symbols from ~ 73 | package ~A if it exists.~%" package-designator) 74 | (restart-case 75 | (progn (setq package-designator (or (find-package package-designator) 76 | (find-package (string-upcase 77 | (string package-designator))) 78 | (error "No package named ~A found." 79 | package-designator))) 80 | (do-external-symbols (sym package-designator) 81 | (if shadowing-import-p 82 | (shadowing-import sym) 83 | (shadowed-import sym *package* t))) 84 | (map nil (lambda (fn) (funcall fn package-designator)) *bring-hooks*) 85 | package-designator) 86 | (specify-other-package () 87 | :report "Specify an alternate package name: " 88 | (bring% (ensure-unquoted (read)) shadowing-import-p)))) 89 | 90 | (defmacro readme (&optional (package *package*)) 91 | "Print the documentation on the exported symbols of a package." 92 | `(readme% ',(ensure-unquoted package))) 93 | 94 | (defun readme% (&optional (package *package*)) 95 | (let (undocumented-symbols 96 | documented-symbols) 97 | (terpri) 98 | (when (documentation (find-package package) t) 99 | (format t "~&~A > Package~% ~<~A~%~%~>" 100 | package 101 | (documentation (find-package package) t))) 102 | (print-asdf-description package) 103 | (do-external-symbols (sym package) 104 | (if (some (lambda (doctype) (documentation sym doctype)) 105 | *documentation-types*) 106 | (push sym documented-symbols) 107 | (push sym undocumented-symbols))) 108 | (when undocumented-symbols 109 | (format t "~&Undocumented exported symbols:~%~% ~{~A ~}~%~%~ 110 | Documented exported symbols:~%~%" 111 | (string-sort undocumented-symbols))) 112 | (dolist (sym (string-sort documented-symbols)) 113 | (doc% sym)))) 114 | 115 | (defmacro summary (&optional (package *package*)) 116 | "Print the exported symbols along with the first line of their docstrings." 117 | `(summary% ',(ensure-unquoted package))) 118 | 119 | (defun summary% (&optional (package-designator *package*)) 120 | (let ((buckets (mapcar #'list *documentation-types*)) 121 | (unlocated-symbols ())) 122 | (do-external-symbols (symbol package-designator) 123 | (push symbol unlocated-symbols) 124 | (dolist (type (mapcar #'car buckets)) 125 | (when (or (documentation symbol type) 126 | (exists-as symbol type)) 127 | (push symbol (cdr (assoc type buckets))) 128 | (setq unlocated-symbols (remove symbol unlocated-symbols))))) 129 | (when unlocated-symbols 130 | (format t "~&Uncategorized Symbols: ~@ 131 | ~@< ~@;~{~A~^, ~}~:@>~%" (string-sort 132 | unlocated-symbols))) 133 | (map nil (lambda (bucket) 134 | (destructuring-bind (type . symbols) bucket 135 | (multiple-value-bind (documented undocumented) 136 | (split-by (lambda (s) (documentation s type)) 137 | (string-sort symbols)) 138 | (format t "~&") 139 | (when symbols (format t "~%~:(~A~)s" type)) 140 | (when documented 141 | (mapc (lambda (symbol) 142 | (when (documentation symbol type) 143 | (format t "~&~A:~20,5t~a~%" 144 | symbol (first-line 145 | (documentation symbol type))))) 146 | documented)) 147 | (when (and documented undocumented) 148 | (format t "~:(~A~)s without docstrings:" type)) 149 | (when undocumented 150 | (format t "~& ~@<~{~A~^, ~}~:@>~%" 151 | undocumented))))) 152 | buckets))) 153 | 154 | (defmacro define-external-symbol-printers (&body name-type-docs) 155 | (flet ((symbol-printer-definition (name type doc) 156 | `(defmacro ,name (&optional (package-name *package*)) 157 | ,doc 158 | `(print-symbols `,',(ensure-unquoted package-name) 159 | ',',type)))) 160 | `(progn ,@(loop for (name type doc) on name-type-docs by #'cdddr 161 | collect (symbol-printer-definition name type doc))))) 162 | 163 | (define-external-symbol-printers 164 | 165 | exs t 166 | "Print the external symbols of package." 167 | 168 | exfns function 169 | "Print the external fboundp symbols of a package." 170 | 171 | exvs variable 172 | "Print the external globally special symbols of a package." 173 | 174 | excs class 175 | "Print the external symbols for which find-class is truthy." 176 | 177 | exts type 178 | "Print the external symbols which are type specifiers.") 179 | 180 | (defun print-symbols (package-designator type) 181 | (handler-case (let (symbols) 182 | (do-external-symbols (symbol package-designator) 183 | (when (exists-as symbol type) 184 | (push symbol symbols))) 185 | (format t "~@<~{~A~^, ~}~:@>~%" (string-sort symbols)) 186 | (values)) 187 | (unsupported () 188 | (multiple-value-prog1 (values) 189 | (princ "EXTS is not supported here."))))) 190 | 191 | (defmacro trace-package (&optional (package *package*) (inheritedp nil)) 192 | "Trace all of the symbols in *package*. 193 | 194 | This won't attempt to trace any symbols in :cl" 195 | `(trace-package% ',(ensure-unquoted package) ,inheritedp)) 196 | 197 | (defun trace-package% (&optional (package *package*) (inheritedp nil)) 198 | (#+clisp flet 199 | #+clisp ((symbol-prefix-p (prefix symbol) 200 | (let ((name (symbol-name symbol))) 201 | (when (<= (length prefix) (length name)) 202 | (every #'char-equal prefix name))))) 203 | ;; We use the reader instead of an ignore declaration to keep sbcl's 204 | ;; compiler quiet. 205 | #-clisp progn 206 | (let ((pac (find-package package))) 207 | (loop for sym being the symbols in pac 208 | when (unless (or (eq (symbol-package sym) 209 | (load-time-value (find-package '#:cl))) 210 | (not (fboundp sym)) 211 | ;; clisp's tracer creates symbols 212 | ;; named TRACED-{function}. We don't want 213 | ;; to trace these trace functions. 214 | #+clisp (symbol-prefix-p "TRACED-" sym)) 215 | (if inheritedp 216 | t 217 | (eq pac (symbol-package sym)))) 218 | do (ignore-errors (eval `(trace ,sym))))))) 219 | 220 | (defmacro nic (package-name nick-symbol) 221 | "Add an additional nickname to package. 222 | Expands to an EVAL-WHEN :compile-toplevel :load-toplevel :execute" 223 | (with-gensyms (old-nicknames) 224 | `(eval-when (:compile-toplevel :load-toplevel :execute) 225 | (let ((,old-nicknames (package-nicknames 226 | ',(ensure-unquoted package-name)))) 227 | (if (and (find-package ',(ensure-unquoted nick-symbol)) 228 | (not (eq (find-package ',(ensure-unquoted nick-symbol)) 229 | (find-package ',(ensure-unquoted package-name))))) 230 | (format t "Not adding that nick because it belongs to ~A~%" 231 | (find-package ',(ensure-unquoted nick-symbol))) 232 | (rename-package ',(ensure-unquoted package-name) 233 | ',(ensure-unquoted package-name) 234 | (cons ',(ensure-unquoted nick-symbol) 235 | ,old-nicknames))))))) 236 | 237 | (defmacro package-apropos (string-designator) 238 | "Print all package names and nicknames which contain the given string." 239 | `(package-apropos% ',(ensure-unquoted string-designator))) 240 | 241 | (defun package-apropos% (string-designator) 242 | (let ((string (string string-designator)) 243 | nicknamep) 244 | (dolist (p (list-all-packages) (values)) 245 | (setq nicknamep nil) 246 | (dolist (name (cons (package-name p) 247 | (package-nicknames p))) 248 | (when (search string name :test #'char-equal) 249 | (format t "~&~A~30,5t~@[(Nickname of ~A)~]~&" name nicknamep)) 250 | (unless nicknamep (setq nicknamep name)))))) 251 | 252 | ;;;; Symbol Utilities 253 | 254 | (defmacro deflex (var val &optional (doc nil docp)) 255 | "Define a top level (global) lexical VAR with initial value VAL, 256 | which is assigned unconditionally as with DEFPARAMETER. If a DOC 257 | string is provided, it is attached to both the name |VAR| and the 258 | name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of 259 | kind 'VARIABLE. The new VAR will have lexical scope and thus may be 260 | shadowed by LET bindings without affecting its dynamic (global) value." 261 | (let* ((s0 (symbol-name '#:*storage-for-deflex-var-)) 262 | (s1 (symbol-name var)) 263 | (s2 (symbol-name '#:*)) 264 | (s3 (symbol-package var)) ; BUGFIX [see above] 265 | (backing-var (intern (concatenate 'string s0 s1 s2) s3))) 266 | ;; Note: The DEFINE-SYMBOL-MACRO must be the last thing we do so 267 | ;; that the value of the form is the symbol VAR. 268 | (if docp 269 | `(progn 270 | (defparameter ,backing-var ,val ,doc) 271 | (setf (documentation ',var 'variable) ,doc) 272 | (define-symbol-macro ,var ,backing-var)) 273 | `(progn 274 | (defparameter ,backing-var ,val) 275 | (define-symbol-macro ,var ,backing-var)))) 276 | ;;; DEFLEX is 277 | ;;; Copyright (c) 2003-2007, 2011 Rob Warnock . 278 | ;;; All Rights Reserved. 279 | ;;; 280 | ;;; Permission to use, copy, modify, and/or distribute this software for any 281 | ;;; purpose with or without fee is hereby granted, provided that the above 282 | ;;; copyright notice and this permission notice appear in all copies. 283 | ;;; 284 | ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 285 | ;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 286 | ;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 287 | ;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 288 | ;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 289 | ;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 290 | ;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 291 | ) 292 | 293 | (defmacro lex (&rest args) 294 | "Shortening of deflex: define a global lexical variable." 295 | `(deflex ,@args)) 296 | 297 | (defun de (&rest rest) 298 | "Shortening of describe. A Rob Warnock function." 299 | (apply #'describe rest)) 300 | 301 | (defmacro doc (symbol &rest ignored-arguments) 302 | "Print any documentation for the symbol. 303 | Includes variable, function, type, compiler macro, method 304 | combination, and setf documentation." 305 | (declare (ignore ignored-arguments)) 306 | `(doc% ',(ensure-unquoted symbol))) 307 | 308 | (defun doc% (symbol) 309 | (do () 310 | ((not (consp symbol))) 311 | (setq symbol (car symbol))) 312 | (let ((*print-case* :downcase)) 313 | (dolist (type *documentation-types*) 314 | (when (documentation symbol type) 315 | (if (member type '(compiler-macro function setf 316 | #-clisp method-combination)) 317 | (format t "~&(~:@(~A~)~@[~{ ~A~}~]) > ~A~% ~<~A~%~%~>" 318 | symbol 319 | (when #1=(arglist symbol) 320 | (if (consp #1#) #1# (list #1#))) 321 | (if (macro-function symbol) 322 | 'macro 323 | type) 324 | (documentation symbol type)) 325 | (format t "~&~A > ~A~% ~<~A~%~%~>" 326 | symbol 327 | type 328 | (documentation symbol type))))))) 329 | 330 | ;;;; Miscellaneous 331 | 332 | (defmacro dbgv ((&optional (where "DEBUG") 333 | (stream '*standard-output*)) 334 | &body forms) 335 | "Print WHERE, execute FORMS, and print each form and its result to the STREAM." 336 | ;; Alteration of Maciej Katafiasz's alteration of a Rob Warnock utility 337 | ;; See http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/df43ce7017c3f101/fda9d18d8196c41b 338 | (with-gensyms (result) 339 | `(let (,result) 340 | (progn 341 | (format ,stream "~&DBGV at: ~a:~%" ,where) 342 | ,@(loop for form in forms 343 | collect `(progn 344 | (setf ,result (multiple-value-list ,form)) 345 | (format ,stream "~&~s = ~{~s~^, ~}~%" ',form ,result))) 346 | (values-list ,result))))) 347 | 348 | (defmacro rig (&body body) 349 | "Execute body with profiling and timing. 350 | Arrange for profiling information to print before IO or timing data. 351 | Profiling is only available in SBCL and with SB-SPROF available. RIG 352 | attempts to load SB-SPROF." 353 | (with-gensyms (ans standard-str s trace-str r sprofp) 354 | `(let ((,sprofp #+sbcl (require-once "SB-SPROF") #-sbcl ()) 355 | (,standard-str (make-array 1000 :element-type 'character 356 | :adjustable t 357 | :fill-pointer 0)) 358 | (,trace-str (make-array 1000 :element-type 'character 359 | :adjustable t 360 | :fill-pointer 0)) 361 | ,ans) 362 | (when ,sprofp 363 | (funcall [sb-sprof reset]) 364 | (funcall [sb-sprof start-profiling])) 365 | (with-output-to-string (,s ,standard-str) 366 | (with-output-to-string (,r ,trace-str) 367 | (let ((*standard-output* ,s) 368 | ;; necessary to catch time's output 369 | (*trace-output* ,r)) 370 | (setq ,ans (multiple-value-list (time (progn ,@body))))))) 371 | (when ,sprofp 372 | (funcall [sb-sprof report] :type :flat :max 30)) 373 | (princ ,trace-str) 374 | (princ ,standard-str) 375 | (apply #'values ,ans)))) 376 | 377 | (defmacro repeatably (&body body) 378 | "Use the same random state seed for every execution. 379 | Random state seed is changed when call-repeatably is reloaded." 380 | `(call-repeatably (lambda () ,@body))) 381 | 382 | (defun call-repeatably (thunk) 383 | (let ((*random-state* (make-random-state 384 | (load-time-value (make-random-state t) t)))) 385 | (funcall thunk))) 386 | (unless (compiled-function-p #'call-repeatably) 387 | (compile 'call-repeatably)) 388 | 389 | (defun print-hash (hash-table) 390 | "Print the hash table as: Key, Value~% " 391 | (loop for k being the hash-keys in hash-table 392 | do (format t "~A, ~A~%" k (gethash k hash-table)))) 393 | 394 | (defun dependency-locations (system-name &optional 395 | print-system-names-p 396 | (operation ())) 397 | "Print the pathname of the system and of the systems needed to load it." 398 | (unless (find-package "ASDF") (return-from dependency-locations 399 | (format t "I don't know how to find ~ 400 | dependencies without asdf."))) 401 | (when operation 402 | (warn "The operation argument to dependency-locations ~ 403 | is not longer supported.")) 404 | (let (printed-systems) 405 | (labels ((rec (sys) 406 | (setq sys (funcall [asdf find-system] (dependency-name sys))) 407 | (unless (member sys printed-systems) 408 | (push sys printed-systems) 409 | (format t "~&~S" (funcall [asdf component-pathname] sys)) 410 | (when print-system-names-p 411 | (format t ", ~A~&" (funcall [asdf component-name] sys))) 412 | (dolist (sysname (funcall 413 | (or [asdf system-depends-on] 414 | [asdf component-load-dependencies]) 415 | sys)) 416 | (rec sysname)))) 417 | (dependency-name (dependency-def) 418 | (if (consp dependency-def) 419 | (ccase (first dependency-def) 420 | ((:version :require) (second dependency-def)) 421 | (:feature (dependency-name (third dependency-def)))) 422 | dependency-def))) 423 | (rec system-name)))) 424 | 425 | (defmacro mac (expr) 426 | "Bind *gensym-counter* to 0, Macroexpand-1 the form, pprint result. 427 | 428 | If expression starts with a quotation, unquotes it first." 429 | ;; From On Lisp, modified to bind *gensym-counter* and use ensure-unquoted 430 | `(let ((*gensym-counter* 0) ; would setq be preferable? 431 | (*print-case* :downcase)) 432 | (pprint (macroexpand-1 ',(ensure-unquoted expr))))) 433 | --------------------------------------------------------------------------------