X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fshow.lisp;h=67234e085327598f2362bb19a317c5e59969463c;hb=c25e4572f5505236faf126f38a74f32a80bf1e8c;hp=27f2973a51b7bc2983ffdde9d8af4f16ecf3e39e;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/show.lisp b/src/code/show.lisp index 27f2973..67234e0 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -11,52 +11,74 @@ ;;;; files for more information. (in-package "SB!INT") - -;;; FIXME: Look for any other calls to %PRIMITIVE PRINT and check whether -;;; any of them need removing too. - -;;;; FIXME: Remove this after all in-the-flow-of-control EXPORTs -;;;; have been cleaned up. - -(defvar *rogue-export*) - -;;;; FILE-COMMENT - -;;;; FILE-COMMENT arguably doesn't belong in this file, even though -;;;; it's sort of for displaying information about the system. -;;;; However, it's convenient to put it in this file, since we'd like -;;;; this file to be the first file in the system, and we'd like to be -;;;; able to use FILE-COMMENT in this file. - -;;; The real implementation of SB!INT:FILE-COMMENT is a special form, -;;; but this macro expansion for it is still useful for -;;; (1) documentation, -;;; (2) code walkers, and -;;; (3) compiling the cross-compiler itself under the cross-compilation -;;; host ANSI Common Lisp. -(defmacro file-comment (string) - #!+sb-doc - "FILE-COMMENT String - When COMPILE-FILE sees this form at top-level, it places the constant string - in the run-time source location information. DESCRIBE will print the file - comment for the file that a function was defined in. The string is also - textually present in the FASL, so the RCS \"ident\" command can find it, - etc." - (declare (ignore string)) - '(values)) - -;;; Now that we've got it, we can use it. -(file-comment - "$Header$") ;;;; various SB-SHOW-dependent forms +;;;; +;;;; In general, macros named /FOO +;;;; * are for debugging/tracing +;;;; * expand into nothing unless :SB-SHOW is in the target +;;;; features list +;;;; Often, they also do nothing at runtime if */SHOW* is NIL, but +;;;; this is not always true for some very-low-level ones. +;;;; +;;;; (I follow the "/FOO for debugging/tracing expressions" naming +;;;; rule and several other naming conventions in all my Lisp +;;;; programming when possible, and then set Emacs to display comments +;;;; in one shade of blue, tracing expressions in another shade of +;;;; blue, and declarations and assertions in a yellowish shade, so +;;;; that it's easy to separate them from the "real code" which +;;;; actually does the work of the program. -- WHN 2001-05-07) ;;; Set this to NIL to suppress output from /SHOW-related forms. #!+sb-show (defvar */show* t) -;;; shorthand for a common idiom in output statements used in debugging: -;;; (/SHOW "Case 2:" X Y) becomes a pretty-printed version of -;;; (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y). +(defun cannot-/show (string) + #+sb-xc-host (error "can't /SHOW: ~A" string) + ;; We end up in this situation when we execute /SHOW too early in + ;; cold init. That happens to me often enough that it's really + ;; annoying for it to cause a hard failure -- which at that point is + ;; hard to recover from -- instead of just diagnostic output. + #-sb-xc-host (sb!sys:%primitive + print + (concatenate 'string "/can't /SHOW: " string)) + (values)) + +;;; Should /SHOW output be suppressed at this point? +;;; +;;; Note that despite the connoting-no-side-effects-pure-predicate +;;; name, we emit some error output if we're called at a point where +;;; /SHOW is inherently invalid. +#!+sb-show +(defun suppress-/show-p () + (cond (;; protection against /SHOW too early in cold init for + ;; (FORMAT *TRACE-OUTPUT* ..) to work, part I: Obviously + ;; we need *TRACE-OUTPUT* bound. + (not (boundp '*trace-output*)) + (cannot-/show "*TRACE-OUTPUT* isn't bound. (Try /SHOW0.)") + t) + (;; protection against /SHOW too early in cold init for + ;; (FORMAT *TRACE-OUTPUT* ..) to work, part II: In a virtuoso + ;; display of name mnemonicity, *READTABLE* is used by the + ;; printer to decide which case convention to use when + ;; writing symbols, so we need it bound. + (not (boundp '*readtable*)) + (cannot-/show "*READTABLE* isn't bound. (Try /SHOW0.)") + t) + (;; more protection against /SHOW too early in cold init, part III + (not (boundp '*/show*)) + (cannot-/show "*/SHOW* isn't bound. (Try initializing it earlier.)") + t) + (;; ordinary, healthy reason to suppress /SHOW, no error + ;; output needed + (not */show*) + t) + (t + ;; Let the /SHOW go on. + nil))) + +;;; shorthand for a common idiom in output statements used in +;;; debugging: (/SHOW "Case 2:" X Y) becomes a pretty-printed version +;;; of (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y), conditional on */SHOW*. (defmacro /show (&rest xlist) #!-sb-show (declare (ignore xlist)) #!+sb-show @@ -84,30 +106,18 @@ (format-rest (reverse format-reverse-rest))) `(locally (declare (optimize (speed 1) (space 2) (safety 3))) - ;; For /SHOW to work, we need *TRACE-OUTPUT* of course, but - ;; also *READTABLE* (used by the printer to decide what - ;; case convention to use when outputting symbols). - (if (every #'boundp '(*trace-output* *readtable*)) - (when */show* - (format *trace-output* - ,format-string - #+ansi-cl (list ,@format-rest) - #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish) - #+sb-xc-host (error "can't /SHOW, unbound vars") - ;; We end up in this situation when we execute /SHOW - ;; too early in cold init. That happens often enough - ;; that it's really annoying for it to cause a hard - ;; failure -- which at that point is hard to recover - ;; from -- instead of just diagnostic output. - #-sb-xc-host (sb!sys:%primitive - print - "/(can't /SHOW, unbound vars)")) + (unless (suppress-/show-p) + (format *trace-output* + ,format-string + #+ansi-cl (list ,@format-rest) + #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish) (values)))))) ;;; a disabled-at-compile-time /SHOW, implemented as a macro instead ;;; of a function so that leaving occasionally-useful /SHOWs in place ;;; but disabled incurs no run-time overhead and works even when the -;;; arguments can't be evaluated due to code flux +;;; arguments can't be evaluated (e.g. because they're only meaningful +;;; in a debugging version of the system, or just due to bit rot..) (defmacro /noshow (&rest rest) (declare (ignore rest))) @@ -120,20 +130,44 @@ ;;; a trivial version of /SHOW which only prints a constant string, ;;; implemented at a sufficiently low level that it can be used early -;;; in cold load +;;; in cold init ;;; ;;; Unlike the other /SHOW-related functions, this one doesn't test ;;; */SHOW* at runtime, because messing with special variables early ;;; in cold load is too much trouble to be worth it. -(defmacro /show0 (s) - (declare (type simple-string s)) - (declare (ignorable s)) ; (for when #!-SB-SHOW) - #+sb-xc-host `(/show ,s) - #-sb-xc-host `(progn - #!+sb-show - (sb!sys:%primitive print - ,(concatenate 'simple-string "/" s)))) -(defmacro /noshow0 (s) - (declare (ignore s))) +(defmacro /show0 (&rest string-designators) + ;; We can't use inline MAPCAR here because, at least in 0.6.11.x, + ;; this code gets compiled before DO-ANONYMOUS is defined. + (declare (notinline mapcar)) + (let ((s (apply #'concatenate + 'simple-string + (mapcar #'string string-designators)))) + (declare (ignorable s)) ; (for when #!-SB-SHOW) + #+sb-xc-host `(/show ,s) + #-sb-xc-host `(progn + #!+sb-show + (sb!sys:%primitive print + ,(concatenate 'simple-string "/" s))))) +(defmacro /noshow0 (&rest rest) + (declare (ignore rest))) + +;;; low-level display of a string, works even early in cold init +(defmacro /primitive-print (thing) + (declare (ignorable thing)) ; (for when #!-SB-SHOW) + #!+sb-show + (progn + #+sb-xc-host `(/show "(/primitive-print)" ,thing) + #-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing)))) + +;;; low-level display of a system word, works even early in cold init +(defmacro /hexstr (thing) + (declare (ignorable thing)) ; (for when #!-SB-SHOW) + #!+sb-show + (progn + #+sb-xc-host `(/show "(/hexstr)" ,thing) + #-sb-xc-host `(sb!sys:%primitive print (hexstr ,thing)))) + +(defmacro /nohexstr (thing) + (declare (ignore thing))) (/show0 "done with show.lisp")