printer-aux.lsp 19 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Feb 23 06:20:00 2004
;;;; Contains: Auxiliary functions and macros for printer tests

(in-package :cl-test)

8
(eval-when (:compile-toplevel :load-toplevel :execute) (compile-and-load "random-aux.lsp"))
9

pfdietz's avatar
pfdietz committed
10 11
(defmacro def-print-test (name form result &rest bindings)
  `(deftest ,name
12
     (if (equalpt
sds's avatar
sds committed
13 14 15 16 17 18
          (my-with-standard-io-syntax
           (let ((*print-readably* nil))
             (let ,bindings
               (with-output-to-string (*standard-output*) (prin1 ,form)))))
          ,result)
         t
19
       ,result)
pfdietz's avatar
pfdietz committed
20
     t))
21

22 23
(defmacro def-pprint-test
  (name form expected-value
sds's avatar
sds committed
24 25 26 27 28 29 30 31 32
        &key
        (margin 100)
        (miser nil)
        (circle nil)
        (len nil)
        (pretty t)
        (escape nil)
        (readably nil)
        (package (find-package "CL-TEST")))
33 34 35
  `(deftest ,name
     (with-standard-io-syntax
      (let ((*print-pretty* ,pretty)
sds's avatar
sds committed
36 37 38 39 40 41 42 43
            (*print-escape* ,escape)
            (*print-readably* ,readably)
            (*print-right-margin* ,margin)
            (*package* ,package)
            (*print-length* ,len)
            (*print-miser-width* ,miser)
            (*print-circle* ,circle))
        ,form))
44 45
     ,expected-value))

pfdietz's avatar
pfdietz committed
46 47 48 49 50 51 52
(defmacro def-ppblock-test (name form expected-value &rest key-args)
  `(def-pprint-test ,name
     (with-output-to-string
       (*standard-output*)
       (pprint-logical-block (*standard-output* nil) ,form))
     ,expected-value
     ,@key-args))
53

54 55 56 57 58 59 60
;;; Function to test readable of printed forms, under random settings
;;; of various printer control variables.
;;;
;;; Return NIL if obj printed and read properly, or a list containing
;;; the object and the printer variable bindings otherwise.  They key
;;; argument TEST is used to compared the reread object and obj.

61
(defvar *random-read-check-debug* nil
62 63 64 65
  "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter
   settings before trying a test.  This is intended for cases where the
   error that occurs is fatal.")

camm's avatar
camm committed
66
(defun randomly-check-readability (obj &key
sds's avatar
sds committed
67 68 69 70 71 72 73
                                       (can-fail nil)
                                       (test #'equal)
                                       (readable t)
                                       (circle nil circle-p)
                                       (escape nil escape-p)
                                       (gensym nil gensym-p)
                                       (debug *random-read-check-debug*))
camm's avatar
camm committed
74 75 76 77
  (declare (type function test))
  ;; Generate random printer-control values
  (my-with-standard-io-syntax
   (let ((*print-array* (coin))
sds's avatar
sds committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
         (*print-base* (+ 2 (random 34)))
         (*print-radix* (coin))
         (*print-case* (random-from-seq #(:upcase :downcase :capitalize)))
         (*print-circle* (if circle-p circle (coin)))
         (*print-escape* (if escape-p escape (coin)))
         (*print-gensym* (if gensym-p gensym (coin)))
         (*print-level* (random 50))
         (*print-length* (if readable (random 50) nil))
         (*print-lines* (if readable (random 50) nil))
         (*print-miser-width* (and (coin) (random 100)))
         (*print-pretty* (coin))
         (*print-right-margin* (and (coin) (random 100)))
         (*print-readably* readable)
         (*read-default-float-format* (rcase (1 'short-float) (1 'single-float)
                                             (1 'double-float) (1 'long-float)
                                             (1 *read-default-float-format*)))
         (*readtable* (copy-readtable))
         (readcase (random-from-seq #(:upcase :downcase :preserve :invert)))
         )
camm's avatar
camm committed
97
     (flet ((%params ()
sds's avatar
sds committed
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
                     (list (list '*print-readably* *print-readably*)
                           (list '*print-array* *print-array*)
                           (list '*print-base* *print-base*)
                           (list '*print-radix* *print-radix*)
                           (list '*print-case* *print-case*)
                           (list '*print-circle* *print-circle*)
                           (list '*print-escape* *print-escape*)
                           (list '*print-gensym* *print-gensym*)
                           (list '*print-level* *print-level*)
                           (list '*print-length* *print-length*)
                           (list '*print-lines* *print-lines*)
                           (list '*print-miser-width* *print-miser-width*)
                           (list '*print-pretty* *print-pretty*)
                           (list '*print-right-margin* *print-right-margin*)
                           (list '*read-default-float-format* *read-default-float-format*)
                           (list 'readtable-case readcase))))
camm's avatar
camm committed
114
       (when debug
sds's avatar
sds committed
115 116 117 118
         (let ((params (%params)))
           (with-standard-io-syntax (format *debug-io* "~%~A~%" params)))
         (finish-output *debug-io*))

119
       (setf (readtable-case *readtable*) readcase)
camm's avatar
camm committed
120
       (let* ((str (handler-case
sds's avatar
sds committed
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
                    (with-output-to-string (s) (write obj :stream s))
                    (print-not-readable
                     ()
                     (if can-fail
                         (return-from randomly-check-readability nil)
                       ":print-not-readable-error"))))
              (obj2 (let ((*read-base* *print-base*))
                      (handler-case
                       (let ((*readtable* (if *print-readably*
                                              (copy-readtable nil)
                                            *readtable*)))
                         (read-from-string str))
                       (reader-error () :reader-error)
                       (end-of-file () :end-of-file)
                       (stream-error () :stream-error)
                       (file-error () :file-error)
                       ))))
         (unless (funcall test obj obj2)
           (list
            (list* obj str obj2 (%params)
                   ))))))))
142 143 144 145 146 147 148

(defun parse-escaped-string (string)
  "Parse a string into a list of either characters (representing
   themselves unescaped) or lists (<char> :escape) (representing
   escaped characters.)"
  (assert (stringp string) () "Not a string: ~A" string)
  (let ((result nil)
sds's avatar
sds committed
149 150
        (len (length string))
        (index 0))
151 152 153 154 155 156
    (prog
     ()
     normal ; parsing in normal mode
     (when (= index len) (return))
     (let ((c (elt string index)))
       (cond ((eql c #\\)
sds's avatar
sds committed
157 158 159 160 161 162 163 164 165 166 167 168
              (assert (< (incf index) len)
                      ()
                      "End of string after \\")
              (push `(,(elt string index) :escaped) result)
              (incf index)
              (go normal))
             ((eql c #\|)
              (incf index)
              (go multiple-escaped))
             (t (push c result)
                (incf index)
                (go normal))))
169 170 171 172 173

     multiple-escaped   ; parsing inside |s
     (assert (< index len) () "End of string inside |")
     (let ((c (elt string index)))
       (cond ((eq c #\|)
sds's avatar
sds committed
174 175 176 177 178 179
              (incf index)
              (go normal))
             (t
              (push `(,c :escaped) result)
              (incf index)
              (go multiple-escaped)))))
180 181 182 183 184 185 186
    (nreverse result)))

(defun escaped-equal (list1 list2)
  "Determine that everything escaped in list1 is also escaped
   in list2, and that the characters are also the same."
  (and (= (length list1) (length list2))
       (loop for e1 in list1
sds's avatar
sds committed
187 188 189 190 191 192 193 194
             for e2 in list2
             for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped))
             for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped))
             for c1 = (if is-escaped1 (car e1) e1)
             for c2 = (if is-escaped2 (car e2) e2)
             always
             (and (if is-escaped1 is-escaped2 t)
                  (char= c1 c2)))))
195 196 197 198 199 200 201

(defun similar-uninterned-symbols (s1 s2)
  (and (symbolp s1)
       (symbolp s2)
       (null (symbol-package s1))
       (null (symbol-package s2))
       (string= (symbol-name s1)
sds's avatar
sds committed
202
                (symbol-name s2))))
pfdietz's avatar
pfdietz committed
203 204 205 206 207 208 209 210 211 212

(defun make-random-cons-tree (size)
  (if (<= size 1)
      (rcase
       (5 nil)
       (1 (random 1000))
       (1 (random 1000.0))
       (2 (random-from-seq #(a b c d e f g |1| |2| |.|))))
    (let ((s1 (1+ (random (1- size)))))
      (cons (make-random-cons-tree s1)
sds's avatar
sds committed
213
            (make-random-cons-tree (- size s1))))))
pfdietz's avatar
pfdietz committed
214

pfdietz's avatar
pfdietz committed
215 216 217
(defun make-random-vector (size)
  (if (> size 1)
      (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4))))))
sds's avatar
sds committed
218 219
             (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems))))
        (make-array nelems :initial-contents (mapcar #'make-random-vector sizes)))
pfdietz's avatar
pfdietz committed
220 221 222 223 224
    (rcase
     (1 (random-from-seq #(a b c d e f g)))
     (1 (- (random 2001) 1000))
     (1 (random 1000.0))
     )))
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246

;;; Random printing test for WRITE and related functions

(defun funcall-with-print-bindings
  (fun &key
       ((:array *print-array*)                     *print-array*)
       ((:base *print-base*)                       *print-base*)
       ((:case *print-case*)                       *print-case*)
       ((:circle *print-circle*)                   *print-circle*)
       ((:escape *print-escape*)                   *print-escape*)
       ((:gensym *print-gensym*)                   *print-gensym*)
       ((:length *print-length*)                   *print-length*)
       ((:level *print-level*)                     *print-level*)
       ((:lines *print-lines*)                     *print-lines*)
       ((:miser-width *print-miser-width*)         *print-miser-width*)
       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
       ((:pretty *print-pretty*)                   *print-pretty*)
       ((:radix *print-radix*)                     *print-radix*)
       ((:readably *print-readably*)               *print-readably*)
       ((:right-margin *print-right-margin*)       *print-right-margin*)
       ((:stream *standard-output*)                *standard-output*))
  (funcall fun))
sds's avatar
sds committed
247

248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266
(defun output-test
  (obj &key
       (fun #'write)
       ((:array *print-array*)                     *print-array*)
       ((:base *print-base*)                       *print-base*)
       ((:case *print-case*)                       *print-case*)
       ((:circle *print-circle*)                   *print-circle*)
       ((:escape *print-escape*)                   *print-escape*)
       ((:gensym *print-gensym*)                   *print-gensym*)
       ((:length *print-length*)                   *print-length*)
       ((:level *print-level*)                     *print-level*)
       ((:lines *print-lines*)                     *print-lines*)
       ((:miser-width *print-miser-width*)         *print-miser-width*)
       ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)
       ((:pretty *print-pretty*)                   *print-pretty*)
       ((:radix *print-radix*)                     *print-radix*)
       ((:readably *print-readably*)               *print-readably*)
       ((:right-margin *print-right-margin*)       *print-right-margin*)
       ((:stream *standard-output*)                *standard-output*))
267
  (let ((results (multiple-value-list (funcall fun obj))))
268 269 270 271 272 273
    (assert (= (length results) 1))
    (assert (eql (car results) obj))
    obj))

(defun make-random-key-param (name)
  (rcase (1 nil)
sds's avatar
sds committed
274 275
         (1 `(,name nil))
         (1 `(,name t))))
276 277 278

(defun make-random-key-integer-or-nil-param (name bound)
  (rcase (1 nil)
sds's avatar
sds committed
279 280
         (1 `(,name nil))
         (1 `(,name ,(random bound)))))
281 282 283

(defun make-random-write-args ()
  (let* ((arg-lists `(,@(mapcar #'make-random-key-param
sds's avatar
sds committed
284 285 286 287 288 289 290 291 292
                                            '(:array :circle :escape :gensym :pretty :radix :readably))
                                    ,(rcase (1 nil)
                                            (1 `(:base ,(+ 2 (random 35)))))
                                    ,(and (coin)
                                          `(:case ,(random-from-seq #(:upcase :downcase :capitalize))))
                                    ,@(mapcar #'make-random-key-integer-or-nil-param
                                              '(:length :level :lines :miser-width :right-margin)
                                              '(100 20 50 200 200)))))
                (reduce #'append (random-permute arg-lists) :from-end t)))
293

294 295 296
(defun filter-unreadable-forms (string)
  "Find #<...> strings and replace with #<>."
  (let ((len (length string))
sds's avatar
sds committed
297
        (pos 0))
298
    (loop while (< pos len)
sds's avatar
sds committed
299 300 301 302 303 304 305 306 307 308 309 310
          do (let ((next (search "#<" string :start2 pos)))
               (unless next (return string))
               (let ((end (position #\> string :start next)))
                 (unless end (return string))
                 (setq string
                       (concatenate 'string
                                    (subseq string 0 next)
                                    "#<>"
                                    (subseq string (1+ end)))
                       pos (+ next 3)
                       len (+ len (- next end) 3)))))))

311

312
(defmacro def-random-write-test-fun (name write-args test-fn
sds's avatar
sds committed
313 314 315
                                          &key
                                          (prefix "")
                                          (suffix ""))
316
  `(defun ,name (n &key (size 10))
317 318 319
     (loop
      for args = (make-random-write-args)
      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
320
      for obj = (let ((*random-readable* t))
sds's avatar
sds committed
321 322
                  (declare (special *random-readable*))
                  (random-thing (random size)))
323
      for s1 = (let ((*package* package))
sds's avatar
sds committed
324
                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
325
      for s2 = (let ((*package* package))
sds's avatar
sds committed
326 327 328
                 (with-output-to-string
                   (*standard-output*)
                   (apply #'output-test obj :fun ,test-fn args)))
329
      repeat n
330 331 332
      ;; We filter the contents of #<...> forms since they may change with time
      ;; if they contain object addresses.
      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
sds's avatar
sds committed
333
                      (filter-unreadable-forms s2))
334
      collect (list obj s1 s2 args))))
335 336 337 338 339 340 341 342 343 344

(def-random-write-test-fun random-write-test nil #'write)
(def-random-write-test-fun random-prin1-test (:escape t) #'prin1)
(def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ)
(def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ")
(def-random-write-test-fun random-pprint-test (:escape t :pretty t)
  #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj)
  :prefix (string #\Newline))

(defmacro def-random-write-to-string-test-fun (name write-args test-fn
sds's avatar
sds committed
345 346 347
                                          &key
                                          (prefix "")
                                          (suffix ""))
348 349 350 351
  `(defun ,name (n)
     (loop
      for args = (make-random-write-args)
      for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD")))
352
      for obj = (let ((*random-readable* t))
sds's avatar
sds committed
353 354
                  (declare (special *random-readable*))
                  (random-thing (random 10)))
355
      for s1 = (let ((*package* package))
sds's avatar
sds committed
356
                 (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args)))
357
      for s2 = (let ((*package* package))
sds's avatar
sds committed
358
                 (apply ,test-fn obj args))
359
      repeat n
360
      unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix))
sds's avatar
sds committed
361
                      (filter-unreadable-forms s2))
362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387
      collect (list obj s1 s2))))

(def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string)
(def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t)
  #'(lambda (obj &rest args)
      (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args)))
(def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil)
  #'(lambda (obj &rest args)
      (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args)))

;;; Routines for testing floating point printing

(defun decode-fixed-decimal-string (s)
  "Return a rational equal to the number represented by a decimal floating
   (without exponent).  Trim off leading/trailing spaces."

  (setq s (string-trim " " s))
  (assert (> (length s) 0))
  (let (neg)
    (when (eql (elt s 0) #\-)
      (setq s (subseq s 1))
      (setq neg t))
    ;; Check it's of the form {digits}.{digits}
    (let ((dot-pos (position #\. s)))
      (assert dot-pos)
      (let ((prefix (subseq s 0 dot-pos))
sds's avatar
sds committed
388 389 390 391 392 393 394 395 396 397 398 399 400 401
            (suffix (subseq s (1+ dot-pos))))
        (assert (every #'digit-char-p prefix))
        (assert (every #'digit-char-p suffix))
        (let* ((prefix-len (length prefix))
               (prefix-integer (if (eql prefix-len 0)
                                   0
                                 (parse-integer prefix)))
               (suffix-len (length suffix))
               (suffix-integer (if (eql suffix-len 0)
                                   0
                                 (parse-integer suffix)))
               (magnitude (+ prefix-integer
                             (* suffix-integer (expt 1/10 suffix-len)))))
          (if neg (- magnitude) magnitude))))))
402

403 404 405

;;; Macro to define both FORMAT and FORMATTER tests

406
(defmacro def-format-test (name string args expected-output &optional (num-left 0))
407 408
  (assert (symbolp name))
  (let* ((s (symbol-name name))
sds's avatar
sds committed
409 410
         (expected-prefix (string 'format.))
         (expected-prefix-length (length expected-prefix)))
411 412
    (assert (>= (length s) expected-prefix-length))
    (assert (string-equal (subseq s 0 expected-prefix-length)
sds's avatar
sds committed
413
                          expected-prefix))
414
    (let* ((formatter-test-name-string
sds's avatar
sds committed
415 416 417 418 419 420 421
            (concatenate 'string (string 'formatter.)
                         (subseq s expected-prefix-length)))
           (formatter-test-name (intern formatter-test-name-string
                                        (symbol-package name)))
           (formatter-form (if (stringp string)
                               `(formatter ,string)
                             (list 'formatter (eval string)))))
422
      `(progn
sds's avatar
sds committed
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
         (deftest ,name
           (with-standard-io-syntax
            (let ((*print-readably* nil)
                  (*package* (symbol-package 'ABC)))
              (format nil ,string ,@args)))
           ,expected-output)
         (deftest ,formatter-test-name
           (let ((fn ,formatter-form)
                 (args (list ,@args)))
             (with-standard-io-syntax
              (let ((*print-readably* nil)
                    (*package* (symbol-package 'ABC)))
                (with-output-to-string
                  (stream)
                  (let ((tail (apply fn stream args)))
                    ;; FIXME -- Need to check that TAIL really is a tail of ARGS
                    (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A"
                            tail ,num-left)
                  )))))
           ,expected-output)))))
443 444 445 446 447 448 449 450

;;; Macro used for an idiom in testing FORMATTER calls

(defmacro formatter-call-to-string (fn &body args)
  (let ((stream (gensym "S")))
    `(with-output-to-string
       (,stream)
       (assert (equal (funcall ,fn ,stream ,@args 'a) '(a))))))