"#1=(1 . #1#)"))
;;; test from CLHS
-(assert (equal
- (with-output-to-string (*standard-output*)
- (let ((a (list 1 2 3)))
- (setf (cdddr a) a)
- (let ((*print-circle* t))
- (write a :stream *standard-output*))
- :done))
- "#1=(1 2 3 . #1#)"))
-
-;;; test case 1 for bug 99
-(assert (equal
- (with-output-to-string (*standard-output*)
- (let* ((*print-circle* t))
- (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
- 'eql 'eql)))
- "EQL is EQL. This was not seen!"))
+(with-test (:name :pprint-clhs-example)
+ (assert (equal
+ (with-output-to-string (*standard-output*)
+ (let ((a (list 1 2 3)))
+ (setf (cdddr a) a)
+ (let ((*print-circle* t))
+ (write a :stream *standard-output*))
+ :done))
+ "#1=(1 2 3 . #1#)")))
-;;; test case 2 for bug 99
-(assert (equal
- (with-output-to-string (*standard-output*)
- (let* ((*print-circle* t))
- (format *standard-output*
- "~@<~S ~_is ~S and ~S. This was not seen!~:>"
- 'eql 'eql 'eql)))
- "EQL is EQL and EQL. This was not seen!"))
+(with-test (:name (:pprint :bug-99))
+ (assert (equal
+ (with-output-to-string (*standard-output*)
+ (let* ((*print-circle* t))
+ (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
+ 'eql 'eql)))
+ "EQL is EQL. This was not seen!"))
+
+ (assert (equal
+ (with-output-to-string (*standard-output*)
+ (let* ((*print-circle* t))
+ (format *standard-output*
+ "~@<~S ~_is ~S and ~S. This was not seen!~:>"
+ 'eql 'eql 'eql)))
+ "EQL is EQL and EQL. This was not seen!")))
;;; the original test for BUG 99 (only interactive), no obvious
;;; way to make an automated test:
;;; bug 263: :PREFIX, :PER-LINE-PREFIX and :SUFFIX arguments of
;;; PPRINT-LOGICAL-BLOCK may be complex strings
-(let ((list '(1 2 3))
- (prefix (make-array 2
- :element-type 'character
- :displaced-to ";x"
- :fill-pointer 1))
- (suffix (make-array 2
- :element-type 'character
- :displaced-to ">xy"
- :displaced-index-offset 1
- :fill-pointer 1)))
- (assert (equal (with-output-to-string (s)
- (pprint-logical-block (s list
- :per-line-prefix prefix
- :suffix suffix)
- (format s "~{~W~^~:@_~}" list)))
- (format nil ";1~%~
+(with-test (:name :pprint-logical-block-arguments-complex-strings)
+ (let ((list '(1 2 3))
+ (prefix (make-array 2
+ :element-type 'character
+ :displaced-to ";x"
+ :fill-pointer 1))
+ (suffix (make-array 2
+ :element-type 'character
+ :displaced-to ">xy"
+ :displaced-index-offset 1
+ :fill-pointer 1)))
+ (assert (equal (with-output-to-string (s)
+ (pprint-logical-block (s list
+ :per-line-prefix prefix
+ :suffix suffix)
+ (format s "~{~W~^~:@_~}" list)))
+ (format nil ";1~%~
;2~%~
- ;3x"))))
+ ;3x")))))
;;; 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)"))
-(assert (equal
- (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-test (:name :pprint-backquote-magic)
+ (assert (equal
+ (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)"))
+ (assert (equal
+ (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)"))
-(assert (equal
- (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)"))
-(assert (equal
- (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)"))
-#+nil ; see above
-(assert (equal
- (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-test (:name :pprint-leaking-backq-comma)
+ (assert (equal
+ (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.
+ (assert (equal
+ (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)"))
+ (assert (equal
+ (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)"))
+ (assert (equal
+ (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
;;; expressions will have to change to printing the low-level conses,
;;; 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)"))
-(assert (equal
- (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-test (:name :pprint-more-backquote-brokeness)
+ (assert (equal
+ (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)"))
+ (assert (equal
+ (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.
(set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
(defun ppd-function-name (s o)
(print (length o) s))
+
+(with-test (:name (:set-pprint-dispatch :no-function-coerce)))
(let ((s (with-output-to-string (s)
(pprint '(frob a b) s))))
(assert (position #\3 s)))
\f
;; 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)))))
- (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))))
- (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
- (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-test (:name :pprint-circular-detection)
+ (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)))))
+ (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))))
+ (assert (string= "#1=<A 1 #1# #2=#(2) #2#>"
+ (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)))))))
;; Test that a circular improper list inside a logical block works.
-(let ((*print-circle* t)
- (*print-pretty* t))
- (assert (string= "#1=(#2=(#2# . #3=(#1# . #3#)))"
- (with-output-to-string (s)
- (write '#1=(#2=(#2# . #3=(#1# . #3#))) :stream s)))))
+(with-test (:name :pprint-circular-improper-lists-inside-logical-blocks)
+ (let ((*print-circle* t)
+ (*print-pretty* t))
+ (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)
+ (let ((*standard-output* (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)))))
+
+(with-test (:name :pprint-defmethod-lambda-list-function)
+ (flet ((to-string (form)
+ (let ((string (with-output-to-string (s) (pprint form s))))
+ (assert (eql #\newline (char string 0)))
+ (subseq string 1))))
+ (assert (equal "(DEFMETHOD FOO ((FUNCTION CONS)) FUNCTION)"
+ (to-string `(defmethod foo ((function cons)) function))))
+ (assert (equal "(DEFMETHOD FOO :AFTER (FUNCTION CONS) FUNCTION)"
+ (to-string `(defmethod foo :after (function cons) function))))))
+
+(defclass frob () ())
+
+(defmethod print-object ((obj frob) stream)
+ (print-unreadable-object (obj stream :type nil :identity nil)
+ (format stream "FRABOTZICATOR")))
+
+;;; SBCL < 1.0.38 printed #<\nFRABOTIZICATOR>
+(with-test (:name (:pprint-unreadable-object :no-ugliness-when-type=nil))
+ (assert (equal "#<FRABOTZICATOR>"
+ (let ((*print-right-margin* 5)
+ (*print-pretty* t))
+ (format nil "~@<~S~:>" (make-instance 'frob))))))
+
+(with-test (:name :pprint-logical-block-code-deletion-node)
+ (handler-case
+ (compile nil
+ `(lambda (words &key a b c)
+ (pprint-logical-block (nil words :per-line-prefix (or a b c))
+ (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil))))
+ ((or sb-ext:compiler-note warning) (c)
+ (error e))))
+
+(with-test (:name :pprint-logical-block-multiple-per-line-prefix-eval)
+ (funcall (compile nil
+ `(lambda ()
+ (let ((n 0))
+ (with-output-to-string (s)
+ (pprint-logical-block (s nil :per-line-prefix (if (eql 1 (incf n))
+ "; "
+ (error "oops")))
+ (pprint-newline :mandatory s)
+ (pprint-newline :mandatory s)))
+ n)))))
+
+(with-test (:name :can-restore-orig-pprint-dispatch-table)
+ (let* ((orig (pprint-dispatch 'some-symbol))
+ (alt (lambda (&rest args) (apply orig args))))
+ (set-pprint-dispatch 'symbol alt)
+ (assert (eq alt (pprint-dispatch 'some-symbol)))
+ (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
+ (assert (eq orig (pprint-dispatch 'some-symbol)))
+ (assert (not (eq alt orig)))))
+
+(with-test (:name :pprint-improper-list)
+ (let* ((max-length 10)
+ (stream (make-broadcast-stream))
+ (errors
+ (loop for symbol being the symbol in :cl
+ nconc
+ (loop for i from 1 below max-length
+ for list = (cons symbol 10) then (cons symbol list)
+ when (nth-value 1 (ignore-errors (pprint list stream)))
+ collect (format nil "(~{~a ~}~a . 10)" (butlast list) symbol)))))
+ (when errors
+ (error "Can't PPRINT imporper lists: ~a" errors))))
+
+(with-test (:name :pprint-circular-backq-comma)
+ ;; LP 1161218 reported by James M. Lawrence
+ (let ((string (write-to-string '(let ((#1=#:var '(99)))
+ `(progn ,@(identity #1#)))
+ :circle t :pretty t)))
+ (assert (not (search "#2#" string)))))
+
+(with-test (:name :pprint-dotted-setf)
+ (let ((*print-pretty* t))
+ (equal (format nil "~a" '(setf . a))
+ "(SETF . A)")))
+
\f
;;; success
projects / sbcl.git / blobdiff