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 ;; Keep last read character at beginning of buffer
18 (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
19 (let ((bytes (device-read stream nil unread nil blocking)))
20 (declare (type fixnum bytes))
21 (setf (sm buffpos stream) unread
22 (sm buffer-ptr stream) (if (plusp bytes)
27 (defun sc-flush-buffer (stream blocking)
28 (with-stream-class (single-channel-simple-stream stream)
30 (bytes (sm buffpos stream)))
31 (declare (type fixnum ptr bytes))
33 (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
34 (let ((bytes-written (device-write stream nil ptr nil blocking)))
35 (declare (fixnum bytes-written))
36 (when (minusp bytes-written)
37 (error "DEVICE-WRITE error."))
38 (incf ptr bytes-written))))))
40 (defun dc-flush-buffer (stream blocking)
41 (with-stream-class (dual-channel-simple-stream stream)
43 (bytes (sm outpos stream)))
44 (declare (type fixnum ptr bytes))
46 (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
47 (let ((bytes-written (device-write stream nil ptr nil blocking)))
48 (declare (fixnum bytes-written))
49 (when (minusp bytes-written)
50 (error "DEVICE-WRITE error."))
51 (incf ptr bytes-written))))))
54 ;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
57 (declaim (ftype j-read-char-fn sc-read-char))
58 (defun sc-read-char (stream eof-error-p eof-value blocking)
59 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
60 (with-stream-class (single-channel-simple-stream stream)
61 ;; if stream is open for read-write, may need to flush the buffer
62 (let* ((buffer (sm buffer stream))
63 (ptr (sm buffpos stream))
64 (code (if (< ptr (sm buffer-ptr stream))
66 (setf (sm buffpos stream) (1+ ptr))
68 (let ((bytes (refill-buffer stream blocking)))
69 (declare (type fixnum bytes))
70 (unless (minusp bytes)
71 (let ((ptr (sm buffpos stream)))
72 (setf (sm buffpos stream) (1+ ptr))
73 (bref buffer ptr))))))
74 (char (if code (code-char code) nil))
75 (ctrl (sm control-in stream)))
77 (setf (sm last-char-read-size stream) 1)
78 (when (and (< code 32) ctrl (svref ctrl code))
79 ;; Does this have to be a function, or can it be a symbol?
80 (setq char (funcall (the (or symbol function) (svref ctrl code))
83 (sb-impl::eof-or-lose stream eof-error-p eof-value)
86 (declaim (ftype j-read-char-fn sc-read-char--buffer))
87 (defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
88 (declare (ignore blocking)) ;; everything is already in the buffer
89 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
90 (with-stream-class (single-channel-simple-stream stream)
91 (let* ((buffer (sm buffer stream))
92 (ptr (sm buffpos stream))
93 (code (when (< ptr (sm buffer-ptr stream))
94 (setf (sm buffpos stream) (1+ ptr))
96 (char (if code (code-char code) nil))
97 (ctrl (sm control-in stream)))
99 (setf (sm last-char-read-size stream) 1)
100 (when (and (< code 32) ctrl (svref ctrl code))
101 ;; Does this have to be a function, or can it be a symbol?
102 (setq char (funcall (the (or symbol function) (svref ctrl code))
105 (sb-impl::eof-or-lose stream eof-error-p eof-value)
108 (declaim (ftype j-read-chars-fn sc-read-chars))
109 (defun sc-read-chars (stream string search start end blocking)
110 ;; string is filled from START to END, or until SEARCH is found
111 ;; Return two values: count of chars read and
112 ;; NIL if SEARCH was not found
113 ;; T is SEARCH was found
114 ;; :EOF if eof encountered before end
115 (declare (type simple-stream stream)
117 (type (or null character) search)
118 (type fixnum start end)
119 (type boolean blocking)
120 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
121 (with-stream-class (single-channel-simple-stream stream)
122 (setf (sm last-char-read-size stream) 0)
123 ;; Should arrange for the last character to be unreadable
124 (do ((buffer (sm buffer stream))
125 (ptr (sm buffpos stream))
126 (max (sm buffer-ptr stream))
127 (posn start (1+ posn))
128 (count 0 (1+ count)))
129 ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
130 (declare (type fixnum ptr max posn count))
131 (let* ((code (if (< ptr max)
135 (let ((bytes (refill-buffer stream blocking)))
136 (declare (type fixnum bytes))
137 (setf ptr (sm buffpos stream)
138 max (sm buffer-ptr stream))
143 (char (if code (code-char code) nil))
144 (ctrl (sm control-in stream)))
145 (when (and code (< code 32) ctrl (svref ctrl code))
146 (setq char (funcall (the (or symbol function) (svref ctrl code))
149 (setf (sm buffpos stream) ptr)
150 (return (values count :eof)))
151 ((and search (char= char search))
152 (setf (sm buffpos stream) ptr)
153 (return (values count t)))
155 (setf (char string posn) char)))))))
157 (declaim (ftype j-read-chars-fn sc-read-chars--buffer))
158 (defun sc-read-chars--buffer (stream string search start end blocking)
159 (declare (type simple-stream stream)
161 (type (or null character) search)
162 (type fixnum start end)
163 (type boolean blocking)
164 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
165 ;; TODO: what about the blocking parameter?
166 (with-stream-class (single-channel-simple-stream stream)
167 (do ((buffer (sm buffer stream))
168 (ptr (sm buffpos stream))
169 (max (sm buffer-ptr stream))
170 (posn start (1+ posn))
171 (count 0 (1+ count)))
173 (setf (sm buffpos stream) ptr)
174 (unless (zerop count) (setf (sm last-char-read-size stream) 1))
176 (declare (type fixnum ptr max posn count))
177 (let* ((code (when (< ptr max)
181 (char (if code (code-char code) nil))
182 (ctrl (sm control-in stream)))
183 (when (and code (< code 32) ctrl (svref ctrl code))
184 (setq char (funcall (the (or symbol function) (svref ctrl code))
187 (setf (sm buffpos stream) ptr)
188 (unless (zerop count) (setf (sm last-char-read-size stream) 1))
189 (return (values count :eof)))
190 ((and search (char= char search))
191 (setf (sm buffpos stream) ptr)
192 ;; Unread of last char must unread the search character, too
193 ;; If no characters were read, just add the length of the
194 ;; search char to that of the previously read char.
196 (incf (sm last-char-read-size stream))
197 (setf (sm last-char-read-size stream) 2))
198 (return (values count t)))
200 (setf (char string posn) char)))))))
202 (declaim (ftype j-unread-char-fn sc-unread-char))
203 (defun sc-unread-char (stream relaxed)
204 (declare (ignore relaxed))
205 (with-stream-class (single-channel-simple-stream stream)
206 (let ((unread (sm last-char-read-size stream)))
207 (if (>= (sm buffpos stream) unread)
208 (decf (sm buffpos stream) unread)
209 (error "Unreading needs work"))
210 (setf (sm last-char-read-size stream) 0))))
212 (declaim (ftype j-write-char-fn sc-write-char))
213 (defun sc-write-char (character stream)
214 (with-stream-class (single-channel-simple-stream stream)
215 (let* ((buffer (sm buffer stream))
216 (ptr (sm buffpos stream))
217 (code (char-code character))
218 (ctrl (sm control-out stream)))
219 (when (and (< code 32) ctrl (svref ctrl code)
220 (funcall (the (or symbol function) (svref ctrl code))
222 (return-from sc-write-char character))
223 ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
224 (unless (< ptr (sm buffer-ptr stream))
225 (sc-flush-buffer stream t)
226 (setf ptr (sm buffpos stream)))
227 (setf (bref buffer ptr) code)
228 (setf (sm buffpos stream) (1+ ptr))))
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))
252 ;; need to update buffpos before control leaves this
253 ;; function in any way
254 (setf (sm buffpos stream) ptr)
255 (sc-flush-buffer stream t)
256 (setf ptr (sm buffpos stream)))
257 (setf (bref buffer ptr) code)
260 (declaim (ftype j-listen-fn sc-listen))
261 (defun sc-listen (stream)
262 (with-stream-class (single-channel-simple-stream stream)
263 (or (< (sm buffpos stream) (sm buffer-ptr stream))
264 (case (device-read stream nil 0 0 nil)
266 (-1 #| latch EOF |# nil)
268 (t (error "DEVICE-READ error."))))))
271 ;;; DUAL-CHANNEL STRATEGY FUNCTIONS
274 (declaim (ftype j-read-char-fn dc-read-char))
275 (defun dc-read-char (stream eof-error-p eof-value blocking)
276 ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
277 (with-stream-class (dual-channel-simple-stream stream)
278 ;; if interactive flag is set, finish-output first
279 (let* ((buffer (sm buffer stream))
280 (ptr (sm buffpos stream))
281 (code (if (< ptr (sm buffer-ptr stream))
283 (setf (sm buffpos stream) (1+ ptr))
285 (let ((bytes (refill-buffer stream blocking)))
286 (declare (type fixnum bytes))
287 (unless (minusp bytes)
288 (let ((ptr (sm buffpos stream)))
289 (setf (sm buffpos stream) (1+ ptr))
290 (bref buffer ptr))))))
291 (char (if code (code-char code) nil))
292 (ctrl (sm control-in stream)))
294 (setf (sm last-char-read-size stream) 1)
295 (when (and (< code 32) ctrl (svref ctrl code))
296 ;; Does this have to be a function, or can it be a symbol?
297 (setq char (funcall (the (or symbol function) (svref ctrl code))
299 #|(let ((column (sm charpos stream)))
300 (declare (type (or null fixnum) column))
302 (setf (sm charpos stream) (1+ column))))|#)
304 (sb-impl::eof-or-lose stream eof-error-p eof-value)
307 (declaim (ftype j-read-chars-fn dc-read-chars))
308 (defun dc-read-chars (stream string search start end blocking)
309 (declare (type dual-channel-simple-stream stream)
311 (type (or null character) search)
312 (type fixnum start end)
313 (type boolean blocking)
314 #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
315 (with-stream-class (dual-channel-simple-stream stream)
316 ;; if interactive flag is set, finish-output first
317 (setf (sm last-char-read-size stream) 0)
318 ;; Should arrange for the last character to be unreadable
319 (do ((buffer (sm buffer stream))
320 (ptr (sm buffpos stream))
321 (max (sm buffer-ptr stream))
322 (posn start (1+ posn))
323 (count 0 (1+ count)))
324 ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
325 (declare (type fixnum ptr max posn count))
326 (let* ((code (if (< ptr max)
330 (let ((bytes (refill-buffer stream blocking)))
331 (declare (type fixnum bytes))
332 (setf ptr (sm buffpos stream)
333 max (sm buffer-ptr stream))
338 (char (if code (code-char code) nil))
339 (ctrl (sm control-in stream)))
340 (when (and code (< code 32) ctrl (svref ctrl code))
341 (setq char (funcall (the (or symbol function) (svref ctrl code))
343 #|(let ((column (sm charpos stream)))
344 (declare (type (or null fixnum) column))
346 (setf (sm charpos stream) (1+ column))))|#
348 (setf (sm buffpos stream) ptr)
349 (return (values count :eof)))
350 ((and search (char= char search))
351 (setf (sm buffpos stream) ptr)
352 (return (values count t)))
354 (setf (char string posn) char)))))))
356 (declaim (ftype j-unread-char-fn dc-unread-char))
357 (defun dc-unread-char (stream relaxed)
358 (declare (ignore relaxed))
359 (with-stream-class (dual-channel-simple-stream stream)
360 (let ((unread (sm last-char-read-size stream)))
361 (if (>= (sm buffpos stream) unread)
362 (decf (sm buffpos stream) unread)
363 (error "Unreading needs work"))
364 (setf (sm last-char-read-size stream) 0))))
366 (declaim (ftype j-write-char-fn dc-write-char))
367 (defun dc-write-char (character stream)
368 (with-stream-class (dual-channel-simple-stream stream)
369 (let* ((buffer (sm out-buffer stream))
370 (ptr (sm outpos stream))
371 (code (char-code character))
372 (ctrl (sm control-out stream)))
373 (when (and (< code 32) ctrl (svref ctrl code)
374 (funcall (the (or symbol function) (svref ctrl code))
376 (return-from dc-write-char character))
377 (unless (< ptr (sm max-out-pos stream))
378 (dc-flush-buffer stream t)
379 (setf ptr (sm outpos stream)))
381 (setf (bref buffer ptr) code)
382 (setf (sm outpos stream) (1+ ptr))
386 (declaim (ftype j-write-chars-fn dc-write-chars))
387 (defun dc-write-chars (string stream start end)
388 (with-stream-class (dual-channel-simple-stream stream)
389 (do ((buffer (sm out-buffer stream))
390 (ptr (sm outpos stream))
391 (max (sm max-out-pos stream))
392 (ctrl (sm control-out stream))
393 (posn start (1+ posn))
394 (count 0 (1+ count)))
395 ((>= posn end) (setf (sm outpos stream) ptr) count)
396 (declare (type fixnum ptr max posn count))
397 (let* ((char (char string posn))
398 (code (char-code char)))
399 (unless (and (< code 32) ctrl (svref ctrl code)
400 (funcall (the (or symbol function) (svref ctrl code))
403 (setf (sm outpos stream) ptr)
404 (dc-flush-buffer stream t)
405 (setf ptr (sm outpos stream)))
406 (setf (bref buffer ptr) code)
410 (declaim (ftype j-listen-fn dc-listen))
411 (defun dc-listen (stream)
412 (with-stream-class (dual-channel-simple-stream stream)
413 (or (< (sm buffpos stream) (sm buffer-ptr stream))
414 (case (device-read stream nil 0 0 nil)
416 (-1 #| latch EOF |# nil)
418 (t (error "DEVICE-READ error."))))))
421 ;;; STRING STRATEGY FUNCTIONS
424 (declaim (ftype j-read-char-fn string-read-char))
425 (defun string-read-char (stream eof-error-p eof-value blocking)
426 (declare (type string-input-simple-stream stream) (ignore blocking)
427 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
428 (with-stream-class (string-input-simple-stream stream)
429 (when (any-stream-instance-flags stream :eof)
430 (sb-impl::eof-or-lose stream eof-error-p eof-value))
431 (let* ((ptr (sm buffpos stream))
432 (char (if (< ptr (sm buffer-ptr stream))
433 (schar (sm buffer stream) ptr)
436 (sb-impl::eof-or-lose stream eof-error-p eof-value)
438 (setf (sm last-char-read-size stream) 1)
439 ;; do string-streams do control-in processing?
440 #|(let ((column (sm charpos stream)))
441 (declare (type (or null fixnum) column))
443 (setf (sm charpos stream) (1+ column))))|#
447 (declaim (ftype j-read-char-fn composing-crlf-read-char))
448 (defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
449 ;; TODO: what about the eof-error-p parameter?
450 (with-stream-class (simple-stream stream)
451 (let* ((melded-stream (sm melded-stream stream))
452 (char (funcall-stm-handler j-read-char melded-stream nil stream
454 ;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
455 ;; character was available...
456 (when (eql char #\Return)
457 (let ((next (funcall-stm-handler j-read-char melded-stream
458 nil stream blocking)))
459 ;; if NEXT is STREAM, we hit EOF, so we should just return the
460 ;; #\Return (and mark the stream :EOF? At least unread if we
461 ;; got a soft EOF, from a terminal, etc.
462 ;; if NEXT is NIL, blocking is NIL and there's a CR but no
463 ;; LF available on the stream: have to unread the CR and
464 ;; return NIL, letting the CR be reread later.
466 ;; If we did get a linefeed, adjust the last-char-read-size
467 ;; so that an unread of the resulting newline will unread both
468 ;; the linefeed _and_ the carriage return.
469 (if (eql next #\Linefeed)
470 (setq char #\Newline)
471 (funcall-stm-handler j-unread-char melded-stream nil))))
472 ;; do control-in processing on whatever character we've got
475 (declaim (ftype j-unread-char-fn composing-crlf-unread-char))
476 (defun composing-crlf-unread-char (stream relaxed)
477 (declare (ignore relaxed))
478 (with-stream-class (simple-stream stream)
479 (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
485 (defun install-single-channel-character-strategy (stream external-format
487 (declare (ignore external-format))
488 ;; ACCESS is usually NIL
489 ;; May be "undocumented" values: stream::buffer, stream::mapped
490 ;; to install strategies suitable for direct buffer streams
491 ;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
492 ;; (Avoids checking "mode" flags by installing special strategy)
493 (with-stream-class (single-channel-simple-stream stream)
494 (if (or (eq access 'buffer) (eq access 'mapped))
495 (setf (sm j-read-char stream) #'sc-read-char--buffer
496 (sm j-read-chars stream) #'sc-read-chars--buffer
497 (sm j-unread-char stream) #'sc-unread-char
498 (sm j-write-char stream) #'sc-write-char
499 (sm j-write-chars stream) #'sc-write-chars
500 (sm j-listen stream) #'sc-listen)
501 (setf (sm j-read-char stream) #'sc-read-char
502 (sm j-read-chars stream) #'sc-read-chars
503 (sm j-unread-char stream) #'sc-unread-char
504 (sm j-write-char stream) #'sc-write-char
505 (sm j-write-chars stream) #'sc-write-chars
506 (sm j-listen stream) #'sc-listen)))
509 (defun install-dual-channel-character-strategy (stream external-format)
510 (declare (ignore external-format))
511 (with-stream-class (dual-channel-simple-stream stream)
512 (setf (sm j-read-char stream) #'dc-read-char
513 (sm j-read-chars stream) #'dc-read-chars
514 (sm j-unread-char stream) #'dc-unread-char
515 (sm j-write-char stream) #'dc-write-char
516 (sm j-write-chars stream) #'dc-write-chars
517 (sm j-listen stream) #'dc-listen))
520 (defun install-string-character-strategy (stream)
521 (with-stream-class (string-simple-stream stream)
522 (setf (sm j-read-char stream) #'string-read-char))