X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpprint.impure.lisp;h=2a98b0bde1df22b9711725f273d574345d265759;hb=06333e9fbc30caf953a7510b8d51c71ab8637a72;hp=8c68a6571e69cc446bd8c7ffac98f63e8ca375ff;hpb=3a2c2a2217f77e0d1a44a581c83e0311ebc2594a;p=sbcl.git diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 8c68a65..2a98b0b 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -6,7 +6,7 @@ ;;;; 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. @@ -16,7 +16,7 @@ ;;;; 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, [...] # is an . (EQL) ;;;; ..." @@ -97,50 +97,50 @@ ;;; 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 @@ -149,17 +149,17 @@ ;;; 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)")) ;;; SET-PPRINT-DISPATCH should accept function name arguments, and not ;;; rush to coerce them to functions. @@ -167,32 +167,32 @@ (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))) -;; 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= "" - (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=" - (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= #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) @@ -200,6 +200,20 @@ (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))" (with-output-to-string (s) (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s))))) + +;;; Printing malformed defpackage forms without errors. +(with-test (:name :pprint-defpackage) + (with-open-stream (null (make-broadcast-stream)) + (pprint '(defpackage :foo nil)) + (pprint '(defpackage :foo 42)))) + +(with-test (:name :standard-pprint-dispatch-modified) + (assert + (eq :error + (handler-case (with-standard-io-syntax + (set-pprint-dispatch 'symbol (constantly nil)) + :no-error) + (sb-int:standard-pprint-dispatch-table-modified-error () + :error))))) ;;; success -(quit :unix-status 104)