Fix problem of retaining !LATE-TYPE-COLD-INIT symbol
[sbcl.git] / tests / bivalent-stream.impure.lisp
blobd1b1aa2bd73064cbd294327d4d5adc278a7b34d3
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
5 ;;;; users.
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
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
12 ;;;; from CMU CL.
13 ;;;;
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))
31 (unwind-protect
32 (macrolet
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)
36 ,@body)))
37 ,@body)
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, ~
44 expected ~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)
61 `(,read-function)
62 result expected)))))))
64 (with-test (:name (stream :bivalent :roundtrip sequence))
65 (let ((pairs
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")
121 ;; Write sequence.
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))
140 (assert-no-signal
141 (with-bivalent-io-setup ("bivalent-stream-test.txt")
142 (with-stream (stream :direction :output :if-exists :supersede)))
143 sb-kernel:parse-unknown-type))