X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fshow.lisp;h=f22336bca9053e254c1c11910006368c3eee2511;hb=15db88b169f732c8d339047bfad92e0725d7cacc;hp=c4abb219ec0e2a4993b67b73dcd3341658fa2141;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/code/show.lisp b/src/code/show.lisp index c4abb21..f22336b 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -32,60 +32,108 @@ ;;; 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) + (declare (type simple-string 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. + ;; + ;; FIXME: The following is what we'd like to have. However, + ;; including it as is causes compilation of make-host-2 to fail, + ;; with "caught WARNING: defining setf macro for AREF when (SETF + ;; AREF) was previously treated as a function" during compilation of + ;; defsetfs.lisp + ;; + ;; #-sb-xc-host (sb!sys:%primitive print + ;; (concatenate 'simple-string "/can't /SHOW:" string)) + ;; + ;; because the CONCATENATE is transformed to an expression involving + ;; (SETF AREF). Not declaring the argument as a SIMPLE-STRING (or + ;; otherwise inhibiting the transform; e.g. with (SAFETY 3)) would + ;; help, but full calls to CONCATENATE don't work this early in + ;; cold-init, because they now need the full assistance of the type + ;; system. So (KLUDGE): + #-sb-xc-host (sb!sys:%primitive print "/can't /SHOW:") + #-sb-xc-host (sb!sys:%primitive print 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 (flet (;; Is X something we want to just show literally by itself? - ;; (instead of showing it as NAME=VALUE) - (literal-p (x) (or (stringp x) (numberp x)))) + ;; (instead of showing it as NAME=VALUE) + (literal-p (x) (or (stringp x) (numberp x)))) ;; We build a FORMAT statement out of what we find in XLIST. (let ((format-stream (make-string-output-stream)) ; string arg to FORMAT - (format-reverse-rest) ; reversed &REST argument to FORMAT - (first-p t)) ; first pass through loop? + (format-reverse-rest) ; reversed &REST argument to FORMAT + (first-p t)) ; first pass through loop? (write-string "~&~<~;/" format-stream) (dolist (x xlist) - (if first-p - (setq first-p nil) - (write-string #+ansi-cl " ~_" - #-ansi-cl " " ; for CLISP (CLTL1-ish) - format-stream)) - (if (literal-p x) - (princ x format-stream) - (progn (let ((*print-pretty* nil)) - (format format-stream "~S=~~S" x)) - (push x format-reverse-rest)))) + (if first-p + (setq first-p nil) + (write-string #+ansi-cl " ~_" + #-ansi-cl " " ; for CLISP (CLTL1-ish) + format-stream)) + (if (literal-p x) + (princ x format-stream) + (progn (let ((*print-pretty* nil)) + (format format-stream "~S=~~S" x)) + (push x format-reverse-rest)))) (write-string "~;~:>~%" format-stream) (let ((format-string (get-output-stream-string format-stream)) - (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)")) - (values)))))) + (format-rest (reverse format-reverse-rest))) + `(locally + (declare (optimize (speed 1) (space 2) (safety 3))) + (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))) @@ -108,14 +156,14 @@ ;; this code gets compiled before DO-ANONYMOUS is defined. (declare (notinline mapcar)) (let ((s (apply #'concatenate - 'simple-string - (mapcar #'string string-designators)))) + '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))))) + #!+sb-show + (sb!sys:%primitive print + ,(concatenate 'simple-string "/" s))))) (defmacro /noshow0 (&rest rest) (declare (ignore rest))) @@ -127,9 +175,6 @@ #+sb-xc-host `(/show "(/primitive-print)" ,thing) #-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing)))) -(defmacro /nohexstr (thing) - (declare (ignore thing))) - ;;; low-level display of a system word, works even early in cold init (defmacro /hexstr (thing) (declare (ignorable thing)) ; (for when #!-SB-SHOW)