streams.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
streams.lisp (11484B)
---
1 #+xcvb (module (:depends-on ("package")))
2
3 (in-package :trivial-gray-streams)
4
5 (defclass fundamental-stream (impl-specific-gray:fundamental-stream) ())
6 (defclass fundamental-input-stream
7 (fundamental-stream impl-specific-gray:fundamental-input-stream) ())
8 (defclass fundamental-output-stream
9 (fundamental-stream impl-specific-gray:fundamental-output-stream) ())
10 (defclass fundamental-character-stream
11 (fundamental-stream impl-specific-gray:fundamental-character-stream) ())
12 (defclass fundamental-binary-stream
13 (fundamental-stream impl-specific-gray:fundamental-binary-stream) ())
14 (defclass fundamental-character-input-stream
15 (fundamental-input-stream fundamental-character-stream
16 impl-specific-gray:fundamental-character-input-stream) ())
17 (defclass fundamental-character-output-stream
18 (fundamental-output-stream fundamental-character-stream
19 impl-specific-gray:fundamental-character-output-stream) ())
20 (defclass fundamental-binary-input-stream
21 (fundamental-input-stream fundamental-binary-stream
22 impl-specific-gray:fundamental-binary-input-stream) ())
23 (defclass fundamental-binary-output-stream
24 (fundamental-output-stream fundamental-binary-stream
25 impl-specific-gray:fundamental-binary-output-stream) ())
26
27 (defgeneric stream-read-sequence
28 (stream sequence start end &key &allow-other-keys))
29 (defgeneric stream-write-sequence
30 (stream sequence start end &key &allow-other-keys))
31
32 (defgeneric stream-file-position (stream))
33 (defgeneric (setf stream-file-position) (newval stream))
34
35 ;;; Default methods for stream-read/write-sequence.
36 ;;;
37 ;;; It would be nice to implement default methods
38 ;;; in trivial gray streams, maybe borrowing the code
39 ;;; from some of CL implementations. But now, for
40 ;;; simplicity we will fallback to default implementation
41 ;;; of the implementation-specific analogue function which calls us.
42
43 (defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key)
44 (declare (ignore seq start end))
45 'fallback)
46
47 (defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key)
48 (declare (ignore seq start end))
49 'fallback)
50
51 (defmacro or-fallback (&body body)
52 `(let ((result ,@body))
53 (if (eq result (quote fallback))
54 (call-next-method)
55 result)))
56
57 ;; Implementations should provide this default method, I believe, but
58 ;; at least sbcl and allegro don't.
59 (defmethod stream-terpri ((stream fundamental-output-stream))
60 (write-char #\newline stream))
61
62 ;; stream-file-position could be specialized to
63 ;; fundamental-stream, but to support backward
64 ;; compatibility with flexi-streams, we specialize
65 ;; it on T. The reason: flexi-streams calls stream-file-position
66 ;; for non-gray stream:
67 ;; https://github.com/edicl/flexi-streams/issues/4
68 (defmethod stream-file-position ((stream t))
69 nil)
70
71 (defmethod (setf stream-file-position) (newval (stream t))
72 (declare (ignore newval))
73 nil)
74
75 #+abcl
76 (progn
77 (defmethod gray-streams:stream-read-sequence
78 ((s fundamental-input-stream) seq &optional start end)
79 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
80
81 (defmethod gray-streams:stream-write-sequence
82 ((s fundamental-output-stream) seq &optional start end)
83 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
84
85 (defmethod gray-streams:stream-write-string
86 ((stream xp::xp-structure) string &optional (start 0) (end (length string)))
87 (xp::write-string+ string stream start end))
88
89 #+#.(cl:if (cl:and (cl:find-package :gray-streams)
90 (cl:find-symbol "STREAM-FILE-POSITION" :gray-streams))
91 '(:and)
92 '(:or))
93 (defmethod gray-streams:stream-file-position
94 ((s fundamental-stream) &optional position)
95 (if position
96 (setf (stream-file-position s) position)
97 (stream-file-position s))))
98
99 #+allegro
100 (progn
101 (defmethod excl:stream-read-sequence
102 ((s fundamental-input-stream) seq &optional start end)
103 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
104
105 (defmethod excl:stream-write-sequence
106 ((s fundamental-output-stream) seq &optional start end)
107 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
108
109 (defmethod excl::stream-file-position
110 ((stream fundamental-stream) &optional position)
111 (if position
112 (setf (stream-file-position stream) position)
113 (stream-file-position stream))))
114
115 ;; Untill 2014-08-09 CMUCL did not have stream-file-position:
116 ;; http://trac.common-lisp.net/cmucl/ticket/100
117 #+cmu
118 (eval-when (:compile-toplevel :load-toplevel :execute)
119 (when (find-symbol (string '#:stream-file-position) '#:ext)
120 (pushnew :cmu-has-stream-file-position *features*)))
121
122 #+cmu
123 (progn
124 (defmethod ext:stream-read-sequence
125 ((s fundamental-input-stream) seq &optional start end)
126 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
127 (defmethod ext:stream-write-sequence
128 ((s fundamental-output-stream) seq &optional start end)
129 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
130
131 #+cmu-has-stream-file-position
132 (defmethod ext:stream-file-position ((stream fundamental-stream))
133 (stream-file-position stream))
134
135 #+cmu-has-stream-file-position
136 (defmethod (setf ext:stream-file-position) (position (stream fundamental-stream))
137 (setf (stream-file-position stream) position)))
138
139 #+lispworks
140 (progn
141 (defmethod stream:stream-read-sequence
142 ((s fundamental-input-stream) seq start end)
143 (or-fallback (stream-read-sequence s seq start end)))
144 (defmethod stream:stream-write-sequence
145 ((s fundamental-output-stream) seq start end)
146 (or-fallback (stream-write-sequence s seq start end)))
147
148 (defmethod stream:stream-file-position ((stream fundamental-stream))
149 (stream-file-position stream))
150 (defmethod (setf stream:stream-file-position)
151 (newval (stream fundamental-stream))
152 (setf (stream-file-position stream) newval)))
153
154 #+openmcl
155 (progn
156 (defmethod ccl:stream-read-vector
157 ((s fundamental-input-stream) seq start end)
158 (or-fallback (stream-read-sequence s seq start end)))
159 (defmethod ccl:stream-write-vector
160 ((s fundamental-output-stream) seq start end)
161 (or-fallback (stream-write-sequence s seq start end)))
162
163 (defmethod ccl:stream-read-list ((s fundamental-input-stream) list count)
164 (or-fallback (stream-read-sequence s list 0 count)))
165 (defmethod ccl:stream-write-list ((s fundamental-output-stream) list count)
166 (or-fallback (stream-write-sequence s list 0 count)))
167
168 (defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position)
169 (if new-position
170 (setf (stream-file-position stream) new-position)
171 (stream-file-position stream))))
172
173 ;; up to version 2.43 there were no
174 ;; stream-read-sequence, stream-write-sequence
175 ;; functions in CLISP
176 #+clisp
177 (eval-when (:compile-toplevel :load-toplevel :execute)
178 (when (find-symbol (string '#:stream-read-sequence) '#:gray)
179 (pushnew :clisp-has-stream-read/write-sequence *features*)))
180
181 #+clisp
182 (progn
183
184 #+clisp-has-stream-read/write-sequence
185 (defmethod gray:stream-read-sequence
186 (seq (s fundamental-input-stream) &key start end)
187 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
188
189 #+clisp-has-stream-read/write-sequence
190 (defmethod gray:stream-write-sequence
191 (seq (s fundamental-output-stream) &key start end)
192 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
193
194 ;;; for old CLISP
195 (defmethod gray:stream-read-byte-sequence
196 ((s fundamental-input-stream)
197 seq
198 &optional start end no-hang interactive)
199 (when no-hang
200 (error "this stream does not support the NO-HANG argument"))
201 (when interactive
202 (error "this stream does not support the INTERACTIVE argument"))
203 (or-fallback (stream-read-sequence s seq start end)))
204
205 (defmethod gray:stream-write-byte-sequence
206 ((s fundamental-output-stream)
207 seq
208 &optional start end no-hang interactive)
209 (when no-hang
210 (error "this stream does not support the NO-HANG argument"))
211 (when interactive
212 (error "this stream does not support the INTERACTIVE argument"))
213 (or-fallback (stream-write-sequence s seq start end)))
214
215 (defmethod gray:stream-read-char-sequence
216 ((s fundamental-input-stream) seq &optional start end)
217 (or-fallback (stream-read-sequence s seq start end)))
218
219 (defmethod gray:stream-write-char-sequence
220 ((s fundamental-output-stream) seq &optional start end)
221 (or-fallback (stream-write-sequence s seq start end)))
222
223 ;;; end of old CLISP read/write-sequence support
224
225 (defmethod gray:stream-position ((stream fundamental-stream) position)
226 (if position
227 (setf (stream-file-position stream) position)
228 (stream-file-position stream))))
229
230 #+sbcl
231 (progn
232 (defmethod sb-gray:stream-read-sequence
233 ((s fundamental-input-stream) seq &optional start end)
234 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
235 (defmethod sb-gray:stream-write-sequence
236 ((s fundamental-output-stream) seq &optional start end)
237 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
238 (defmethod sb-gray:stream-file-position
239 ((stream fundamental-stream) &optional position)
240 (if position
241 (setf (stream-file-position stream) position)
242 (stream-file-position stream)))
243 ;; SBCL extension:
244 (defmethod sb-gray:stream-line-length ((stream fundamental-stream))
245 80))
246
247 #+(or ecl clasp)
248 (progn
249 (defmethod gray::stream-file-position
250 ((stream fundamental-stream) &optional position)
251 (if position
252 (setf (stream-file-position stream) position)
253 (stream-file-position stream)))
254 (defmethod gray:stream-read-sequence
255 ((s fundamental-input-stream) seq &optional start end)
256 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
257 (defmethod gray:stream-write-sequence
258 ((s fundamental-output-stream) seq &optional start end)
259 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))))
260
261 #+mocl
262 (progn
263 (defmethod gray:stream-read-sequence
264 ((s fundamental-input-stream) seq &optional start end)
265 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
266 (defmethod gray:stream-write-sequence
267 ((s fundamental-output-stream) seq &optional start end)
268 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
269 (defmethod gray:stream-file-position
270 ((stream fundamental-stream) &optional position)
271 (if position
272 (setf (stream-file-position stream) position)
273 (stream-file-position stream))))
274
275 #+genera
276 (progn
277 (defmethod gray-streams:stream-read-sequence
278 ((s fundamental-input-stream) seq &optional start end)
279 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
280 (defmethod gray-streams:stream-write-sequence
281 ((s fundamental-output-stream) seq &optional start end)
282 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
283 (defmethod gray-streams:stream-file-position
284 ((stream fundamental-stream))
285 (stream-file-position stream))
286 (defmethod (setf gray-streams:stream-file-position)
287 (position (stream fundamental-stream))
288 (setf (stream-file-position stream) position)))
289
290 ;; deprecated
291 (defclass trivial-gray-stream-mixin () ())
292