debug.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
debug.lisp (5246B)
---
1 ;;;;; A few essential debugging utilities by fare@tunes.org,
2 ;;;;; to be loaded in the *PACKAGE* that you wish to debug.
3 ;;
4 ;; We want debugging utilities in the _current_ package,
5 ;; so we don't have to either change the package structure
6 ;; or use heavy package prefixes everywhere.
7 ;;
8 ;; The short names of symbols below are unlikely to clash
9 ;; with global bindings of any well-designed source file being debugged,
10 ;; yet are quite practical in a debugging session.
11 #|
12 ;;; If ASDF is already loaded,
13 ;;; you can load these utilities in the current package as follows:
14 (uiop:uiop-debug)
15 ;; which is the same as:
16 (uiop/utility:uiop-debug)
17
18 ;; The above macro can be configured to load any other debugging utility
19 ;; that you may prefer to this one, with your customizations,
20 ;; by setting the variable
21 ;; uiop/utility:*uiop-debug-utility*
22 ;; to a form that evaluates to a designator of the pathname to your file.
23 ;; For instance, on a home directory shared via NFS with different names
24 ;; on different machines, with your debug file in ~/lisp/debug-utils.lisp
25 ;; you could in your ~/.sbclrc have the following configuration setting:
26 (require :asdf)
27 (setf uiop/utility:*uiop-debug-utility*
28 '(uiop/pathname:subpathname (uiop/os:user-homedir) "lisp/debug-utils.lisp"))
29
30 ;;; If ASDF is not loaded (for instance, when debugging ASDF itself),
31 ;;; Try the below, fixing the pathname to point to this file:
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (let ((kw (read-from-string (format nil ":DBG-~A" (package-name *package*)))))
34 (unless (member kw *features*)
35 (load "/home/tunes/cl/asdf/contrib/debug.lisp"))))
36
37 |#
38
39 ;;; Here we define the magic package-dependent feature.
40 ;;; With it, you should be able to use #+DBG-/PACKAGE-NAME/
41 ;;; to annotate your debug statements, e.g. upper-case #+DBG-ASDF
42 ;;; This will be all upper-case even in lower-case lisps.
43
44 (eval-when (:compile-toplevel :load-toplevel :execute)
45 (let ((kw (read-from-string
46 (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
47 (pushnew kw *features*)))
48
49 ;;; Now for the debugging stuff itself.
50 ;;; First, my all-purpose print-debugging macro
51 (defmacro DBG (tag &rest exprs)
52 "debug macro for print-debugging:
53 TAG is typically a constant string or keyword to identify who is printing,
54 but can be an arbitrary expression returning a tag to be princ'ed first;
55 if the expression returns NIL, nothing is printed.
56 EXPRS are expressions, which when the TAG was not NIL are evaluated in order,
57 with their source code then their return values being printed each time.
58 The last expression is *always* evaluated and its multiple values are returned,
59 but its source and return values are only printed if TAG was not NIL;
60 previous expressions are not evaluated at all if TAG was NIL.
61 The macro expansion has relatively low overhead in space or time."
62 (let* ((last-expr (car (last exprs)))
63 (other-exprs (butlast exprs))
64 (tag-var (gensym "TAG"))
65 (thunk-var (gensym "THUNK")))
66 `(let ((,tag-var ,tag))
67 (flet ,(when exprs `((,thunk-var () ,last-expr)))
68 (if ,tag-var
69 (DBG-helper ,tag-var
70 (list ,@(loop :for x :in other-exprs :collect
71 `(cons ',x #'(lambda () ,x))))
72 ',last-expr ,(if exprs `#',thunk-var nil))
73 ,(if exprs `(,thunk-var) '(values)))))))
74
75 (defun DBG-helper (tag expressions-thunks last-expression last-thunk)
76 ;; Helper for the above debugging macro
77 (labels
78 ((f (stream fmt &rest args)
79 (with-standard-io-syntax
80 (let ((*print-readably* nil)
81 (*package* (find-package :cl)))
82 (apply 'format stream fmt args)
83 (finish-output stream))))
84 (z (stream)
85 (f stream "~&"))
86 (e (fmt arg)
87 (f *error-output* fmt arg))
88 (x (expression thunk)
89 (e "~& ~S => " expression)
90 (let ((results (multiple-value-list (funcall thunk))))
91 (e "~{~S~^ ~}~%" results)
92 (values-list results))))
93 (map () #'z (list *standard-output* *error-output* *trace-output*))
94 (e "~A~%" tag)
95 (loop :for (expression . thunk) :in expressions-thunks
96 :do (x expression thunk))
97 (if last-thunk
98 (x last-expression last-thunk)
99 (values))))
100
101
102 ;;; Quick definitions for use at the REPL
103 (defun w (&rest x) (format t "~&~{~S~^ ~}~%" x)) ;Write, space separated + LF
104 (defun a (&rest x) (format t "~&~{~A~}~%" x)) ;print Anything, no separator, LF
105 (defun e (x) (cons x (ignore-errors (list (eval x))))) ;Evaluate
106 (defmacro x (x) `(format t "~&~S => ~S~%" ',x ,x)) ;eXamine
107 (defun i (&rest x) (apply (read-from-string "swank:inspect-in-emacs") x)) ; SLIME inspection
108 (defun ra (&rest x) (require :cl-ppcre) (apply (read-from-string "cl-ppcre:regex-apropos") x))
109 (defmacro !a (&rest foo) ; define! Alias
110 `(progn ,@(loop :for (alias name) :on foo :by #'cddr
111 :collect (if (macro-function name)
112 `(defmacro ,alias (&rest x) `(,',name ,@x))
113 `(defun ,alias (&rest x) (apply ',name x))))))
114 (!a ;;; common aliases
115 d describe
116 ap apropos
117 !p defparameter
118 m1 macroexpand-1)