;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;;;; tests for former BUG 99, where pretty-printing was pretty messed
;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
;;;; - didn't really work:
-;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
+;;;; "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
;;;; (let ((*print-circle* t)) (describe (make-hash-table)))
;;;; is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
;;;; ..."
;;; bug 141b: not enough care taken to disambiguate ,.FOO and ,@FOO
;;; from , .FOO and , @FOO
(assert (equal
- (with-output-to-string (s)
- (write '`(, .foo) :stream s :pretty t :readably t))
- "`(, .FOO)"))
+ (with-output-to-string (s)
+ (write '`(, .foo) :stream s :pretty t :readably t))
+ "`(, .FOO)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(, @foo) :stream s :pretty t :readably t))
- "`(, @FOO)"))
+ (with-output-to-string (s)
+ (write '`(, @foo) :stream s :pretty t :readably t))
+ "`(, @FOO)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(, ?foo) :stream s :pretty t :readably t))
- "`(,?FOO)"))
+ (with-output-to-string (s)
+ (write '`(, ?foo) :stream s :pretty t :readably t))
+ "`(,?FOO)"))
;;; bug reported by Paul Dietz on sbcl-devel: unquoted lambda lists
;;; were leaking the SB-IMPL::BACKQ-COMMA implementation.
(assert (equal
- (with-output-to-string (s)
- (write '`(foo ,x) :stream s :pretty t :readably t))
- "`(FOO ,X)"))
+ (with-output-to-string (s)
+ (write '`(foo ,x) :stream s :pretty t :readably t))
+ "`(FOO ,X)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(foo ,@x) :stream s :pretty t :readably t))
- "`(FOO ,@X)"))
-#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently.
+ (with-output-to-string (s)
+ (write '`(foo ,@x) :stream s :pretty t :readably t))
+ "`(FOO ,@X)"))
+#+nil ; '`(foo ,.x) => '`(foo ,@x) apparently.
(assert (equal
- (with-output-to-string (s)
- (write '`(foo ,.x) :stream s :pretty t :readably t))
- "`(FOO ,.X)"))
+ (with-output-to-string (s)
+ (write '`(foo ,.x) :stream s :pretty t :readably t))
+ "`(FOO ,.X)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(lambda ,x) :stream s :pretty t :readably t))
- "`(LAMBDA ,X)"))
+ (with-output-to-string (s)
+ (write '`(lambda ,x) :stream s :pretty t :readably t))
+ "`(LAMBDA ,X)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(lambda ,@x) :stream s :pretty t :readably t))
- "`(LAMBDA ,@X)"))
+ (with-output-to-string (s)
+ (write '`(lambda ,@x) :stream s :pretty t :readably t))
+ "`(LAMBDA ,@X)"))
#+nil ; see above
(assert (equal
- (with-output-to-string (s)
- (write '`(lambda ,.x) :stream s :pretty t :readably t))
- "`(LAMBDA ,.X)"))
+ (with-output-to-string (s)
+ (write '`(lambda ,.x) :stream s :pretty t :readably t))
+ "`(LAMBDA ,.X)"))
(assert (equal
- (with-output-to-string (s)
- (write '`(lambda (,x)) :stream s :pretty t :readably t))
- "`(LAMBDA (,X))"))
+ (with-output-to-string (s)
+ (write '`(lambda (,x)) :stream s :pretty t :readably t))
+ "`(LAMBDA (,X))"))
;;; more backquote printing brokenness, fixed quasi-randomly by CSR.
;;; NOTE KLUDGE FIXME: because our backquote optimizes at read-time,
;;; these assertions, like the ones above, are fragile. Likewise, it
;;; since the magical symbols are accessible though (car '`(,foo)) and
;;; friends. HATE HATE HATE. -- CSR, 2004-06-10
(assert (equal
- (with-output-to-string (s)
- (write '``(foo ,@',@bar) :stream s :pretty t))
- "``(FOO ,@',@BAR)"))
+ (with-output-to-string (s)
+ (write '``(foo ,@',@bar) :stream s :pretty t))
+ "``(FOO ,@',@BAR)"))
(assert (equal
- (with-output-to-string (s)
- (write '``(,,foo ,',foo foo) :stream s :pretty t))
- "``(,,FOO ,',FOO FOO)"))
+ (with-output-to-string (s)
+ (write '``(,,foo ,',foo foo) :stream s :pretty t))
+ "``(,,FOO ,',FOO FOO)"))
(assert (equal
- (with-output-to-string (s)
- (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
- "``(((,,FOO) ,',FOO) FOO)"))
+ (with-output-to-string (s)
+ (write '``(((,,foo) ,',foo) foo) :stream s :pretty t))
+ "``(((,,FOO) ,',FOO) FOO)"))
\f
;;; SET-PPRINT-DISPATCH should accept function name arguments, and not
;;; rush to coerce them to functions.
(defun ppd-function-name (s o)
(print (length o) s))
(let ((s (with-output-to-string (s)
- (pprint '(frob a b) s))))
+ (pprint '(frob a b) s))))
(assert (position #\3 s)))
\f
-;; Test that circularity detection works with pprint-logical-block
+;; Test that circularity detection works with pprint-logical-block
;; (including when called through pprint-dispatch).
(let ((*print-pretty* t)
(*print-circle* t)
(*print-pprint-dispatch* (copy-pprint-dispatch)))
(labels ((pprint-a (stream form &rest rest)
- (declare (ignore rest))
- (pprint-logical-block (stream form :prefix "<" :suffix ">")
- (pprint-exit-if-list-exhausted)
- (loop
- (write (pprint-pop) :stream stream)
- (pprint-exit-if-list-exhausted)
- (write-char #\space stream)))))
+ (declare (ignore rest))
+ (pprint-logical-block (stream form :prefix "<" :suffix ">")
+ (pprint-exit-if-list-exhausted)
+ (loop
+ (write (pprint-pop) :stream stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)))))
(set-pprint-dispatch '(cons (eql a)) #'pprint-a)
(assert (string= "<A 1 2 3>"
- (with-output-to-string (s)
- (write '(a 1 2 3) :stream s))))
+ (with-output-to-string (s)
+ (write '(a 1 2 3) :stream s))))
(assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
- (with-output-to-string (s)
- (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
+ (with-output-to-string (s)
+ (write '#2=(a 1 #2# #5=#(2) #5#) :stream s))))
(assert (string= "#1=(B #2=<A 1 #1# 2 3> #2#)"
- (with-output-to-string (s)
- (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s))))))
+ (with-output-to-string (s)
+ (write '#3=(b #4=(a 1 #3# 2 3) #4#) :stream s))))))
;; Test that a circular improper list inside a logical block works.
(let ((*print-circle* t)
projects / sbcl.git / blobdiff