source: trunk/source/tests/ansi-tests/print-unreadable-object.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: 3.9 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               (string= s1 s2 :end1 (- (length s1) 1)
43                        :end2 (- (length s2) 2))
44               (string= s2 " X>" :start1 (- (length s2) 3)))
45   collect (list x return-vals1 return-vals2 s1 s2))
46  nil)
47
48(def-pprint-test print-unreadable-object.3
49  (loop
50   for x in *mini-universe*
51   for return-vals1 = nil
52   for return-vals2 = nil
53   for s1 = (with-output-to-string
54              (s)
55              (setq return-vals1
56                    (multiple-value-list (print-unreadable-object
57                                          (x s :identity t)
58                                          (write "FOO" :stream s)
59                                          (values 1 2 3 4 5) ;; test if this is ignored
60                                          ))))
61   for s2 = (with-output-to-string
62              (s)
63              (setq return-vals2
64                    (multiple-value-list (print-unreadable-object
65                                          (x s :identity t)
66                                          ))))
67   unless (and (equal return-vals1 '(nil))
68               (equal return-vals2 '(nil))
69               (string= s1 "#<FOO " :end1 6)
70               (string= s2 "#< " :end1 3)
71               (eql (char s1 (1- (length s1))) #\>)
72               (eql (char s2 (1- (length s2))) #\>)
73               (string= s1 s2 :start2 3 :start1 6))
74   collect (list x return-vals1 return-vals2 s1 s2))
75  nil)
76
77(def-pprint-test print-unreadable-object.4
78  (loop
79   for x in *mini-universe*
80   for return-vals = nil
81   for s = (with-output-to-string
82             (s)
83             (setq return-vals
84                   (multiple-value-list (print-unreadable-object
85                                         (x s :identity t :type t)
86                                         (write "FOO" :stream s)
87                                         (values) ;; test if this is ignored
88                                         ))))
89   unless (and (equal return-vals '(nil))
90               (string= s "#<" :end1 2)
91               (eql (char s (1- (length s))) #\>)
92               (>= (count #\Space s) 2))
93   collect (list x return-vals s))
94  nil)
95
96;;; TODO Tests that the :identity and :type arguments are evaluated
97;;; TODO Tests where :type, :identity are provided, but are nil
98;;; TODO Test that the type/identity parts of the output are the same
99;;;       for the both-printed case as they are in the only-one printed case,
100;;;       and that only a single space occurs between them if FORMS is omitted.
101
102;;; Error cases
103
104(deftest print-unreadable-object.error.1
105  (with-standard-io-syntax
106   (let ((*print-readably* t))
107     (loop for x in *mini-universe*
108           for form = `(with-output-to-string
109                         (*standard-output*)
110                         (assert (signals-error
111                                  (print-unreadable-object (',x *standard-output*))
112                                  print-not-readable)))
113           unless (equal (eval form) "")
114           collect x)))
115  nil)
116
117;;; Stream designators
118
119(deftest print-unreadable-object.t.1
120  (with-output-to-string
121    (os)
122    (with-input-from-string
123     (is "")
124     (with-open-stream
125      (*terminal-io* (make-two-way-stream is os))
126      (let ((*print-readably* nil))
127        (assert
128         (equal (multiple-value-list (print-unreadable-object (1 t)))
129                '(nil)))))))
130  "#<>")
131
132(deftest print-unreadable-object.nil.1
133  (with-output-to-string
134    (*standard-output*)
135    (let ((*print-readably* nil))
136      (assert
137       (equal (multiple-value-list (print-unreadable-object (1 nil)))
138              '(nil)))))
139  "#<>")
140
141
Note: See TracBrowser for help on using the repository browser.