print-unreadable-object.lsp 4.82 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Jul 12 06:06:01 2004
;;;; Contains: Tests of PRINT-UNREADABLE-OBJECT

(in-package :cl-test)

(compile-and-load "printer-aux.lsp")

(def-pprint-test print-unreadable-object.1
  (loop
   for x in *mini-universe*
   for return-vals = nil
   for s = (with-output-to-string
sds's avatar
sds committed
15 16 17
             (s)
             (setq return-vals
                   (multiple-value-list (print-unreadable-object (x s)))))
18
   unless (and (equal return-vals '(nil))
sds's avatar
sds committed
19
               (equal s "#<>"))
20 21 22 23 24 25 26 27 28
   collect (list x return-vals s))
  nil)

(def-pprint-test print-unreadable-object.2
  (loop
   for x in *mini-universe*
   for return-vals1 = nil
   for return-vals2 = nil
   for s1 = (with-output-to-string
sds's avatar
sds committed
29 30 31 32
              (s)
              (setq return-vals1
                    (multiple-value-list (print-unreadable-object
                                          (x s :type t)))))
33
   for s2 = (with-output-to-string
sds's avatar
sds committed
34 35 36 37 38
              (s)
              (setq return-vals2
                    (multiple-value-list (print-unreadable-object
                                          (x s :type t)
                                          (write-char #\X s)))))
39
   unless (and (equal return-vals1 '(nil))
sds's avatar
sds committed
40 41 42 43 44
               (equal return-vals2 '(nil))
               (string= s1 "#<" :end1 2)
               (string= s1 s2 :end1 (- (length s1) 1)
                        :end2 (- (length s2) 2))
               (string= s2 " X>" :start1 (- (length s2) 3)))
45 46 47 48 49 50 51 52 53
   collect (list x return-vals1 return-vals2 s1 s2))
  nil)

(def-pprint-test print-unreadable-object.3
  (loop
   for x in *mini-universe*
   for return-vals1 = nil
   for return-vals2 = nil
   for s1 = (with-output-to-string
sds's avatar
sds committed
54 55 56 57 58 59 60
              (s)
              (setq return-vals1
                    (multiple-value-list (print-unreadable-object
                                          (x s :identity t)
                                          (write "FOO" :stream s)
                                          (values 1 2 3 4 5) ;; test if this is ignored
                                          ))))
61
   for s2 = (with-output-to-string
sds's avatar
sds committed
62 63 64 65 66
              (s)
              (setq return-vals2
                    (multiple-value-list (print-unreadable-object
                                          (x s :identity t)
                                          ))))
67
   unless (and (equal return-vals1 '(nil))
sds's avatar
sds committed
68 69 70 71 72 73
               (equal return-vals2 '(nil))
               (string= s1 "#<FOO " :end1 6)
               (string= s2 "#< " :end1 3)
               (eql (char s1 (1- (length s1))) #\>)
               (eql (char s2 (1- (length s2))) #\>)
               (string= s1 s2 :start2 3 :start1 6))
74 75 76 77 78 79
   collect (list x return-vals1 return-vals2 s1 s2))
  nil)

(def-pprint-test print-unreadable-object.4
  (loop
   for x in *mini-universe*
80
   for return-vals = nil
81
   for s = (with-output-to-string
sds's avatar
sds committed
82 83 84 85 86 87 88
             (s)
             (setq return-vals
                   (multiple-value-list (print-unreadable-object
                                         (x s :identity t :type t)
                                         (write "FOO" :stream s)
                                         (values) ;; test if this is ignored
                                         ))))
89
   unless (and (equal return-vals '(nil))
sds's avatar
sds committed
90 91 92
               (string= s "#<" :end1 2)
               (eql (char s (1- (length s))) #\>)
               (>= (count #\Space s) 2))
93 94 95
   collect (list x return-vals s))
  nil)

pfdietz's avatar
pfdietz committed
96 97 98 99 100 101
;;; TODO Tests that the :identity and :type arguments are evaluated
;;; TODO Tests where :type, :identity are provided, but are nil
;;; TODO Test that the type/identity parts of the output are the same
;;;       for the both-printed case as they are in the only-one printed case,
;;;       and that only a single space occurs between them if FORMS is omitted.

102 103 104 105 106 107
;;; Error cases

(deftest print-unreadable-object.error.1
  (with-standard-io-syntax
   (let ((*print-readably* t))
     (loop for x in *mini-universe*
sds's avatar
sds committed
108 109 110 111 112 113 114
           for form = `(with-output-to-string
                         (*standard-output*)
                         (assert (signals-error
                                  (print-unreadable-object (',x *standard-output*))
                                  print-not-readable)))
           unless (equal (eval form) "")
           collect x)))
115 116 117 118 119 120 121 122 123 124 125 126
  nil)

;;; Stream designators

(deftest print-unreadable-object.t.1
  (with-output-to-string
    (os)
    (with-input-from-string
     (is "")
     (with-open-stream
      (*terminal-io* (make-two-way-stream is os))
      (let ((*print-readably* nil))
sds's avatar
sds committed
127 128 129
        (assert
         (equal (multiple-value-list (print-unreadable-object (1 t)))
                '(nil)))))))
130 131 132 133 134 135 136 137
  "#<>")

(deftest print-unreadable-object.nil.1
  (with-output-to-string
    (*standard-output*)
    (let ((*print-readably* nil))
      (assert
       (equal (multiple-value-list (print-unreadable-object (1 nil)))
sds's avatar
sds committed
138
              '(nil)))))
139 140 141
  "#<>")