1 ;;;; This file is for testing bivalent stream functionality, using
2 ;;;; test machinery which might have side effects (e.g. executing
3 ;;;; DEFUN, writing files). Note that the tests here might reach into
4 ;;;; unexported functionality, and should not be used as a guide for
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
18 ;;; Test character decode restarts.
20 (defun bvector (&rest elements
)
21 (make-array (length elements
) :element-type
'(unsigned-byte 8)
22 :initial-contents elements
))
24 (defun cvector (&rest elements
)
25 (make-array (length elements
) :element-type
'character
26 :initial-contents elements
))
28 (defmacro with-bivalent-io-setup
((file) &body body
)
29 (let ((file-var (gensym)))
30 `(let ((,file-var
,file
))
33 ((with-stream ((stream &rest args
&key
&allow-other-keys
) &body body
)
34 `(with-open-file (,stream
,',file-var
,@args
35 :element-type
:default
:external-format
:utf-8
)
38 (when (probe-file ,file-var
)
39 (delete-file ,file-var
))))))
41 (defun assert-roundtrip (write-call read-call result expected
)
42 (unless (equalp result expected
)
43 (error "~@<Writing via ~S and reading back via ~S produced ~S, ~
45 write-call read-call result expected
)))
47 (with-test (:name
(stream :bivalent
:roundtrip
:element
))
48 (let ((pairs '((write-byte 65 read-char
#\A
)
49 (write-char #\B read-byte
66)
50 (write-byte #xe0 read-byte
#xe0
)
51 (write-char #\C read-char
#\C
))))
52 (with-bivalent-io-setup ("bivalent-stream-test.txt")
53 (with-stream (stream :direction
:output
:if-exists
:supersede
)
54 (loop :for
(function argument
) :in pairs
55 :do
(funcall function argument stream
)))
57 (with-stream (stream :direction
:input
)
58 (loop :for
(write-function write-arg read-function expected
) :in pairs
59 :do
(let ((result (funcall read-function stream
)))
60 (assert-roundtrip `(,write-function
,write-arg
)
62 result expected
)))))))
64 (with-test (:name
(stream :bivalent
:roundtrip sequence
))
66 `(;; List source and destination sequence.
67 ((65) () ,(list 0) () 1 (#\A
))
68 ((#\B
) () ,(list 0) () 1 (#\B
))
69 ((#x7e
) () ,(list 0) () 1 (,(code-char #x7e
)))
70 ((66 #\C
) () ,(list 0 0) () 2 (#\B
#\C
))
71 ((#\B
67) () ,(list 0 0) () 2 (#\B
#\C
))
72 ((#\B
#\C
) (:start
1) ,(list 0) () 1 (#\C
))
73 ((#\B
#\C
) (:end
1) ,(list 0) () 1 (#\B
))
74 ((#\B
) () ,(list 0 0) (:start
1) 2 (0 #\B
))
75 ((#\B
) () ,(list 0 0) (:end
1) 1 (#\B
0))
76 ;; Vector source sequence.
77 (#(65) () ,(list 0) () 1 (#\A
))
78 (#(#\B
) () ,(list 0) () 1 (#\B
))
79 (#(#x7e
) () ,(list 0) () 1 (,(code-char #x7e
)))
80 (#(66 #\C
) () ,(list 0 0) () 2 (#\B
#\C
))
81 (#(#\B
67) () ,(list 0 0) () 2 (#\B
#\C
))
82 (#(#\B
#\C
) (:end
1) ,(list 0) () 1 (#\B
))
83 (#(#\B
#\C
) (:start
1) ,(list 0) () 1 (#\C
))
84 ;; String source sequence.
85 ("A" () ,(list 0) () 1 (#\A
))
86 ("B" () ,(list 0) () 1 (#\B
))
87 ("BC" (:start
1) ,(list 0) () 1 (#\C
))
88 ("BC" (:end
1) ,(list 0) () 1 (#\B
))
89 ;; Generic vector destination sequence.
90 (#(65) () ,(vector 0) () 1 #(#\A
))
91 (#(#\B
) () ,(vector 0) () 1 #(#\B
))
92 (#(#x7e
) () ,(vector 0) () 1 #(,(code-char #x7e
)))
93 (#(66 #\C
) () ,(vector 0 0) () 2 #(#\B
#\C
))
94 (#(#\B
67) () ,(vector 0 0) () 2 #(#\B
#\C
))
95 (#(#\B
) () ,(vector 0 0) (:end
1) 1 #(#\B
0))
96 (#(#\B
) () ,(vector 0 0) (:start
1) 2 #(0 #\B
))
97 ;; Byte-vector destination sequence.
98 (#(65) () ,(bvector 0) () 1 #(65))
99 (#(#\B
) () ,(bvector 0) () 1 #(66))
100 (#(#xe0
) () ,(bvector 0) () 1 #(#xe0
))
101 (#(66 #\C
) () ,(bvector 0 0) () 2 #(66 67))
102 (#(#\B
67) () ,(bvector 0 0) () 2 #(66 67))
103 (#(#\B
) () ,(bvector 0 0) (:end
1) 1 #(66 0))
104 (#(#\B
) () ,(bvector 0 0) (:start
1) 2 #(0 66))
105 ;; Character-vector destination sequence.
106 (#(65) () ,(cvector #\_
) () 1 #(#\A
))
107 (#(#\B
) () ,(cvector #\_
) () 1 #(#\B
))
108 (#(#x7e
) () ,(cvector #\_
) () 1 #(,(code-char #x7e
)))
109 (#(66 #\C
) () ,(cvector #\_
#\_
) () 2 #(#\B
#\C
))
110 (#(#\B
67) () ,(cvector #\_
#\_
) () 2 #(#\B
#\C
))
111 (#(#\B
) () ,(cvector #\_
#\_
) (:end
1) 1 #(#\B
#\_
))
112 (#(#\B
) () ,(cvector #\_
#\_
) (:start
1) 2 #(#\_
#\B
))
113 ;; String destination sequence.
114 (#(65) () ,(make-string 1) () 1 "A")
115 (#(#\B
) () ,(make-string 1) () 1 "B")
116 (#(66 #\C
) () ,(make-string 2) () 2 "BC")
117 (#(#\B
67) () ,(make-string 2) () 2 "BC")
118 (#(#\B
) () ,(make-string 2) (:end
1) 1 ,(coerce '(#\B
#\Nul
) 'string
))
119 (#(#\B
) () ,(make-string 2) (:start
1) 2 ,(coerce '(#\Nul
#\B
) 'string
)))))
120 (with-bivalent-io-setup ("bivalent-stream-test.txt")
122 (with-stream (stream :direction
:output
:if-exists
:supersede
)
123 (loop :for
(sequence args
) :in pairs
124 :do
(apply #'write-sequence sequence stream args
)))
125 ;; Read sequence and compare.
126 (with-stream (stream :direction
:input
)
127 (loop :for
(source source-args into into-args
128 expected-position expected-sequence
) :in pairs
129 :do
(let ((into/old
(copy-seq into
))
130 (position (apply #'read-sequence into stream into-args
)))
131 (unless (= position expected-position
)
132 (error "~@<~S returned ~S, expected ~S.~@:>"
133 `(read-sequence ,into
/old
,@into-args
)
134 position expected-position
))
135 (assert-roundtrip `(write-sequence ,source
,@source-args
)
136 `(read-sequence ,into
/old
,@into-args
)
137 into expected-sequence
)))))))
139 (with-test (:name
(stream :bivalent
:no-unknown-type-condition
))
141 (with-bivalent-io-setup ("bivalent-stream-test.txt")
142 (with-stream (stream :direction
:output
:if-exists
:supersede
)))
143 sb-kernel
:parse-unknown-type
))
