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)