3 ;;; This code is in the public domain.
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain. Sbcl port by Rudi
9 (in-package "SB-SIMPLE-STREAMS")
12 (defun refill-buffer (stream blocking)
13 (with-stream-class (simple-stream stream)
14 (let* ((unread (sm last-char-read-size stream))
15 (buffer (sm buffer stream)))
16 (unless (zerop unread)
17 (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
18 (let ((bytes (device-read stream nil unread nil blocking)))
19 (declare (type fixnum bytes))
20 (setf (sm buffpos stream) unread
21 (sm buffer-ptr stream) (if (plusp bytes)
26 (defun sc-flush-buffer (stream blocking)
27 (with-stream-class (single-channel-simple-stream stream)
29 (bytes (sm buffpos stream)))
30 (declare (type fixnum ptr bytes))
32 (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
33 (let ((bytes-written (device-write stream nil ptr nil blocking)))
34 (declare (fixnum bytes-written))
35 (when (minusp bytes-written)
36 (error "DEVICE-WRITE error."))
37 (incf ptr bytes-written))))))
39 (defun dc-flush-buffer (stream blocking)
40 (with-stream-class (dual-channel-simple-stream stream)
42 (bytes (sm outpos stream)))
43 (declare (type fixnum ptr bytes))
45 (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
46 (let ((bytes-written (device-write stream nil ptr nil blocking)))
47 (declare (fixnum bytes-written))
48 (when (minusp bytes-written)
49 (error "DEVICE-WRITE error."))
50 (incf ptr bytes-written))))))
53 ;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
56 (declaim (ftype j-read-char-fn sc-read-char))
57 (defun sc-read-char (stream eof-error-p eof-value blocking)
58 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
59 (with-stream-class (single-channel-simple-stream stream)
60 ;; if stream is open for read-write, may need to flush the buffer
61 (let* ((buffer (sm buffer stream))
62 (ptr (sm buffpos stream))
63 (code (if (< ptr (sm buffer-ptr stream))
65 (setf (sm buffpos stream) (1+ ptr))
67 (let ((bytes (refill-buffer stream blocking)))
68 (declare (type fixnum bytes))
69 (unless (minusp bytes)
70 (let ((ptr (sm buffpos stream)))
71 (setf (sm buffpos stream) (1+ ptr))
72 (bref buffer ptr))))))
73 (char (if code (code-char code) nil))
74 (ctrl (sm control-in stream)))
76 (setf (sm last-char-read-size stream) 1)
77 (when (and (< code 32) ctrl (svref ctrl code))
78 ;; Does this have to be a function, or can it be a symbol?
79 (setq char (funcall (the (or symbol function) (svref ctrl code))
82 (sb-impl::eof-or-lose stream eof-error-p eof-value)
85 (declaim (ftype j-read-char-fn sc-read-char--buffer))
86 (defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
87 (declare (ignore blocking)) ;; everything is already in the buffer
88 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
89 (with-stream-class (single-channel-simple-stream stream)
90 (let* ((buffer (sm buffer stream))
91 (ptr (sm buffpos stream))
92 (code (when (< ptr (sm buffer-ptr stream))
93 (setf (sm buffpos stream) (1+ ptr))
95 (char (if code (code-char code) nil))
96 (ctrl (sm control-in stream)))
98 (setf (sm last-char-read-size stream) 1)
99 (when (and (< code 32) ctrl (svref ctrl code))
100 ;; Does this have to be a function, or can it be a symbol?
101 (setq char (funcall (the (or symbol function) (svref ctrl code))
104 (sb-impl::eof-or-lose stream eof-error-p eof-value)
107 (declaim (ftype j-read-chars-fn sc-read-chars))
108 (defun sc-read-chars (stream string search start end blocking)
109 ;; string is filled from START to END, or until SEARCH is found
110 ;; Return two values: count of chars read and
111 ;; NIL if SEARCH was not found
112 ;; T is SEARCH was found
113 ;; :EOF if eof encountered before end
114 (declare (type simple-stream stream)
116 (type (or null character) search)
117 (type fixnum start end)
118 (type boolean blocking)
119 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
120 (with-stream-class (single-channel-simple-stream stream)
121 (setf (sm last-char-read-size stream) 0)
122 ;; Should arrange for the last character to be unreadable
123 (do ((buffer (sm buffer stream))
124 (ptr (sm buffpos stream))
125 (max (sm buffer-ptr stream))
126 (posn start (1+ posn))
127 (count 0 (1+ count)))
128 ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
129 (declare (type fixnum ptr max posn count))
130 (let* ((code (if (< ptr max)
134 (let ((bytes (refill-buffer stream blocking)))
135 (declare (type fixnum bytes))
136 (setf ptr (sm buffpos stream)
137 max (sm buffer-ptr stream))
142 (char (if code (code-char code) nil))
143 (ctrl (sm control-in stream)))
144 (when (and code (< code 32) ctrl (svref ctrl code))
145 (setq char (funcall (the (or symbol function) (svref ctrl code))
148 (setf (sm buffpos stream) ptr)
149 (return (values count :eof)))
150 ((and search (char= char search))
151 (setf (sm buffpos stream) ptr)
152 (return (values count t)))
154 (setf (char string posn) char)))))))
156 (declaim (ftype j-read-chars-fn sc-read-chars--buffer))
157 (defun sc-read-chars--buffer (stream string search start end blocking)
158 (declare (type simple-stream stream)
160 (type (or null character) search)
161 (type fixnum start end)
162 (type boolean blocking)
163 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
164 ;; TODO: what about the blocking parameter?
165 (with-stream-class (single-channel-simple-stream stream)
166 (do ((buffer (sm buffer stream))
167 (ptr (sm buffpos stream))
168 (max (sm buffer-ptr stream))
169 (posn start (1+ posn))
170 (count 0 (1+ count)))
172 (setf (sm buffpos stream) ptr)
173 (unless (zerop count) (setf (sm last-char-read-size stream) 1))
175 (declare (type fixnum ptr max posn count))
176 (let* ((code (when (< ptr max)
180 (char (if code (code-char code) nil))
181 (ctrl (sm control-in stream)))
182 (when (and code (< code 32) ctrl (svref ctrl code))
183 (setq char (funcall (the (or symbol function) (svref ctrl code))
186 (setf (sm buffpos stream) ptr)
187 (unless (zerop count) (setf (sm last-char-read-size stream) 1))
188 (return (values count :eof)))
189 ((and search (char= char search))
190 (setf (sm buffpos stream) ptr)
191 ;; Unread of last char must unread the search character, too
192 ;; If no characters were read, just add the length of the
193 ;; search char to that of the previously read char.
195 (incf (sm last-char-read-size stream))
196 (setf (sm last-char-read-size stream) 2))
197 (return (values count t)))
199 (setf (char string posn) char)))))))
201 (declaim (ftype j-unread-char-fn sc-unread-char))
202 (defun sc-unread-char (stream relaxed)
203 (declare (ignore relaxed))
204 (with-stream-class (single-channel-simple-stream stream)
205 (let ((unread (sm last-char-read-size stream)))
206 (if (>= (sm buffpos stream) unread)
207 (decf (sm buffpos stream) unread)
208 (error "Unreading needs work"))
209 (setf (sm last-char-read-size stream) 0))))
211 (declaim (ftype j-write-char-fn sc-write-char))
212 (defun sc-write-char (character stream)
213 (with-stream-class (single-channel-simple-stream stream)
214 (let* ((buffer (sm buffer stream))
215 (ptr (sm buffpos stream))
216 (code (char-code character))
217 (ctrl (sm control-out stream)))
218 (when (and (< code 32) ctrl (svref ctrl code)
219 (funcall (the (or symbol function) (svref ctrl code))
221 (return-from sc-write-char character))
222 (if (< ptr (sm buffer-ptr stream))
224 (setf (bref buffer ptr) code)
225 (setf (sm buffpos stream) (1+ ptr)))
227 (sc-flush-buffer stream t)
228 (setf ptr (sm buffpos stream))))))
231 (declaim (ftype j-write-chars-fn sc-write-chars))
232 (defun sc-write-chars (string stream start end)
233 (with-stream-class (single-channel-simple-stream stream)
234 (do ((buffer (sm buffer stream))
235 (ptr (sm buffpos stream))
236 ;; xxx buffer-ptr or buf-len? TODO: look them up in the
237 ;; docs; was: buffer-ptr, but it's initialized to 0 in
238 ;; (device-open file-simple-stream); buf-len seems to work(tm)
239 (max #+nil(sm buffer-ptr stream) ;; or buf-len?
241 (ctrl (sm control-out stream))
242 (posn start (1+ posn))
243 (count 0 (1+ count)))
244 ((>= posn end) (setf (sm buffpos stream) ptr) count)
245 (declare (type fixnum ptr max posn count))
246 (let* ((char (char string posn))
247 (code (char-code char)))
248 (unless (and (< code 32) ctrl (svref ctrl code)
249 (funcall (the (or symbol function) (svref ctrl code))
253 (setf (bref buffer ptr) code)
256 (sc-flush-buffer stream t)
257 (setf ptr (sm buffpos stream)))))))))
259 (declaim (ftype j-listen-fn sc-listen))
260 (defun sc-listen (stream)
261 (with-stream-class (single-channel-simple-stream stream)
262 (or (< (sm buffpos stream) (sm buffer-ptr stream))
263 (case (device-read stream nil 0 0 nil)
265 (-1 #| latch EOF |# nil)
267 (t (error "DEVICE-READ error."))))))
270 ;;; DUAL-CHANNEL STRATEGY FUNCTIONS
273 (declaim (ftype j-read-char-fn dc-read-char))
274 (defun dc-read-char (stream eof-error-p eof-value blocking)
275 ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
276 (with-stream-class (dual-channel-simple-stream stream)
277 ;; if interactive flag is set, finish-output first
278 (let* ((buffer (sm buffer stream))
279 (ptr (sm buffpos stream))
280 (code (if (< ptr (sm buffer-ptr stream))
282 (setf (sm buffpos stream) (1+ ptr))
284 (let ((bytes (refill-buffer stream blocking)))
285 (declare (type fixnum bytes))
286 (unless (minusp bytes)
287 (let ((ptr (sm buffpos stream)))
288 (setf (sm buffpos stream) (1+ ptr))
289 (bref buffer ptr))))))
290 (char (if code (code-char code) nil))
291 (ctrl (sm control-in stream)))
293 (setf (sm last-char-read-size stream) 1)
294 (when (and (< code 32) ctrl (svref ctrl code))
295 ;; Does this have to be a function, or can it be a symbol?
296 (setq char (funcall (the (or symbol function) (svref ctrl code))
298 #|(let ((column (sm charpos stream)))
299 (declare (type (or null fixnum) column))
301 (setf (sm charpos stream) (1+ column))))|#)
303 (sb-impl::eof-or-lose stream eof-error-p eof-value)
306 (declaim (ftype j-read-chars-fn dc-read-chars))
307 (defun dc-read-chars (stream string search start end blocking)
308 (declare (type dual-channel-simple-stream stream)
310 (type (or null character) search)
311 (type fixnum start end)
312 (type boolean blocking)
313 #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
314 (with-stream-class (dual-channel-simple-stream stream)
315 ;; if interactive flag is set, finish-output first
316 (setf (sm last-char-read-size stream) 0)
317 ;; Should arrange for the last character to be unreadable
318 (do ((buffer (sm buffer stream))
319 (ptr (sm buffpos stream))
320 (max (sm buffer-ptr stream))
321 (posn start (1+ posn))
322 (count 0 (1+ count)))
323 ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
324 (declare (type fixnum ptr max posn count))
325 (let* ((code (if (< ptr max)
329 (let ((bytes (refill-buffer stream blocking)))
330 (declare (type fixnum bytes))
331 (setf ptr (sm buffpos stream)
332 max (sm buffer-ptr stream))
337 (char (if code (code-char code) nil))
338 (ctrl (sm control-in stream)))
339 (when (and code (< code 32) ctrl (svref ctrl code))
340 (setq char (funcall (the (or symbol function) (svref ctrl code))
342 #|(let ((column (sm charpos stream)))
343 (declare (type (or null fixnum) column))
345 (setf (sm charpos stream) (1+ column))))|#
347 (setf (sm buffpos stream) ptr)
348 (return (values count :eof)))
349 ((and search (char= char search))
350 (setf (sm buffpos stream) ptr)
351 (return (values count t)))
353 (setf (char string posn) char)))))))
355 (declaim (ftype j-unread-char-fn dc-unread-char))
356 (defun dc-unread-char (stream relaxed)
357 (declare (ignore relaxed))
358 (with-stream-class (dual-channel-simple-stream stream)
359 (let ((unread (sm last-char-read-size stream)))
360 (if (>= (sm buffpos stream) unread)
361 (decf (sm buffpos stream) unread)
362 (error "Unreading needs work"))
363 (setf (sm last-char-read-size stream) 0))))
365 (declaim (ftype j-write-char-fn dc-write-char))
366 (defun dc-write-char (character stream)
367 (with-stream-class (dual-channel-simple-stream stream)
368 (let* ((buffer (sm out-buffer stream))
369 (ptr (sm outpos stream))
370 (code (char-code character))
371 (ctrl (sm control-out stream)))
372 (when (and (< code 32) ctrl (svref ctrl code)
373 (funcall (the (or symbol function) (svref ctrl code))
375 (return-from dc-write-char character))
376 (if (< ptr (sm max-out-pos stream))
378 (setf (bref buffer ptr) code)
379 (setf (sm outpos stream) (1+ ptr)))
381 (dc-flush-buffer stream t)
382 (setf ptr (sm outpos stream))))))
385 (declaim (ftype j-write-chars-fn dc-write-chars))
386 (defun dc-write-chars (string stream start end)
387 (with-stream-class (dual-channel-simple-stream stream)
388 (do ((buffer (sm out-buffer stream))
389 (ptr (sm outpos stream))
390 (max (sm max-out-pos stream))
391 (ctrl (sm control-out stream))
392 (posn start (1+ posn))
393 (count 0 (1+ count)))
394 ((>= posn end) (setf (sm outpos stream) ptr) count)
395 (declare (type fixnum ptr max posn count))
396 (let* ((char (char string posn))
397 (code (char-code char)))
398 (unless (and (< code 32) ctrl (svref ctrl code)
399 (funcall (the (or symbol function) (svref ctrl code))
403 (setf (bref buffer ptr) code)
406 (dc-flush-buffer stream t)
407 (setf ptr (sm outpos stream)))))))))
409 (declaim (ftype j-listen-fn dc-listen))
410 (defun dc-listen (stream)
411 (with-stream-class (dual-channel-simple-stream stream)
412 (or (< (sm buffpos stream) (sm buffer-ptr stream))
413 (case (device-read stream nil 0 0 nil)
415 (-1 #| latch EOF |# nil)
417 (t (error "DEVICE-READ error."))))))
420 ;;; STRING STRATEGY FUNCTIONS
423 (declaim (ftype j-read-char-fn string-read-char))
424 (defun string-read-char (stream eof-error-p eof-value blocking)
425 (declare (type string-input-simple-stream stream) (ignore blocking)
426 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
427 (with-stream-class (string-input-simple-stream stream)
428 (when (any-stream-instance-flags stream :eof)
429 (sb-impl::eof-or-lose stream eof-error-p eof-value))
430 (let* ((ptr (sm buffpos stream))
431 (char (if (< ptr (sm buffer-ptr stream))
432 (schar (sm buffer stream) ptr)
435 (sb-impl::eof-or-lose stream eof-error-p eof-value)
437 (setf (sm last-char-read-size stream) 1)
438 ;; do string-streams do control-in processing?
439 #|(let ((column (sm charpos stream)))
440 (declare (type (or null fixnum) column))
442 (setf (sm charpos stream) (1+ column))))|#
446 (declaim (ftype j-read-char-fn composing-crlf-read-char))
447 (defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
448 ;; TODO: what about the eof-error-p parameter?
449 (with-stream-class (simple-stream stream)
450 (let* ((melded-stream (sm melded-stream stream))
451 (char (funcall-stm-handler j-read-char melded-stream nil stream
453 ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
454 ;; character was available...
455 (when (eql char #\Return)
456 (let ((next (funcall-stm-handler j-read-char melded-stream
457 nil stream blocking)))
458 ;; if NEXT is STREAM, we hit EOF, so we should just return the
459 ;; #\Return (and mark the stream :EOF? At least unread if we
460 ;; got a soft EOF, from a terminal, etc.
461 ;; if NEXT is NIL, blocking is NIL and there's a CR but no
462 ;; LF available on the stream: have to unread the CR and
463 ;; return NIL, letting the CR be reread later.
465 ;; If we did get a linefeed, adjust the last-char-read-size
466 ;; so that an unread of the resulting newline will unread both
467 ;; the linefeed _and_ the carriage return.
468 (if (eql next #\Linefeed)
469 (setq char #\Newline)
470 (funcall-stm-handler j-unread-char melded-stream nil))))
471 ;; do control-in processing on whatever character we've got
474 (declaim (ftype j-unread-char-fn composing-crlf-unread-char))
475 (defun composing-crlf-unread-char (stream relaxed)
476 (declare (ignore relaxed))
477 (with-stream-class (simple-stream stream)
478 (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
484 (defun install-single-channel-character-strategy (stream external-format
486 (declare (ignore external-format))
487 ;; ACCESS is usually NIL
488 ;; May be "undocumented" values: stream::buffer, stream::mapped
489 ;; to install strategies suitable for direct buffer streams
490 ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
491 ;; (Avoids checking "mode" flags by installing special strategy)
492 (with-stream-class (single-channel-simple-stream stream)
493 (if (or (eq access 'buffer) (eq access 'mapped))
494 (setf (sm j-read-char stream) #'sc-read-char--buffer
495 (sm j-read-chars stream) #'sc-read-chars--buffer
496 (sm j-unread-char stream) #'sc-unread-char
497 (sm j-write-char stream) #'sc-write-char
498 (sm j-write-chars stream) #'sc-write-chars
499 (sm j-listen stream) #'sc-listen)
500 (setf (sm j-read-char stream) #'sc-read-char
501 (sm j-read-chars stream) #'sc-read-chars
502 (sm j-unread-char stream) #'sc-unread-char
503 (sm j-write-char stream) #'sc-write-char
504 (sm j-write-chars stream) #'sc-write-chars
505 (sm j-listen stream) #'sc-listen)))
508 (defun install-dual-channel-character-strategy (stream external-format)
509 (declare (ignore external-format))
510 (with-stream-class (dual-channel-simple-stream stream)
511 (setf (sm j-read-char stream) #'dc-read-char
512 (sm j-read-chars stream) #'dc-read-chars
513 (sm j-unread-char stream) #'dc-unread-char
514 (sm j-write-char stream) #'dc-write-char
515 (sm j-write-chars stream) #'dc-write-chars
516 (sm j-listen stream) #'dc-listen))
519 (defun install-string-character-strategy (stream)
520 (with-stream-class (string-simple-stream stream)
521 (setf (sm j-read-char stream) #'string-read-char))