pprint-fill.lsp 5.56 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Jun 25 22:03:01 2004
;;;; Contains: Tests of PPRINT-FILL

(in-package :cl-test)

;;; When printing a non-list, the result is the same as calling WRITE."
(deftest pprint-fill.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
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (pprint-fill s obj))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
20 21 22 23 24
  nil)

(deftest pprint-fill.2
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
25
         (*print-readably* nil))
26
     (loop for obj in *mini-universe*
sds's avatar
sds committed
27 28 29 30 31 32
           nconc
           (and (not (listp obj))
                (let ((s1 (write-to-string obj))
                      (s2 (with-output-to-string (s) (pprint-fill s obj))))
                  (unless (equal s1 s2)
                    (list (list obj s1 s2))))))))
33 34
  nil)

35
(defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil) (len nil))
36
  `(deftest ,name
37 38
     (my-with-standard-io-syntax
      (let ((*print-pretty* t)
sds's avatar
sds committed
39 40 41 42 43 44
            (*print-readably* nil)
            (*print-right-margin* ,margin)
            (*package* (find-package "CL-TEST"))
            (*print-length* ,len)
            (*print-circle* ,circle))
        (with-output-to-string (s) (pprint-fill s ,@args))))
45 46
     ,expected-value))

47 48 49
(def-pprint-fill-test pprint-fill.3 ('(|A|)) "(A)")
(def-pprint-fill-test pprint-fill.4 ('(|A|) t) "(A)")
(def-pprint-fill-test pprint-fill.5 ('(|A|) nil) "A")
50 51 52 53 54 55 56 57 58 59
(def-pprint-fill-test pprint-fill.6 ('(1 2 3 4 5)) "(1 2 3 4 5)")
(def-pprint-fill-test pprint-fill.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5")

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

;;; Takes T, NIL as stream designators

(deftest pprint-fill.10
60 61
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
62 63
         (*print-readably* nil)
         (*print-right-margin* 100))
64 65
     (with-output-to-string
       (os)
66
       (with-input-from-string
sds's avatar
sds committed
67 68 69
        (is "")
        (with-open-stream (*terminal-io* (make-two-way-stream is os))
                          (pprint-fill t '(1 2 3)))))))
70
  "(1 2 3)")
71

72
(deftest pprint-fill.11
73
  (my-with-standard-io-syntax
74
   (let ((*print-pretty* t)
sds's avatar
sds committed
75 76
         (*print-readably* nil)
         (*print-right-margin* 100))
77 78
     (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3)))))
  "(1 2 3)")
79 80


81 82 83
;;; Now tests for cases that should be wrapped
;;; It's not entirely clear what they should be doing
;;; but check for some obvious properties
84

85
(deftest pprint-fill.12
86
  (my-with-standard-io-syntax
87
   (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-fill os obj))))
             (cond
              ((not (eql (elt s 0) #\Newline))
               (list :bad1 s))
              ((not (equal (read-from-string s) obj))
               (list :bad2 s))
              ((not (find #\Newline s :start 1))
               (list :bad3 s))
              (t t)))
           unless (eql result t)
           collect (list i result))))
107
  nil)
108 109


110 111 112
(deftest pprint-fill.13
  (my-with-standard-io-syntax
   (let ((*print-pretty* t)
sds's avatar
sds committed
113 114 115
         (*print-readably* nil)
         (*package* (find-package :cl-test))
         (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|)))
116
     (loop for i from 1 to 10
sds's avatar
sds committed
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
           for result =
           (let* ((*print-right-margin* i)
                  (s (with-output-to-string (os)
                                            (terpri os)
                                            (pprint-fill 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))
              ((not (find #\Newline s :start 1))
               (list :bad3 s))
              (t t)))
           unless (eql result t)
           collect (list i result))))
133
  nil)
134

sds's avatar
sds committed
135
;;;
136
(def-pprint-fill-test pprint-fill.14 ((let ((x (list '|A|))) (list x x)))
137
  "(#1=(A) #1#)" :circle t)
138

139
(def-pprint-fill-test pprint-fill.15 ((let ((x (list '|A|))) (setf (cdr x) x) x))
140
  "#1=(A . #1#)" :circle t :len 500)
141 142


143 144 145 146 147
;;; Test that pprint-fill returns NIL

(deftest pprint-fill.return-values.1
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
148
         (*package* (find-package "CL-TEST")))
149
     (with-open-stream (s (make-broadcast-stream))
sds's avatar
sds committed
150
                       (pprint-fill s '(a b)))))
151 152 153 154 155
  nil)

(deftest pprint-fill.return-values.2
  (my-with-standard-io-syntax
   (let ((*print-pretty* nil)
sds's avatar
sds committed
156
         (*package* (find-package :cl-test)))
157
     (with-open-stream (s (make-broadcast-stream))
sds's avatar
sds committed
158
                       (pprint-fill s 10 nil t))))
159 160
  nil)

161 162 163 164 165 166 167 168 169 170 171 172 173
;;; Error tests

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

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

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