X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fshow.lisp;h=be2b45c3c92fcb110f7ed6ecb18b04b51aca9824;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=67234e085327598f2362bb19a317c5e59969463c;hpb=8ac4c19014a23665e5842d0a989cb9d22d1592ed;p=sbcl.git diff --git a/src/code/show.lisp b/src/code/show.lisp index 67234e0..be2b45c 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -33,14 +33,30 @@ #!+sb-show (defvar */show* t) (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. - #-sb-xc-host (sb!sys:%primitive - print - (concatenate 'string "/can't /SHOW: " string)) + ;; + ;; 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? @@ -51,30 +67,30 @@ #!+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))) + ;; (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 @@ -83,35 +99,35 @@ #!-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))) - (unless (suppress-/show-p) - (format *trace-output* - ,format-string - #+ansi-cl (list ,@format-rest) - #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish) - (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 @@ -138,16 +154,19 @@ (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)) + ;; Similarly, we don't use inline CONCATENATE, because some of the + ;; machinery behind its optimizations isn't available in the + ;; cross-compiler. + (declare (notinline mapcar concatenate)) (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)))