source: trunk/tests/ansi-tests/print-unreadable-object.lsp @ 10943

Last change on this file since 10943 was 10768, checked in by rme, 12 years ago

In PRINT-UNREADABLE-OBJECT.2, mark the form that tests for output of
the form #<SOME-TYPE > (note space) as bogus.

I suppose I can see how a pedantic reading of the spec could lead to
this conclusion, but since the spec also implies that the precise
format of stuff between "#<" and ">" is implementation-dependent, it's
hard for me to agree. It's not like programs can portably rely on the
output of PRINT-UNREADABLE-OBJECT anyway. In the case above, it just
looks stupid. (I mean, if it's valid to omit the body forms, then it
stands to reason that it's valid to omit the extra spaces that would
normally delimit the output from the body forms. Sheesh.)

File size: 4.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Jul 12 06:06:01 2004
4;;;; Contains: Tests of PRINT-UNREADABLE-OBJECT
5
6(in-package :cl-test)
7
8(compile-and-load "printer-aux.lsp")
9
10(def-pprint-test print-unreadable-object.1
11  (loop
12   for x in *mini-universe*
13   for return-vals = nil
14   for s = (with-output-to-string
15             (s)
16             (setq return-vals
17                   (multiple-value-list (print-unreadable-object (x s)))))
18   unless (and (equal return-vals '(nil))
19               (equal s "#<>"))
20   collect (list x return-vals s))
21  nil)
22
23(def-pprint-test print-unreadable-object.2
24  (loop
25   for x in *mini-universe*
26   for return-vals1 = nil
27   for return-vals2 = nil
28   for s1 = (with-output-to-string
29              (s)
30              (setq return-vals1
31                    (multiple-value-list (print-unreadable-object
32                                          (x s :type t)))))
33   for s2 = (with-output-to-string
34              (s)
35              (setq return-vals2
36                    (multiple-value-list (print-unreadable-object
37                                          (x s :type t)
38                                          (write-char #\X s)))))
39   unless (and (equal return-vals1 '(nil))
40               (equal return-vals2 '(nil))
41               (string= s1 "#<" :end1 2)
42               #+bogus-test
43               (string= s1 s2 :end1 (- (length s1) 1)
44                        :end2 (- (length s2) 2))
45               (string= s2 " X>" :start1 (- (length s2) 3)))
46   collect (list x return-vals1 return-vals2 s1 s2))
47  nil)
48
49(def-pprint-test print-unreadable-object.3
50  (loop
51   for x in *mini-universe*
52   for return-vals1 = nil
53   for return-vals2 = nil
54   for s1 = (with-output-to-string
55              (s)
56              (setq return-vals1
57                    (multiple-value-list (print-unreadable-object
58                                          (x s :identity t)
59                                          (write "FOO" :stream s)
60                                          (values 1 2 3 4 5) ;; test if this is ignored
61                                          ))))
62   for s2 = (with-output-to-string
63              (s)
64              (setq return-vals2
65                    (multiple-value-list (print-unreadable-object
66                                          (x s :identity t)
67                                          ))))
68   unless (and (equal return-vals1 '(nil))
69               (equal return-vals2 '(nil))
70               (string= s1 "#<FOO " :end1 6)
71               (string= s2 "#< " :end1 3)
72               (eql (char s1 (1- (length s1))) #\>)
73               (eql (char s2 (1- (length s2))) #\>)
74               (string= s1 s2 :start2 3 :start1 6))
75   collect (list x return-vals1 return-vals2 s1 s2))
76  nil)
77
78(def-pprint-test print-unreadable-object.4
79  (loop
80   for x in *mini-universe*
81   for return-vals = nil
82   for s = (with-output-to-string
83             (s)
84             (setq return-vals
85                   (multiple-value-list (print-unreadable-object
86                                         (x s :identity t :type t)
87                                         (write "FOO" :stream s)
88                                         (values) ;; test if this is ignored
89                                         ))))
90   unless (and (equal return-vals '(nil))
91               (string= s "#<" :end1 2)
92               (eql (char s (1- (length s))) #\>)
93               (>= (count #\Space s) 2))
94   collect (list x return-vals s))
95  nil)
96
97;;; TODO Tests that the :identity and :type arguments are evaluated
98;;; TODO Tests where :type, :identity are provided, but are nil
99;;; TODO Test that the type/identity parts of the output are the same
100;;;       for the both-printed case as they are in the only-one printed case,
101;;;       and that only a single space occurs between them if FORMS is omitted.
102
103;;; Error cases
104
105(deftest print-unreadable-object.error.1
106  (with-standard-io-syntax
107   (let ((*print-readably* t))
108     (loop for x in *mini-universe*
109           for form = `(with-output-to-string
110                         (*standard-output*)
111                         (assert (signals-error
112                                  (print-unreadable-object (',x *standard-output*))
113                                  print-not-readable)))
114           unless (equal (eval form) "")
115           collect x)))
116  nil)
117
118;;; Stream designators
119
120(deftest print-unreadable-object.t.1
121  (with-output-to-string
122    (os)
123    (with-input-from-string
124     (is "")
125     (with-open-stream
126      (*terminal-io* (make-two-way-stream is os))
127      (let ((*print-readably* nil))
128        (assert
129         (equal (multiple-value-list (print-unreadable-object (1 t)))
130                '(nil)))))))
131  "#<>")
132
133(deftest print-unreadable-object.nil.1
134  (with-output-to-string
135    (*standard-output*)
136    (let ((*print-readably* nil))
137      (assert
138       (equal (multiple-value-list (print-unreadable-object (1 nil)))
139              '(nil)))))
140  "#<>")
141
142
Note: See TracBrowser for help on using the repository browser.