0.pre7.123:
[sbcl.git] / tests / pprint.impure.lisp
1 ;;;; test of the pretty-printer
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;; 
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (in-package :cl-user)
15
16 ;;;; tests for former BUG 99, where pretty-printing was pretty messed
17 ;;;; up, e.g. PPRINT-LOGICAL-BLOCK - because of CHECK-FOR-CIRCULARITY
18 ;;;; - didn't really work:
19 ;;;;   "DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from 
20 ;;;;    (let ((*print-circle* t)) (describe (make-hash-table)))
21 ;;;;  is weird, [...] #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
22 ;;;; ..."
23 ;;;; So, this was mainly a pretty printing problem.
24
25 ;;; Create a circular list.
26 (eval-when (:compile-toplevel :load-toplevel :execute)
27   (defparameter *circ-list* '(1 1))
28   (prog1 nil
29     (setf (cdr *circ-list*) *circ-list*)))
30
31 ;;; circular lists are still being printed correctly?
32 (assert (equal
33          (with-output-to-string (*standard-output*)
34            (let ((*print-circle* t))
35              (pprint-logical-block (*standard-output* *circ-list*)
36                                  (format *standard-output* "~S" *circ-list*))))
37          "#1=(1 . #1#)"))
38
39 ;;; test from CLHS
40 (assert (equal
41          (with-output-to-string (*standard-output*)
42           (let ((a (list 1 2 3)))
43             (setf (cdddr a) a)
44             (let ((*print-circle* t))
45               (write a :stream *standard-output*))
46             :done))
47          "#1=(1 2 3 . #1#)"))
48
49 ;;; test case 1 for bug 99
50 (assert (equal
51          (with-output-to-string (*standard-output*)
52            (let* ((*print-circle* t))
53              (format *standard-output* "~@<~S ~_is ~S. This was not seen!~:>"
54                      'eql 'eql)))
55          "EQL is EQL. This was not seen!"))
56
57 ;;; test case 2 for bug 99
58 (assert (equal
59          (with-output-to-string (*standard-output*)
60            (let* ((*print-circle* t))
61              (format *standard-output*
62                      "~@<~S ~_is ~S and ~S. This was not seen!~:>"
63                      'eql 'eql 'eql)))
64          "EQL is EQL and EQL. This was not seen!"))
65
66 ;;; the original test for BUG 99 (only interactive), no obvious
67 ;;; way to make an automated test:
68 ;;;  (LET ((*PRINT-CIRCLE* T)) (DESCRIBE (MAKE-HASH-TABLE)))
69
70 ;;; success
71 (quit :unix-status 104)