GopherProxy

	tdebug.lisp - clic - Clic is an command line interactive client for gopher writ…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tdebug.lisp (5246B)
	---
	1 ;;;;; A few essential debugging utilities by [email protected],
	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-uti…
	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 *packa…
	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 printin…
	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 o…
	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 re…
	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…
	104 (defun a (&rest x) (format t "~&~{~A~}~%" x)) ;print Anything, no separa…
	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)…
	108 (defun ra (&rest x) (require :cl-ppcre) (apply (read-from-string "cl-ppc…
	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)