0.7.5.15:
[sbcl.git] / src / code / show.lisp
1 ;;;; some stuff for displaying information for debugging/experimenting
2 ;;;; with the system, mostly conditionalized with #!+SB-SHOW
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!INT")
14 \f
15 ;;;; various SB-SHOW-dependent forms
16 ;;;;
17 ;;;; In general, macros named /FOO
18 ;;;;   * are for debugging/tracing
19 ;;;;   * expand into nothing unless :SB-SHOW is in the target
20 ;;;;     features list
21 ;;;; Often, they also do nothing at runtime if */SHOW* is NIL, but
22 ;;;; this is not always true for some very-low-level ones.
23 ;;;;
24 ;;;; (I follow the "/FOO for debugging/tracing expressions" naming
25 ;;;; rule and several other naming conventions in all my Lisp
26 ;;;; programming when possible, and then set Emacs to display comments
27 ;;;; in one shade of blue, tracing expressions in another shade of
28 ;;;; blue, and declarations and assertions in a yellowish shade, so
29 ;;;; that it's easy to separate them from the "real code" which
30 ;;;; actually does the work of the program. -- WHN 2001-05-07)
31
32 ;;; Set this to NIL to suppress output from /SHOW-related forms.
33 #!+sb-show (defvar */show* t)
34
35 (defun cannot-/show (string)
36   #+sb-xc-host (error "can't /SHOW: ~A" string)
37   ;; We end up in this situation when we execute /SHOW too early in
38   ;; cold init. That happens to me often enough that it's really
39   ;; annoying for it to cause a hard failure -- which at that point is
40   ;; hard to recover from -- instead of just diagnostic output.
41   #-sb-xc-host (sb!sys:%primitive
42                 print
43                 (concatenate 'string "/can't /SHOW: " string))
44   (values))
45
46 ;;; Should /SHOW output be suppressed at this point?
47 ;;;
48 ;;; Note that despite the connoting-no-side-effects-pure-predicate
49 ;;; name, we emit some error output if we're called at a point where
50 ;;; /SHOW is inherently invalid.
51 #!+sb-show
52 (defun suppress-/show-p ()
53   (cond (;; protection against /SHOW too early in cold init for
54          ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously
55          ;; we need *TRACE-OUTPUT* bound.
56          (not (boundp '*trace-output*))
57          (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)")
58          t)
59         (;; protection against /SHOW too early in cold init for
60          ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso
61          ;; display of name mnemonicity, *READTABLE* is used by the
62          ;; printer to decide which case convention to use when
63          ;; writing symbols, so we need it bound.
64          (not (boundp '*readtable*))
65          (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)")
66          t)
67         (;; more protection against /SHOW too early in cold init, part III
68          (not (boundp '*/show*))
69          (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)")
70          t)
71         (;; ordinary, healthy reason to suppress /SHOW, no error
72          ;; output needed
73          (not */show*)
74          t)
75         (t
76          ;; Let the /SHOW go on.
77          nil)))
78
79 ;;; shorthand for a common idiom in output statements used in
80 ;;; debugging: (/SHOW "Case 2:" X Y) becomes a pretty-printed version
81 ;;; of (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y), conditional on */SHOW*.
82 (defmacro /show (&rest xlist)
83   #!-sb-show (declare (ignore xlist))
84   #!+sb-show
85   (flet (;; Is X something we want to just show literally by itself?
86          ;; (instead of showing it as NAME=VALUE)
87          (literal-p (x) (or (stringp x) (numberp x))))
88     ;; We build a FORMAT statement out of what we find in XLIST.
89     (let ((format-stream (make-string-output-stream)) ; string arg to FORMAT
90           (format-reverse-rest)  ; reversed &REST argument to FORMAT
91           (first-p t))            ; first pass through loop?
92       (write-string "~&~<~;/" format-stream)
93       (dolist (x xlist)
94         (if first-p
95             (setq first-p nil)
96             (write-string #+ansi-cl " ~_"
97                           #-ansi-cl " " ; for CLISP (CLTL1-ish)
98                           format-stream))
99         (if (literal-p x)
100             (princ x format-stream)
101             (progn (let ((*print-pretty* nil))
102                      (format format-stream "~S=~~S" x))
103                    (push x format-reverse-rest))))
104       (write-string "~;~:>~%" format-stream)
105       (let ((format-string (get-output-stream-string format-stream))
106             (format-rest (reverse format-reverse-rest)))
107         `(locally
108            (declare (optimize (speed 1) (space 2) (safety 3)))
109            (unless (suppress-/show-p)
110              (format *trace-output*
111                      ,format-string
112                      #+ansi-cl (list ,@format-rest)
113                      #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish)
114            (values))))))
115
116 ;;; a disabled-at-compile-time /SHOW, implemented as a macro instead
117 ;;; of a function so that leaving occasionally-useful /SHOWs in place
118 ;;; but disabled incurs no run-time overhead and works even when the
119 ;;; arguments can't be evaluated (e.g. because they're only meaningful
120 ;;; in a debugging version of the system, or just due to bit rot..)
121 (defmacro /noshow (&rest rest)
122   (declare (ignore rest)))
123
124 ;;; like /SHOW, except displaying values in hexadecimal
125 (defmacro /xhow (&rest rest)
126   `(let ((*print-base* 16))
127      (/show ,@rest)))
128 (defmacro /noxhow (&rest rest)
129   (declare (ignore rest)))
130
131 ;;; a trivial version of /SHOW which only prints a constant string,
132 ;;; implemented at a sufficiently low level that it can be used early
133 ;;; in cold init
134 ;;;
135 ;;; Unlike the other /SHOW-related functions, this one doesn't test
136 ;;; */SHOW* at runtime, because messing with special variables early
137 ;;; in cold load is too much trouble to be worth it.
138 (defmacro /show0 (&rest string-designators)
139   ;; We can't use inline MAPCAR here because, at least in 0.6.11.x,
140   ;; this code gets compiled before DO-ANONYMOUS is defined.
141   (declare (notinline mapcar))
142   (let ((s (apply #'concatenate
143                   'simple-string
144                   (mapcar #'string string-designators))))
145     (declare (ignorable s)) ; (for when #!-SB-SHOW)
146     #+sb-xc-host `(/show ,s)
147     #-sb-xc-host `(progn
148                     #!+sb-show
149                     (sb!sys:%primitive print
150                                        ,(concatenate 'simple-string "/" s)))))
151 (defmacro /noshow0 (&rest rest)
152   (declare (ignore rest)))
153
154 ;;; low-level display of a string, works even early in cold init
155 (defmacro /primitive-print (thing)
156   (declare (ignorable thing)) ; (for when #!-SB-SHOW)
157   #!+sb-show
158   (progn
159     #+sb-xc-host `(/show "(/primitive-print)" ,thing)
160     #-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing))))
161
162 ;;; low-level display of a system word, works even early in cold init
163 (defmacro /hexstr (thing)
164   (declare (ignorable thing)) ; (for when #!-SB-SHOW)
165   #!+sb-show
166   (progn
167     #+sb-xc-host `(/show "(/hexstr)" ,thing)
168     #-sb-xc-host `(sb!sys:%primitive print (hexstr ,thing))))
169
170 (defmacro /nohexstr (thing)
171   (declare (ignore thing)))
172 \f
173 (/show0 "done with show.lisp")