;; 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))
+ ;; (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
#!+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
#!-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
;; 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)))
projects / sbcl.git / blobdiff