source: trunk/source/tests/ansi-tests/printer-aux.lsp @ 8991

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

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

File size: 16.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Feb 23 06:20:00 2004
4;;;; Contains: Auxiliary functions and macros for printer tests
5
6(in-package :cl-test)
7
8(eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp"))
9
10(defmacro def-print-test (name form result &rest bindings)
11  `(deftest ,name
12     (if (equalpt
13          (my-with-standard-io-syntax
14           (let ((*print-readably* nil))
15             (let ,bindings
16               (with-output-to-string (*standard-output*) (prin1 ,form)))))
17          ,result)
18         t
19       ,result)
20     t))
21
22(defmacro def-pprint-test
23  (name form expected-value
24        &key
25        (margin 100)
26        (miser nil)
27        (circle nil)
28        (len nil)
29        (pretty t)
30        (escape nil)
31        (readably nil)
32        (package (find-package "CL-TEST")))
33  `(deftest ,name
34     (with-standard-io-syntax
35      (let ((*print-pretty* ,pretty)
36            (*print-escape* ,escape)
37            (*print-readably* ,readably)
38            (*print-right-margin* ,margin)
39            (*package* ,package)
40            (*print-length* ,len)
41            (*print-miser-width* ,miser)
42            (*print-circle* ,circle))
43        ,form))
44     ,expected-value))
45
46(defmacro def-ppblock-test (name form expected-value &rest key-args)
47  `(def-pprint-test ,name
48     (with-output-to-string
49       (*standard-output*)
50       (pprint-logical-block (*standard-output* nil) ,form))
51     ,expected-value
52     ,@key-args))
53
54;;; Function to test readable of printed forms, under random settings
55;;; of various printer control variables.
56;;;
57;;; Return NIL if obj printed and read properly, or a list containing
58;;; the object and the printer variable bindings otherwise.  They key
59;;; argument TEST is used to compared the reread object and obj.
60
61(defvar *random-read-check-debug* nil
62  "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter
63   settings before trying a test.  This is intended for cases where the
64   error that occurs is fatal.")
65
66(defun randomly-check-readability (obj &key
67                                       (can-fail nil)
68                                       (test #'equal)
69                                       (readable t)
70                                       (circle nil circle-p)
71                                       (escape nil escape-p)
72                                       (gensym nil gensym-p)
73                                       (debug *random-read-check-debug*))
74  (declare (type function test))
75  ;; Generate random printer-control values
76  (my-with-standard-io-syntax
77   (let ((*print-array* (coin))
78         (*print-base* (+ 2 (random 34)))
79         (*print-radix* (coin))
80         (*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
81         (*print-circle* (if circle-p circle (coin)))
82         (*print-escape* (if escape-p escape (coin)))
83         (*print-gensym* (if gensym-p gensym (coin)))
84         (*print-level* (random 50))
85         (*print-length* (if readable (random 50) nil))
86         (*print-lines* (if readable (random 50) nil))
87         (*print-miser-width* (and (coin) (random 100)))
88         (*print-pretty* (coin))
89         (*print-right-margin* (and (coin) (random 100)))
90         (*print-readably* readable)
91         (*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
92                                             (1 'double-float) (1 'long-float)
93                                             (1 *read-default-float-format*)))
94         (*readtable* (copy-readtable))
95         (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
96         )
97     (flet ((%params ()
98                     (list (list '*print-readably* *print-readably*)
99                           (list '*print-array* *print-array*)
100                           (list '*print-base* *print-base*)
101                           (list '*print-radix* *print-radix*)
102                           (list '*print-case* *print-case*)
103                           (list '*print-circle* *print-circle*)
104                           (list '*print-escape* *print-escape*)
105                           (list '*print-gensym* *print-gensym*)
106                           (list '*print-level* *print-level*)
107                           (list '*print-length* *print-length*)
108                           (list '*print-lines* *print-lines*)
109                           (list '*print-miser-width* *print-miser-width*)
110                           (list '*print-pretty* *print-pretty*)
111                           (list '*print-right-margin* *print-right-margin*)
112                           (list '*read-default-float-format* *read-default-float-format*)
113                           (list 'readtable-case readcase))))
114       (when debug
115         (let ((params (%params)))
116           (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
117         (finish-output *debug-io*))
118       
119       (setf (readtable-case *readtable*) readcase)
120       (let* ((str (handler-case
121                    (with-output-to-string (s) (write obj :stream s))
122                    (print-not-readable
123                     ()
124                     (if can-fail
125                         (return-from randomly-check-readability nil)
126                       ":print-not-readable-error"))))
127              (obj2 (let ((*read-base* *print-base*))
128                      (handler-case
129                       (let ((*readtable* (if *print-readably*
130                                              (copy-readtable nil)
131                                            *readtable*)))
132                         (read-from-string str))
133                       (reader-error () :reader-error)
134                       (end-of-file () :end-of-file)
135                       (stream-error () :stream-error)
136                       (file-error () :file-error)
137                       ))))
138         (unless (funcall test obj obj2)
139           (list
140            (list* obj str obj2 (%params)
141                   ))))))))
142
143(defun parse-escaped-string (string)
144  "Parse a string into a list of either characters (representing
145   themselves unescaped) or lists (<char> :escape) (representing
146   escaped characters.)"
147  (assert (stringp string) () "Not a string: ~A" string)
148  (let ((result nil)
149        (len (length string))
150        (index 0))
151    (prog
152     ()
153     normal ; parsing in normal mode
154     (when (= index len) (return))
155     (let ((c (elt string index)))
156       (cond ((eql c #\\)
157              (assert (< (incf index) len)
158                      ()
159                      "End of string after \\")
160              (push `(,(elt string index) :escaped) result)
161              (incf index)
162              (go normal))
163             ((eql c #\|)
164              (incf index)
165              (go multiple-escaped))
166             (t (push c result)
167                (incf index)
168                (go normal))))
169
170     multiple-escaped   ; parsing inside |s
171     (assert (< index len) () "End of string inside |")
172     (let ((c (elt string index)))
173       (cond ((eq c #\|)
174              (incf index)
175              (go normal))
176             (t
177              (push `(,c :escaped) result)
178              (incf index)
179              (go multiple-escaped)))))
180    (nreverse result)))
181
182(defun escaped-equal (list1 list2)
183  "Determine that everything escaped in list1 is also escaped
184   in list2, and that the characters are also the same."
185  (and (= (length list1) (length list2))
186       (loop for e1 in list1
187             for e2 in list2
188             for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped))
189             for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped))
190             for c1 = (if is-escaped1 (car e1) e1)
191             for c2 = (if is-escaped2 (car e2) e2)
192             always
193             (and (if is-escaped1 is-escaped2 t)
194                  (char= c1 c2)))))
195
196(defun similar-uninterned-symbols (s1 s2)
197  (and (symbolp s1)
198       (symbolp s2)
199       (null (symbol-package s1))
200       (null (symbol-package s2))
201       (string= (symbol-name s1)
202                (symbol-name s2))))
203
204(defun make-random-cons-tree (size)
205  (if (<= size 1)
206      (rcase
207       (5 nil)
208       (1 (random 1000))
209       (1 (random 1000.0))
210       (2 (random-from-seq #(a b c d e f g |1| |2| |.|))))
211    (let ((s1 (1+ (random (1- size)))))
212      (cons (make-random-cons-tree s1)
213            (make-random-cons-tree (- size s1))))))
214
215(defun make-random-vector (size)
216  (if (> size 1)
217      (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4))))))
218             (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems))))
219        (make-array nelems :initial-contents (mapcar #'make-random-vector sizes)))
220    (rcase
221     (1 (random-from-seq #(a b c d e f g)))
222     (1 (- (random 2001) 1000))
223     (1 (random 1000.0))
224     )))
225
226;;; Random printing test for WRITE and related functions
227
228(defun funcall-with-print-bindings
229  (fun &key
230       ((:array *print-array*)                     *print-array*)
231       ((:base *print-base*)                       *print-base*)
232       ((:case *print-case*)                       *print-case*)
233       ((:circle *print-circle*)                   *print-circle*)
234       ((:escape *print-escape*)                   *print-escape*)
235       ((:gensym *print-gensym*)                   *print-gensym*)
236       ((:length *print-length*)                   *print-length*)
237       ((:level *print-level*)                     *print-level*)
238       ((:lines *print-lines*)                     *print-lines*)
239       ((:miser-width *print-miser-width*)         *print-miser-width*)
240       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
241       ((:pretty *print-pretty*)                   *print-pretty*)
242       ((:radix *print-radix*)                     *print-radix*)
243       ((:readably *print-readably*)               *print-readably*)
244       ((:right-margin *print-right-margin*)       *print-right-margin*)
245       ((:stream *standard-output*)                *standard-output*))
246  (funcall fun))
247 
248(defun output-test
249  (obj &key
250       (fun #'write)
251       ((:array *print-array*)                     *print-array*)
252       ((:base *print-base*)                       *print-base*)
253       ((:case *print-case*)                       *print-case*)
254       ((:circle *print-circle*)                   *print-circle*)
255       ((:escape *print-escape*)                   *print-escape*)
256       ((:gensym *print-gensym*)                   *print-gensym*)
257       ((:length *print-length*)                   *print-length*)
258       ((:level *print-level*)                     *print-level*)
259       ((:lines *print-lines*)                     *print-lines*)
260       ((:miser-width *print-miser-width*)         *print-miser-width*)
261       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
262       ((:pretty *print-pretty*)                   *print-pretty*)
263       ((:radix *print-radix*)                     *print-radix*)
264       ((:readably *print-readably*)               *print-readably*)
265       ((:right-margin *print-right-margin*)       *print-right-margin*)
266       ((:stream *standard-output*)                *standard-output*))
267  (let ((results (multiple-value-list (funcall fun obj))))
268    (assert (= (length results) 1))
269    (assert (eql (car results) obj))
270    obj))
271
272(defun make-random-key-param (name)
273  (rcase (1 nil)
274         (1 `(,name nil))
275         (1 `(,name t))))
276
277(defun make-random-key-integer-or-nil-param (name bound)
278  (rcase (1 nil)
279         (1 `(,name nil))
280         (1 `(,name ,(random bound)))))
281
282(defun make-random-write-args ()
283  (let* ((arg-lists `(,@(mapcar #'make-random-key-param
284                                            '(:array :circle :escape :gensym :pretty :radix :readably))
285                                    ,(rcase (1 nil)
286                                            (1 `(:base ,(+ 2 (random 35)))))
287                                    ,(and (coin)
288                                          `(:case ,(random-from-seq #(:upcase :downcase :capitalize))))
289                                    ,@(mapcar #'make-random-key-integer-or-nil-param
290                                              '(:length :level :lines :miser-width :right-margin)
291                                              '(100 20 50 200 200)))))
292                (reduce #'append (random-permute arg-lists) :from-end t)))
293
294(defun filter-unreadable-forms (string)
295  "Find #<...> strings and replace with #<>."
296  (let ((len (length string))
297        (pos 0))
298    (loop while (< pos len)
299          do (let ((next (search "#<" string :start2 pos)))
300               (unless next (return string))
301               (let ((end (position #\> string :start next)))
302                 (unless end (return string))
303                 (setq string
304                       (concatenate 'string
305                                    (subseq string 0 next)
306                                    "#<>"
307                                    (subseq string (1+ end)))
308                       pos (+ next 3)
309                       len (+ len (- next end) 3)))))))
310                       
311
312(defmacro def-random-write-test-fun (name write-args test-fn
313                                          &key
314                                          (prefix "")
315                                          (suffix ""))
316  `(defun ,name (n &key (size 10))
317     (loop
318      for args = (make-random-write-args)
319      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
320      for obj = (let ((*random-readable* t))
321                  (declare (special *random-readable*))
322                  (random-thing (random size)))
323      for s1 = (let ((*package* package))
324                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
325      for s2 = (let ((*package* package))
326                 (with-output-to-string
327                   (*standard-output*)
328                   (apply #'output-test obj :fun ,test-fn args)))
329      repeat n
330      ;; We filter the contents of #<...> forms since they may change with time
331      ;; if they contain object addresses.
332      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
333                      (filter-unreadable-forms s2))
334      collect (list obj s1 s2 args))))
335
336(def-random-write-test-fun random-write-test nil #'write)
337(def-random-write-test-fun random-prin1-test (:escape t) #'prin1)
338(def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ)
339(def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ")
340(def-random-write-test-fun random-pprint-test (:escape t :pretty t)
341  #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj)
342  :prefix (string #\Newline))
343
344(defmacro def-random-write-to-string-test-fun (name write-args test-fn
345                                          &key
346                                          (prefix "")
347                                          (suffix ""))
348  `(defun ,name (n)
349     (loop
350      for args = (make-random-write-args)
351      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
352      for obj = (let ((*random-readable* t))
353                  (declare (special *random-readable*))
354                  (random-thing (random 10)))
355      for s1 = (let ((*package* package))
356                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
357      for s2 = (let ((*package* package))
358                 (apply ,test-fn obj args))
359      repeat n
360      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
361                      (filter-unreadable-forms s2))
362      collect (list obj s1 s2))))
363
364(def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string)
365(def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t)
366  #'(lambda (obj &rest args)
367      (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args)))
368(def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil)
369  #'(lambda (obj &rest args)
370      (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args)))
371
372;;; Routines for testing floating point printing
373
374(defun decode-fixed-decimal-string (s)
375  "Return a rational equal to the number represented by a decimal floating
376   (without exponent).  Trim off leading/trailing spaces."
377
378  (setq s (string-trim " " s))
379  (assert (> (length s) 0))
380  (let (neg)
381    (when (eql (elt s 0) #\-)
382      (setq s (subseq s 1))
383      (setq neg t))
384    ;; Check it's of the form {digits}.{digits}
385    (let ((dot-pos (position #\. s)))
386      (assert dot-pos)
387      (let ((prefix (subseq s 0 dot-pos))
388            (suffix (subseq s (1+ dot-pos))))
389        (assert (every #'digit-char-p prefix))
390        (assert (every #'digit-char-p suffix))
391        (let* ((prefix-len (length prefix))
392               (prefix-integer (if (eql prefix-len 0)
393                                   0
394                                 (parse-integer prefix)))
395               (suffix-len (length suffix))
396               (suffix-integer (if (eql suffix-len 0)
397                                   0
398                                 (parse-integer suffix)))
399               (magnitude (+ prefix-integer
400                             (* suffix-integer (expt 1/10 suffix-len)))))
401          (if neg (- magnitude) magnitude))))))
402
403
404;;; Macro to define both FORMAT and FORMATTER tests
405
406(defmacro def-format-test (name string args expected-output &optional (num-left 0))
407  (assert (symbolp name))
408  (let* ((s (symbol-name name))
409         (expected-prefix (string 'format.))
410         (expected-prefix-length (length expected-prefix)))
411    (assert (>= (length s) expected-prefix-length))
412    (assert (string-equal (subseq s 0 expected-prefix-length)
413                          expected-prefix))
414    (let* ((formatter-test-name-string
415            (concatenate 'string (string 'formatter.)
416                         (subseq s expected-prefix-length)))
417           (formatter-test-name (intern formatter-test-name-string
418                                        (symbol-package name)))
419           (formatter-form (if (stringp string)
420                               `(formatter ,string)
421                             (list 'formatter (eval string)))))
422      `(progn
423         (deftest ,name
424           (with-standard-io-syntax
425            (let ((*print-readably* nil)
426                  (*package* (symbol-package 'ABC)))
427              (format nil ,string ,@args)))
428           ,expected-output)
429         (deftest ,formatter-test-name
430           (let ((fn ,formatter-form)
431                 (args (list ,@args)))
432             (with-standard-io-syntax
433              (let ((*print-readably* nil)
434                    (*package* (symbol-package 'ABC)))
435                (with-output-to-string
436                  (stream)
437                  (let ((tail (apply fn stream args)))
438                    ;; FIXME -- Need to check that TAIL really is a tail of ARGS
439                    (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A"
440                            tail ,num-left)
441                  )))))
442           ,expected-output)))))
443
444;;; Macro used for an idiom in testing FORMATTER calls
445
446(defmacro formatter-call-to-string (fn &body args)
447  (let ((stream (gensym "S")))
448    `(with-output-to-string
449       (,stream)
450       (assert (equal (funcall ,fn ,stream ,@args 'a) '(a))))))
Note: See TracBrowser for help on using the repository browser.