X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpprint.impure.lisp;h=4f10bd01c1e91b00058203c84cd2cad846d31660;hb=062283b901155792f65775491aea51481c56faaa;hp=8c68a6571e69cc446bd8c7ffac98f63e8ca375ff;hpb=3a2c2a2217f77e0d1a44a581c83e0311ebc2594a;p=sbcl.git diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 8c68a65..4f10bd0 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) ;;;; ..." @@ -43,31 +43,31 @@ "#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: @@ -75,72 +75,76 @@ ;;; 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 @@ -148,58 +152,156 @@ ;;; 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)"))) ;;; 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)))) + (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))))) - (set-pprint-dispatch '(cons (eql a)) #'pprint-a) - (assert (string= "" - (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)))) - (assert (string= "#1=(B #2= #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= "" + (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)))) + (assert (string= "#1=(B #2= #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 "#" + (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)"))) + ;;; success -(quit :unix-status 104)