pprint-logical-block.lsp 9.19 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Jul  4 07:17:52 2004
;;;; Contains: Tests of PPRINT-LOGICAL-BLOCK

(in-package :cl-test)

(deftest pprint-logical-block.1
  (with-standard-io-syntax
10
   (let ((*print-pretty* t)
sds's avatar
sds committed
11 12
         (*print-right-margin* 100)
         (*print-readably* nil))
13 14 15 16 17 18 19
     (with-open-stream
      (os (make-string-output-stream))
      (values
       (multiple-value-list (pprint-logical-block (os 1)))
       (get-output-stream-string os)))))
  (nil) "1")

20 21 22
(deftest pprint-logical-block.2
  (with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
23 24 25
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z))))
26
     (string=t (with-output-to-string (s) (write val :stream s))
sds's avatar
sds committed
27
               (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s))))))
28 29 30 31 32
  t)

(deftest pprint-logical-block.3
  (with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
33 34
         (*print-right-margin* 100)
         (*print-readably* nil))
35 36 37 38 39 40 41 42
     (with-output-to-string
       (*standard-output*)
       (pprint-logical-block (nil 1)))))
  "1")

(deftest pprint-logical-block.4
  (with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
43 44
         (*print-right-margin* 100)
         (*print-readably* nil))
45 46 47
     (with-output-to-string
       (os)
       (with-input-from-string
sds's avatar
sds committed
48 49 50
        (is "")
        (with-open-stream (*terminal-io* (make-two-way-stream is os))
                          (pprint-logical-block (t 1)))))))
51 52 53 54 55
  "1")

(deftest pprint-logical-block.5
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
56 57 58
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(1)))
59 60 61
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
62 63
        (os val)
        (write (car val) :stream os)))))
64 65 66 67 68
  "1")

(deftest pprint-logical-block.6
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
69 70 71
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(2)))
72 73 74
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
75 76
        (os val :prefix "[" :suffix "]")
        (write (car val) :stream os)))))
77 78 79 80 81 82
  "[2]")

(deftest pprint-logical-block.7
  :notes (:nil-vectors-are-strings)
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
83 84 85
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(3)))
86 87 88
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
89 90 91 92
        (os val
            :prefix (make-array '(0) :element-type nil)
            :suffix (make-array '(0) :element-type nil))
        (write (car val) :stream os)))))
93 94 95 96 97
  "3")

(deftest pprint-logical-block.8
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
98 99 100
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(4)))
101 102 103
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
104 105 106 107 108 109 110 111
        (os val
            :prefix (make-array '(10) :element-type 'character
                                :initial-contents "abcdefghij"
                                :fill-pointer 3)
            :suffix (make-array '(2) :element-type 'base-char
                                :initial-contents "!?"
                                :adjustable t))
        (write (car val) :stream os)))))
112 113 114 115 116
  "abc4!?")

(deftest pprint-logical-block.9
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
117 118 119 120
         (*print-right-margin* 100)
         (*print-readably* nil)
         (*print-level* 1)
         (val '((4))))
121 122 123
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
124 125 126 127
        (os val :prefix "{" :suffix "}")
        (pprint-logical-block
         (os (car val)  :prefix "[" :suffix "]")
         (write (caar val) :stream os))))))
128 129 130 131 132
  "{#}")

(deftest pprint-logical-block.10
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
133 134 135 136
         (*print-right-margin* 100)
         (*print-readably* nil)
         (*print-level* 0)
         (val '(5)))
137 138 139
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
140 141
        (os val :prefix "[" :suffix "]")
        (write (car val) :stream os)))))
142 143 144 145 146
  "#")

(deftest pprint-logical-block.11
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
147 148 149
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(6)))
150 151 152
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
153 154
        (os val :per-line-prefix "abcd")
        (write (car val) :stream os)))))
155 156 157 158 159
  "abcd6")

(deftest pprint-logical-block.12
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
160 161 162
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(a b c)))
163 164 165
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
166 167 168 169 170 171 172
        (os val :per-line-prefix "abcd")
        (write 1 :stream os)
        (terpri os)
        (terpri os)
        (write 2 :stream os)
        (terpri os)
        (write 3 :stream os)))))
173 174 175 176 177 178 179 180 181 182

  "abcd1
abcd
abcd2
abcd3")

;;; Same as pprint-logical-block.10, but *print-pretty* is bound to nil
(deftest pprint-logical-block.13
  (with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
183 184 185 186
         (*print-right-margin* 100)
         (*print-readably* nil)
         (*print-level* 0)
         (val '(5)))
187 188 189
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
190 191
        (os val :prefix "[" :suffix "]")
        (write (car val) :stream os)))))
192 193
  "#")

194 195 196 197
;;; Both :suffix and :per-line-prefix may be supplied
(deftest pprint-logical-block.14
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
198 199 200
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val '(6)))
201 202 203
     (with-output-to-string
       (os)
       (pprint-logical-block (os val :per-line-prefix "[" :suffix "]")
sds's avatar
sds committed
204
                             (write (car val) :stream os)))))
205 206 207 208 209 210 211
  "[6]")

;;; Declarations are allowed

(deftest pprint-logical-block.15
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
212
         (x 0))
213 214 215 216 217 218 219 220 221 222 223
     (with-output-to-string
       (os)
       (declare (integer x))
       (declare (optimize (safety 3))))))
  "")

;;; Two conditions that cause :prefix, :suffix to be omitted

(deftest pprint-logical-block.16
  (with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
224 225 226
         (*print-right-margin* 100)
         (*print-readably* nil)
         (val 9))
227 228 229
     (with-output-to-string
       (os)
       (pprint-logical-block (os val :prefix "[" :suffix "]")
sds's avatar
sds committed
230
                             (write val :stream os)))))
231 232 233 234 235
  "9")

(deftest pprint-logical-block.17
  (with-standard-io-syntax
   (let* ((*print-pretty* t)
sds's avatar
sds committed
236 237 238 239 240
          (*print-right-margin* 100)
          (*print-readably* nil)
          (*print-circle* t)
          (v1 '(8))
          (val (list v1 v1)))
241 242 243
     (with-output-to-string
       (os)
       (pprint-logical-block
sds's avatar
sds committed
244 245 246 247 248 249
        (os val :prefix "(" :suffix ")")
        (pprint-logical-block (os (car val) :prefix "(" :suffix ")")
                              (write (caar val) :stream os))
        (write-char #\Space os)
        (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")")
                              (write (caadr val) :stream os))))))
250
  "(#1=(8) #1#)")
251 252 253 254

;;; Error cases

(deftest pprint-logical-block.error.1
pfdietz's avatar
pfdietz committed
255
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
256 257
                        (pprint-logical-block (*standard-output* '(1) :prefix x)))
                    #'stringp)
258
  nil)
259

260
(deftest pprint-logical-block.error.1-unsafe
pfdietz's avatar
pfdietz committed
261
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
262 263 264
                        (declare (optimize (safety 0)))
                        (pprint-logical-block (*standard-output* '(1) :prefix x)))
                    #'stringp)
265 266
  nil)

267
(deftest pprint-logical-block.error.2
pfdietz's avatar
pfdietz committed
268
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
269 270
                        (pprint-logical-block (*standard-output* '(1) :suffix x)))
                    #'stringp)
271
  nil)
272

273
(deftest pprint-logical-block.error.2-unsafe
pfdietz's avatar
pfdietz committed
274
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
275 276 277
                        (declare (optimize (safety 0)))
                        (pprint-logical-block (*standard-output* '(1) :suffix x)))
                    #'stringp)
278 279
  nil)

280
(deftest pprint-logical-block.error.3
pfdietz's avatar
pfdietz committed
281
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
282 283
                        (pprint-logical-block (*standard-output* '(1) :per-line-prefix x)))
                    #'stringp)
284
  nil)
285

286
(deftest pprint-logical-block.error.3-unsafe
pfdietz's avatar
pfdietz committed
287
  (check-type-error #'(lambda (x)
sds's avatar
sds committed
288 289 290
                        (declare (optimize (safety 0)))
                        (pprint-logical-block (*standard-output* '(1) :per-line-prefix x)))
                    #'stringp)
291 292
  nil)

293 294
(deftest pprint-logical-block.error.4
  (signals-error (with-standard-io-syntax
sds's avatar
sds committed
295 296 297 298 299 300 301
                  (let ((*print-pretty* t)
                        (*print-right-margin* 100)
                        (*print-readably* nil)
                        (val '(7)))
                    (pprint-logical-block (os val :prefix "" :per-line-prefix "")
                                          (write (car val) :stream os))))
                 error)
302
  t)
303 304 305

(deftest pprint-logical-block.error.4-unsafe
  (signals-error (with-standard-io-syntax
sds's avatar
sds committed
306 307 308 309 310 311 312 313
                  (let ((*print-pretty* t)
                        (*print-right-margin* 100)
                        (*print-readably* nil)
                        (val '(7)))
                    (pprint-logical-block (os val :prefix "" :per-line-prefix "")
                                          (write (car val) :stream os))))
                 error
                 :safety 0)
314
  t)