pprint-linear.lsp 5.18 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Jun 26 21:55:26 2004
;;;; Contains: Tests of PPRINT-LINEAR

(in-package :cl-test)

;;; When printing a non-list, the result is the same as calling WRITE."
(deftest pprint-linear.1
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
12
         (*print-readably* nil))
13
     (loop for obj in *mini-universe*
sds's avatar
sds committed
14 15 16 17 18 19 20 21
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
                                                                     (pprint-linear s obj))
                                                                    '(nil))))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
22 23 24 25 26
  nil)

(deftest pprint-linear.2
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
27
         (*print-readably* nil))
28
     (loop for obj in *mini-universe*
sds's avatar
sds committed
29 30 31 32 33 34 35 36
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (assert (equal (multiple-value-list
                                                                     (pprint-linear s obj))
                                                                    '(nil))))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
37 38 39 40
  nil)

(defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil))
  `(deftest ,name
41 42
     (my-with-standard-io-syntax
      (let ((*print-pretty* t)
sds's avatar
sds committed
43 44 45 46 47 48 49
            (*print-readably* nil)
            (*print-right-margin* ,margin)
            (*package* (find-package "CL-TEST"))
            (*print-circle* ,circle))
        (with-output-to-string
          (s)
          (pprint-linear s ,@args))))
50 51
     ,expected-value))

52 53 54
(def-pprint-linear-test pprint-linear.3 ('(|A|)) "(A)")
(def-pprint-linear-test pprint-linear.4 ('(|A|) t) "(A)")
(def-pprint-linear-test pprint-linear.5 ('(|A|) nil) "A")
55 56 57 58 59 60 61 62 63 64 65 66
(def-pprint-linear-test pprint-linear.6 ('(1 2 3 4 5)) "(1 2 3 4 5)")
(def-pprint-linear-test pprint-linear.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5")

;;; The fourth argument is ignored
(def-pprint-linear-test pprint-linear.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)")
(def-pprint-linear-test pprint-linear.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5")

;;; Takes T, NIL as stream designators

(deftest pprint-linear.10
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
67 68
         (*print-readably* nil)
         (*print-right-margin* 100))
69 70
     (with-output-to-string
       (os)
71
       (with-input-from-string
sds's avatar
sds committed
72 73 74
        (is "")
        (with-open-stream (*terminal-io* (make-two-way-stream is os))
                          (pprint-linear t '(1 2 3)))))))
75 76 77 78 79
  "(1 2 3)")

(deftest pprint-linear.11
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
80 81
         (*print-readably* nil)
         (*print-right-margin* 100))
82 83 84 85 86 87
     (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3)))))
  "(1 2 3)")

(deftest pprint-linear.12
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
88 89 90
         (*print-readably* nil)
         (*package* (find-package :cl-test))
         (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
91
     (loop for i from 1 to 10
sds's avatar
sds committed
92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
           for result =
           (let* ((*print-right-margin* i)
                  (s (with-output-to-string (os)
                                            (terpri os)
                                            (pprint-linear os obj))))
             (cond
              ((not (eql (elt s 0) #\Newline))
               (list :bad1 s))
              ((not (equal (read-from-string s) obj))
               (list :bad2 s))
              ((< (count #\Newline s) (length obj))
               (list :bad3 s))
              (t t)))
           unless (eql result t)
           collect (list i result))))
107 108 109 110 111
  nil)

(deftest pprint-linear.13
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
112 113 114
         (*print-readably* nil)
         (*package* (find-package :cl-test))
         (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
115
     (loop for i from 1 to 10
sds's avatar
sds committed
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
           for result =
           (let* ((*print-right-margin* i)
                  (s (with-output-to-string (os)
                                            (terpri os)
                                            (pprint-linear os obj nil))))
             (cond
              ((not (eql (elt s 0) #\Newline))
               (list :bad1 s))
              ((not (equal (read-from-string (concatenate 'string "(" s ")"))
                           obj))
               (list :bad2 s))
              ((< (count #\Newline s) (length obj))
               (list :bad3 s))
              (t t)))
           unless (eql result t)
           collect (list i result))))
132 133
  nil)

sds's avatar
sds committed
134
;;;
135
(def-pprint-linear-test pprint-linear.14 ((let ((x (list '|A|))) (list x x)))
136
  "(#1=(A) #1#)" :circle t)
137 138 139 140 141 142 143 144 145 146 147 148 149 150

;;; Error tests

(deftest pprint-linear.error.1
  (signals-error (pprint-linear) program-error)
  t)

(deftest pprint-linear.error.2
  (signals-error (pprint-linear *standard-output*) program-error)
  t)

(deftest pprint-linear.error.3
  (signals-error (pprint-linear *standard-output* nil t t t) program-error)
  t)