source: trunk/source/tests/ansi-tests/pprint-tab.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 6.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Jul 10 14:08:08 2004
4;;;; Contains: Tests of PPRINT-TAB
5
6(in-package :cl-test)
7
8(compile-and-load "printer-aux.lsp")
9
10;;; No effect in a non-pprint stream
11
12(def-pprint-test pprint-tab.non-pretty.1
13  (with-output-to-string
14    (*standard-output*)
15    (write "A")
16    (pprint-tab :line 10 3)
17    (write "B"))
18  "AB")
19
20(def-pprint-test pprint-tab.non-pretty.2
21  (with-output-to-string
22    (*standard-output*)
23    (write "A")
24    (pprint-tab :section 10 3)
25    (write "B"))
26  "AB")
27
28(def-pprint-test pprint-tab.non-pretty.3
29  (with-output-to-string
30    (*standard-output*)
31    (write "A")
32    (pprint-tab :line-relative 10 3)
33    (write "B"))
34  "AB")
35
36(def-pprint-test pprint-tab.non-pretty.4
37  (with-output-to-string
38    (*standard-output*)
39    (write "A")
40    (pprint-tab :section-relative 10 3)
41    (write "B"))
42  "AB")
43
44(def-ppblock-test pprint-tab.non-pretty.5
45  (progn (write "A") (pprint-tab :line 10 3) (write "B"))
46  "AB"
47  :pretty nil)
48
49(def-ppblock-test pprint-tab.non-pretty.6
50  (progn (write "A") (pprint-tab :section 10 3) (write "B"))
51  "AB"
52  :pretty nil)
53
54(def-ppblock-test pprint-tab.non-pretty.7
55  (progn (write "A") (pprint-tab :line-relative 10 3) (write "B"))
56  "AB"
57  :pretty nil)
58
59(def-ppblock-test pprint-tab.non-pretty.8
60  (progn (write "A") (pprint-tab :section-relative 10 3) (write "B"))
61  "AB"
62  :pretty nil)
63
64
65;;; nil designates *standard-output*
66
67(def-ppblock-test pprint-tab.nil.1
68  (progn (write "A")
69         (pprint-tab :line 10 1 nil)
70         (write "B"))
71  "A         B")
72
73;;; t designates *terminal-io*
74
75(def-pprint-test pprint-tab.t.1
76  (with-output-to-string
77    (os)
78    (with-input-from-string
79     (is "")
80     (with-open-stream
81      (*terminal-io* (make-two-way-stream is os))
82      (pprint-logical-block
83       (*terminal-io* nil)
84       (write "A" :stream t)
85       (pprint-tab :line 10 1 t)
86       (write "B" :stream t)))))
87  "A         B")
88
89;;; Now test actual tabbing behavior
90
91;;; NOTE
92;;; I am assuming that when colnum <= current column,
93;;; and the current column == colnum + k * colinc for some positive integer k,
94;;; then pprint-tab :line will tab at least 1 space.
95
96(def-pprint-test pprint-tab.line.1
97  (loop
98   for offset = (random 100)
99   for colnum = (random 100)
100   for colinc = (min (random 50) (random 50))
101   for s = (with-output-to-string
102             (*standard-output*)
103             (pprint-logical-block
104              (*standard-output* nil)
105              (dotimes (i offset) (write #\Space))
106              (pprint-tab :line colnum colinc)
107              (write #\A)))
108   for expected-col = (cond ((< offset colnum) colnum)
109                            ((= colinc 0) offset)
110                            ((= offset colnum) (+ offset colinc))
111                            (t (let ((k (mod (- colnum offset) colinc)))
112                                 (if (= k 0)
113                                     (+ offset colinc)
114                                   (+ offset k)))))
115   repeat 200
116   nconc
117   (unless (string= s (concatenate
118                         'string
119                         (make-string expected-col :initial-element #\Space)
120                         "A"))
121       (list (list offset colnum colinc expected-col (count #\Space s) s))))
122  nil
123  :margin 1000)
124
125(def-pprint-test pprint-tab.section.1
126  (loop
127   for prefix-length = (random 50)
128   for offset = (random 50)
129   for colnum = (random 50)
130   for colinc = (min (random 50) (random 50))
131   for s = (with-output-to-string
132             (*standard-output*)
133             (pprint-logical-block
134              (*standard-output* nil :prefix (make-string prefix-length
135                                                          :initial-element #\Space))
136              (dotimes (i offset) (write #\Space))
137              (pprint-tab :section colnum colinc)
138              (write #\A)))
139   for expected-col = (+ prefix-length
140                         (cond ((< offset colnum) colnum)
141                               ((= colinc 0) offset)
142                               ((= offset colnum) (+ offset colinc))
143                               (t (let ((k (mod (- colnum offset) colinc)))
144                                    (if (= k 0)
145                                        (+ offset colinc)
146                                      (+ offset k))))))
147   repeat 200
148   nconc
149   (unless (string= s (concatenate
150                         'string
151                         (make-string expected-col :initial-element #\Space)
152                         "A"))
153       (list (list offset colnum colinc expected-col (count #\Space s) s))))
154  nil
155  :margin 1000)
156
157(def-pprint-test pprint-tab.line-relative.1
158  (loop
159   for offset = (random 100)
160   for colrel = (random 100)
161   for colinc = (1+ (min (random 50) (random 50)))
162   for extra = (mod (- (+ offset colrel)) colinc)
163   for s = (with-output-to-string
164             (*standard-output*)
165             (pprint-logical-block
166              (*standard-output* nil)
167              (dotimes (i offset) (write #\Space))
168              (pprint-tab :line-relative colrel colinc)
169              (write #\A)))
170   for expected-col = (+ offset colrel extra)
171   repeat 200
172   nconc
173   (unless (string= s (concatenate
174                         'string
175                         (make-string expected-col :initial-element #\Space)
176                         "A"))
177       (list (list offset colrel colinc expected-col (count #\Space s) s))))
178  nil
179  :margin 1000)
180
181(def-pprint-test pprint-tab.section-relative.1
182  (loop
183   for prefix-length = (random 50)
184   for offset = (random 50)
185   for colrel = (random 50)
186   for colinc = (1+ (min (random 50) (random 50)))
187   for extra = (mod (- (+ offset colrel)) colinc)
188   for s = (with-output-to-string
189             (*standard-output*)
190             (pprint-logical-block
191              (*standard-output* nil :prefix (make-string prefix-length
192                                                          :initial-element #\Space))
193              (dotimes (i offset) (write #\Space))
194              (pprint-tab :section-relative colrel colinc)
195              (write #\A)))
196   for expected-col = (+ prefix-length offset colrel extra)
197
198   repeat 200
199   nconc
200   (unless (string= s (concatenate
201                         'string
202                         (make-string expected-col :initial-element #\Space)
203                         "A"))
204       (list (list prefix-length offset colrel colinc extra expected-col (count #\Space s) s))))
205  nil
206  :margin 1000)
207
208;;; Error cases
209
210(deftest pprint-tab.error.1
211  (signals-error (pprint-tab) program-error)
212  t)
213
214(deftest pprint-tab.error.2
215  (signals-error (pprint-tab :line) program-error)
216  t)
217
218(deftest pprint-tab.error.3
219  (signals-error (pprint-tab :line 1) program-error)
220  t)
221
222(deftest pprint-tab.error.4
223  (signals-error (pprint-tab :line 1 1 nil nil) program-error)
224  t)
225
226(deftest pprint-tab.error.5
227  (loop for x in *mini-universe*
228        unless (or (member x '(:line :section :line-relative :section-relative))
229                   (eval `(signals-error (pprint-tab ',x 1 1) error)))
230        collect x)
231  nil)
232
233(deftest pprint-tab.error.5-unsafe
234  (loop for x in *mini-universe*
235        unless (or (member x '(:line :section :line-relative :section-relative))
236                   (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error)))
237        collect x)
238  nil)
Note: See TracBrowser for help on using the repository browser.