3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
8 ;;; Sbcl port by Rudi Schlatte.
10 (in-package "SB-SIMPLE-STREAMS")
13 ;;; **********************************************************************
15 ;;; Implementations of standard Common Lisp functions for simple-streams
17 (defun %uninitialized (stream)
18 (error "~S has not been initialized." stream))
20 (defun %check (stream kind)
21 (declare (type simple-stream stream)
22 (optimize (speed 3) (space 1) (debug 0) (safety 0)))
23 (with-stream-class (simple-stream stream)
24 (cond ((not (any-stream-instance-flags stream :simple))
25 (%uninitialized stream))
27 (not (any-stream-instance-flags stream :input :output)))
28 (sb-kernel:closed-flame stream))
29 ((and (or (eq kind :input) (eq kind :io))
30 (not (any-stream-instance-flags stream :input)))
31 (sb-kernel:ill-in stream))
32 ((and (or (eq kind :output) (eq kind :io))
33 (not (any-stream-instance-flags stream :output)))
34 (sb-kernel:ill-out stream)))))
36 (defmethod input-stream-p ((stream simple-stream))
37 (any-stream-instance-flags stream :input))
39 (defmethod output-stream-p ((stream simple-stream))
40 (any-stream-instance-flags stream :output))
42 (defmethod open-stream-p ((stream simple-stream))
43 (any-stream-instance-flags stream :input :output))
45 ;;; From the simple-streams documentation: "A generic function implies
46 ;;; a specialization capability that does not exist for
47 ;;; simple-streams; simple-stream specializations should be on
48 ;;; device-close." So don't do it.
49 (defmethod close ((stream simple-stream) &key abort)
50 (device-close stream abort))
52 (defun %file-position (stream position)
53 (declare (type simple-stream stream)
54 (type (or (integer 0 *) (member nil :start :end)) position))
55 (with-stream-class (simple-stream stream)
58 ;; Adjust current position
59 (let ((position (case position (:start 0) (:end -1)
60 (otherwise position))))
62 (single-channel-simple-stream
63 (when (sc-dirty-p stream)
64 (flush-buffer stream t)))
65 (dual-channel-simple-stream
66 (with-stream-class (dual-channel-simple-stream stream)
67 (when (> (sm outpos stream) 0)
68 (device-write stream :flush 0 nil t))))
72 (setf (sm last-char-read-size stream) 0)
73 (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read
74 (sm buffer-ptr stream) 0)
75 (setf (sm charpos stream) nil)
76 (remove-stream-instance-flags stream :eof)
77 (setf (device-file-position stream) position))
78 ;; Just report current position
79 (let ((posn (device-file-position stream)))
81 (when (sm handler stream)
82 (dolist (queued (sm pending stream))
83 (incf posn (- (the sb-int:index (third queued))
84 (the sb-int:index (second queued))))))
86 (single-channel-simple-stream
87 (case (sm mode stream)
88 ((0 3) ; read, read-modify
89 ;; Note that posn can increase here if we wrote
90 ;; past the end of previously-read data
91 (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
93 (incf posn (sm buffpos stream)))))
94 (dual-channel-simple-stream
95 (with-stream-class (dual-channel-simple-stream stream)
96 (incf posn (sm outpos stream))
97 (when (>= (sm buffer-ptr stream) 0)
98 (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))))
103 (defun %file-length (stream)
104 (declare (type simple-stream stream))
105 (%check stream :open)
106 (device-file-length stream))
109 (defun %file-name (stream)
110 (declare (type simple-stream stream))
114 (with-stream-class (file-simple-stream stream)
115 (sm pathname stream)))
117 (with-stream-class (probe-simple-stream stream)
118 (sm pathname stream)))
123 (defun %file-rename (stream new-name)
124 (declare (type simple-stream stream))
126 (if (typep stream 'file-simple-stream)
127 (with-stream-class (file-simple-stream stream)
128 (setf (sm pathname stream) new-name)
129 (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
134 (defun %file-string-length (stream object)
135 (declare (type simple-stream stream))
136 (with-stream-class (simple-stream stream)
137 (%check stream :output)
138 ;; FIXME: need to account for compositions on the stream...
141 (declare (ignore octet))
146 (char-to-octets (sm external-format stream) object x #'fn)))
149 (ef (sm external-format stream)))
150 (dotimes (i (length object))
151 (declare (type sb-int:index i))
152 (char-to-octets ef (char object i) x #'fn))))))
156 (defun %read-line (stream eof-error-p eof-value recursive-p)
157 (declare (optimize (speed 3) (space 1) (safety 0) (debug 0))
158 (type simple-stream stream)
159 (ignore recursive-p))
160 (with-stream-class (simple-stream stream)
161 (%check stream :input)
162 (when (any-stream-instance-flags stream :eof)
163 (return-from %read-line
164 (sb-impl::eof-or-lose stream eof-error-p eof-value)))
165 ;; for interactive streams, finish output first to force prompt
166 (when (and (any-stream-instance-flags stream :output)
167 (any-stream-instance-flags stream :interactive))
168 (%finish-output stream))
169 (let* ((encap (sm melded-stream stream)) ; encapsulating stream
170 (cbuf (make-string 80)) ; current buffer
171 (bufs (list cbuf)) ; list of buffers
172 (tail bufs) ; last cons of bufs list
173 (index 0) ; current index in current buffer
174 (total 0)) ; total characters
175 (declare (type simple-stream encap)
176 (type simple-base-string cbuf)
177 (type cons bufs tail)
178 (type sb-int:index index total))
180 (multiple-value-bind (chars done)
181 (funcall-stm-handler j-read-chars encap cbuf
182 #\Newline index (length cbuf) t)
183 (declare (type sb-int:index chars))
186 (when (and (eq done :eof) (zerop total))
188 (error 'end-of-file :stream stream)
189 (return (values eof-value t))))
191 ;; If there's only one buffer in use, return it directly
192 (when (null (cdr bufs))
193 (return (values (sb-kernel:shrink-vector cbuf total)
195 ;; If total fits in final buffer, use it
196 (when (<= total (length cbuf))
197 (replace cbuf cbuf :start1 (- total index) :end2 index)
199 (declare (type sb-int:index idx))
200 (do ((list bufs (cdr list)))
202 (let ((buf (car list)))
203 (declare (type simple-base-string buf))
204 (replace cbuf buf :start1 idx)
205 (incf idx (length buf)))))
206 (return (values (sb-kernel:shrink-vector cbuf total)
208 ;; Allocate new string of appropriate length
209 (let ((string (make-string total))
211 (declare (type sb-int:index index))
213 (declare (type simple-base-string buf))
214 (replace string buf :start1 index)
215 (incf index (length buf)))
216 (return (values string (eq done :eof)))))
217 (when (>= index (length cbuf))
218 (setf cbuf (make-string (the sb-int:index (* 2 index))))
220 (setf (cdr tail) (cons cbuf nil))
221 (setf tail (cdr tail))))))))
223 (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
224 (declare (type simple-stream stream)
225 (ignore recursive-p))
226 (with-stream-class (simple-stream stream)
227 (%check stream :input)
228 (when (any-stream-instance-flags stream :eof)
229 (return-from %read-char
230 (sb-impl::eof-or-lose stream eof-error-p eof-value)))
231 ;; for interactive streams, finish output first to force prompt
232 (when (and (any-stream-instance-flags stream :output)
233 (any-stream-instance-flags stream :interactive))
234 (%finish-output stream))
235 (funcall-stm-handler j-read-char (sm melded-stream stream)
236 eof-error-p eof-value blocking-p)))
239 (defun %unread-char (stream character)
240 (declare (type simple-stream stream) (ignore character))
241 (with-stream-class (simple-stream stream)
242 (%check stream :input)
243 (if (zerop (sm last-char-read-size stream))
244 (error "Nothing to unread.")
246 (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
247 (remove-stream-instance-flags stream :eof)
248 (setf (sm last-char-read-size stream) 0)))))
251 (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
252 (declare (type simple-stream stream)
253 (ignore recursive-p))
254 (with-stream-class (simple-stream stream)
255 (%check stream :input)
256 (when (any-stream-instance-flags stream :eof)
257 (return-from %peek-char
258 (sb-impl::eof-or-lose stream eof-error-p eof-value)))
259 (let* ((encap (sm melded-stream stream))
260 (char (funcall-stm-handler j-read-char encap
261 eof-error-p stream t)))
262 (cond ((eq char stream) eof-value)
263 ((characterp peek-type)
264 (do ((char char (funcall-stm-handler j-read-char encap
267 ((or (eq char stream) (char= char peek-type))
268 (unless (eq char stream)
269 (funcall-stm-handler j-unread-char encap t))
270 (if (eq char stream) eof-value char))))
272 (do ((char char (funcall-stm-handler j-read-char encap
275 ((or (eq char stream)
276 (not (sb-impl::whitespacep char)))
277 (unless (eq char stream)
278 (funcall-stm-handler j-unread-char encap t))
279 (if (eq char stream) eof-value char))))
281 (funcall-stm-handler j-unread-char encap t)
284 (defun %listen (stream width)
285 (declare (type simple-stream stream))
286 ;; WIDTH is number of octets which must be available; any value
287 ;; other than 1 is treated as 'character.
288 (with-stream-class (simple-stream stream)
289 (%check stream :input)
290 (when (any-stream-instance-flags stream :eof)
291 (return-from %listen nil))
292 (if (not (or (eql width 1) (null width)))
293 (funcall-stm-handler j-listen (sm melded-stream stream))
294 (or (< (sm buffpos stream) (sm buffer-ptr stream))
295 (when (or (not (any-stream-instance-flags stream :dual :string))
296 (>= (sm mode stream) 0)) ;; device-connected @@ single-channel
297 (let ((lcrs (sm last-char-read-size stream)))
300 (setf (sm last-char-read-size stream) (1+ lcrs))
301 (plusp (refill-buffer stream nil)))
302 (setf (sm last-char-read-size stream) lcrs))))))))
304 (defun %clear-input (stream buffer-only)
305 (declare (type simple-stream stream))
306 (with-stream-class (simple-stream stream)
307 (%check stream :input)
308 (setf (sm buffpos stream) 0
309 (sm buffer-ptr stream) 0
310 (sm last-char-read-size stream) 0
311 #|(sm unread-past-soft-eof stream) nil|#)
312 #| (setf (sm reread-count stream) 0) on dual-channel streams? |#
314 (device-clear-input stream buffer-only))
317 (defun %read-byte (stream eof-error-p eof-value)
318 (declare (type simple-stream stream))
319 (with-stream-class (simple-stream stream)
320 (%check stream :input)
321 (if (any-stream-instance-flags stream :eof)
322 (sb-impl::eof-or-lose stream eof-error-p eof-value)
324 (single-channel-simple-stream
325 (read-byte-internal stream eof-error-p eof-value t))
326 (dual-channel-simple-stream
327 (read-byte-internal stream eof-error-p eof-value t))
328 (string-simple-stream
329 (with-stream-class (string-simple-stream stream)
330 (let ((encap (sm input-handle stream)))
332 (error 'simple-type-error
334 :expected-type 'stream
335 :format-control "Can't read-byte on string streams"
336 :format-arguments '()))
338 (read-byte encap eof-error-p eof-value)
339 (setf (sm last-char-read-size stream) 0
340 (sm encapsulated-char-read-size stream) 0)))))))))
343 (defun %write-char (stream character)
344 (declare (type simple-stream stream))
345 (with-stream-class (simple-stream stream)
346 (%check stream :output)
347 (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
350 (defun %fresh-line (stream)
351 (declare (type simple-stream stream))
352 (with-stream-class (simple-stream stream)
353 (%check stream :output)
354 (when (/= (or (sm charpos stream) 1) 0)
355 (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
359 (defun %write-string (stream string start end)
360 (declare (type simple-stream stream))
361 (with-stream-class (simple-stream stream)
362 (%check stream :output)
363 (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
367 (defun %line-length (stream)
368 (declare (type simple-stream stream))
369 (%check stream :output)
374 (defun %finish-output (stream)
375 (declare (type simple-stream stream))
376 (with-stream-class (simple-stream stream)
377 (%check stream :output)
378 (when (sm handler stream)
380 ((null (sm pending stream)))
381 (sb-sys:serve-all-events)))
383 (single-channel-simple-stream
384 ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
385 ; (setf (device-file-position stream)
386 ; (- (device-file-position stream) (sm buffer-ptr stream))))
387 ;(device-write stream :flush 0 nil t)
388 (flush-buffer stream t)
389 (setf (sm buffpos stream) 0))
390 (dual-channel-simple-stream
391 (with-stream-class (dual-channel-simple-stream stream)
392 (device-write stream :flush 0 nil t)
393 (setf (sm outpos stream) 0)))
394 (string-simple-stream
395 (device-write stream :flush 0 nil t))))
399 (defun %force-output (stream)
400 (declare (type simple-stream stream))
401 (with-stream-class (simple-stream stream)
402 (%check stream :output)
404 (single-channel-simple-stream
405 ;(when (> (sm buffer-ptr stream) 0)
406 ; (setf (device-file-position stream)
407 ; (- (device-file-position stream) (sm buffer-ptr stream))))
408 ;(device-write stream :flush 0 nil nil)
409 (flush-buffer stream nil)
410 (setf (sm buffpos stream) 0))
411 (dual-channel-simple-stream
412 (with-stream-class (dual-channel-simple-stream stream)
413 (device-write stream :flush 0 nil nil)
414 (setf (sm outpos stream) 0)))
415 (string-simple-stream
416 (device-write stream :flush 0 nil nil))))
420 (defun %clear-output (stream)
421 (declare (type simple-stream stream))
422 (with-stream-class (simple-stream stream)
423 (%check stream :output)
424 (when (sm handler stream)
425 (sb-sys:remove-fd-handler (sm handler stream))
426 (setf (sm handler stream) nil
427 (sm pending stream) nil))
429 (single-channel-simple-stream
430 (with-stream-class (single-channel-simple-stream stream)
431 (case (sm mode stream)
432 (1 (setf (sm buffpos stream) 0))
433 (3 (setf (sm mode stream) 0)))))
434 (dual-channel-simple-stream
435 (setf (sm outpos stream) 0))
436 (string-simple-stream
438 (device-clear-output stream)))
441 (defun %write-byte (stream integer)
442 (declare (type simple-stream stream))
443 (with-stream-class (simple-stream stream)
444 (%check stream :output)
446 (single-channel-simple-stream
447 (with-stream-class (single-channel-simple-stream stream)
448 (let ((ptr (sm buffpos stream)))
449 (when (>= ptr (sm buf-len stream))
450 (setf ptr (flush-buffer stream t)))
451 (setf (sm buffpos stream) (1+ ptr))
452 (setf (sm charpos stream) nil)
453 (setf (bref (sm buffer stream) ptr) integer)
454 (sc-set-dirty stream))))
455 (dual-channel-simple-stream
456 (with-stream-class (dual-channel-simple-stream stream)
457 (let ((ptr (sm outpos stream)))
458 (when (>= ptr (sm max-out-pos stream))
459 (setf ptr (flush-out-buffer stream t)))
460 (setf (sm outpos stream) (1+ ptr))
461 (setf (sm charpos stream) nil)
462 (setf (bref (sm out-buffer stream) ptr) integer))))
463 (string-simple-stream
464 (with-stream-class (string-simple-stream stream)
465 (let ((encap (sm output-handle stream)))
467 (error 'simple-type-error
469 :expected-type 'stream
470 :format-control "Can't write-byte on string streams."
471 :format-arguments '()))
472 (write-byte integer encap)))))))
475 (defun %read-sequence (stream seq start end partial-fill)
476 (declare (type simple-stream stream)
478 (type sb-int:index start)
479 (type (or null sb-int:index) end)
480 (type boolean partial-fill))
481 (with-stream-class (simple-stream stream)
482 (%check stream :input)
483 (when (any-stream-instance-flags stream :eof)
484 (return-from %read-sequence 0))
487 (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
488 start (or end (length seq))
489 (if partial-fill :bnb t)))
490 ((or (simple-array (unsigned-byte 8) (*))
491 (simple-array (signed-byte 8) (*)))
492 ;; "read-vector" equivalent, but blocking if partial-fill is NIL
493 (error "implement me")
495 ;; extend to work on other sequences: repeated read-byte
499 (defun %write-sequence (stream seq start end)
500 (declare (type simple-stream stream)
502 (type sb-int:index start)
503 (type (or null sb-int:index) end))
504 (with-stream-class (simple-stream stream)
505 (%check stream :output)
508 (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
509 start (or end (length seq))))
510 ((or (simple-array (unsigned-byte 8) (*))
511 (simple-array (signed-byte 8) (*)))
512 ;; "write-vector" equivalent
513 (setf (sm charpos stream) nil)
515 (single-channel-simple-stream
516 (with-stream-class (single-channel-simple-stream stream)
517 (loop with max-ptr = (sm buf-len stream)
518 with real-end = (or end (length seq))
519 for src-pos = start then (+ src-pos count)
520 for src-rest = (- real-end src-pos)
521 while (> src-rest 0) ; FIXME: this is non-ANSI
522 for ptr = (let ((ptr (sm buffpos stream)))
524 (flush-buffer stream t)
526 for buf-rest = (- max-ptr ptr)
527 for count = (min buf-rest src-rest)
528 do (progn (setf (sm mode stream) 1)
529 (setf (sm buffpos stream) (+ ptr count))
530 (buffer-copy seq src-pos (sm buffer stream) ptr count)))))
531 (dual-channel-simple-stream
532 (error "Implement me"))
533 (string-simple-stream
534 (error 'simple-type-error
536 :expected-type 'stream
537 :format-control "Can't write-byte on string streams."
538 :format-arguments '())))
540 ;; extend to work on other sequences: repeated write-byte
544 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
545 (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
546 (type stream stream))
547 ;; START and END are octet offsets, not vector indices! [Except for strings]
548 ;; Return value is index of next octet to be read into (i.e., start+count)
551 (with-stream-class (simple-stream stream)
553 (let* ((start (or start 0))
554 (end (or end (length vector)))
555 (encap (sm melded-stream stream))
556 (char (funcall-stm-handler j-read-char encap nil nil t)))
558 (setf (schar vector start) char)
560 (+ start (funcall-stm-handler j-read-chars encap vector nil
562 (do* ((j-read-byte (if (any-stream-instance-flags stream :string)
563 (error "Can't READ-BYTE on string streams.")
564 #'read-byte-internal))
565 (encap (sm melded-stream stream))
566 (index (or start 0) (1+ index))
567 (end (or end (* (length vector) (vector-elt-width vector))))
568 (endian-swap (endian-swap-value vector endian-swap))
569 (byte (funcall j-read-byte encap nil nil t)
570 (funcall j-read-byte encap nil nil nil)))
571 ((or (null byte) (>= index end)) index)
572 (setf (bref vector (logxor index endian-swap)) byte)))))
573 ((or ansi-stream fundamental-stream)
574 (unless (typep vector '(or string
575 (simple-array (signed-byte 8) (*))
576 (simple-array (unsigned-byte 8) (*))))
577 (error "Wrong vector type for read-vector on stream not of type simple-stream."))
578 (read-sequence vector stream :start (or start 0) :end end))))
580 ;;; Basic functionality for ansi-streams. These are separate
581 ;;; functions because they are called in places where we already know
582 ;;; we operate on an ansi-stream (as opposed to a simple- or
583 ;;; gray-stream, or the symbols t or nil), so we can evade typecase
584 ;;; and (in|out)-synonym-of calls.
586 (declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
587 %ansi-stream-unread-char %ansi-stream-read-line
588 %ansi-stream-read-sequence))
590 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
591 (declare (ignore blocking))
593 (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
594 (sb-int:prepare-for-fast-read-byte stream
596 (sb-int:fast-read-byte eof-error-p eof-value t)
597 (sb-int:done-with-fast-read-byte))))
599 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
600 (declare (ignore blocking))
602 (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
603 (sb-int:prepare-for-fast-read-char stream
605 (sb-int:fast-read-char eof-error-p eof-value)
606 (sb-int:done-with-fast-read-char))))
608 (defun %ansi-stream-unread-char (character stream)
609 (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
610 (buffer (sb-kernel:ansi-stream-in-buffer stream)))
611 (declare (fixnum index))
612 (when (minusp index) (error "nothing to unread"))
614 (setf (aref buffer index) (char-code character))
615 (setf (sb-kernel:ansi-stream-in-index stream) index))
617 (funcall (sb-kernel:ansi-stream-misc stream) stream
618 :unread character)))))
620 (defun %ansi-stream-read-line (stream eof-error-p eof-value)
621 (sb-int:prepare-for-fast-read-char stream
622 (let ((res (make-string 80))
626 (let ((ch (sb-int:fast-read-char nil nil)))
628 (when (char= ch #\newline)
629 (sb-int:done-with-fast-read-char)
630 (return (values (sb-kernel:shrink-vector res index) nil)))
633 (let ((new (make-string len)))
636 (setf (schar res index) ch)
639 (sb-int:done-with-fast-read-char)
640 (return (values (sb-impl::eof-or-lose stream eof-error-p
643 ;; Since FAST-READ-CHAR already hit the eof char, we
644 ;; shouldn't do another READ-CHAR.
646 (sb-int:done-with-fast-read-char)
647 (return (values (sb-kernel:shrink-vector res index) t)))))))))
649 (defun %ansi-stream-read-sequence (seq stream start %end)
650 (declare (type sequence seq)
651 (type sb-kernel:ansi-stream stream)
652 (type sb-int:index start)
653 (type sb-kernel:sequence-end %end)
654 (values sb-int:index))
655 (let ((end (or %end (length seq))))
656 (declare (type sb-int:index end))
660 (if (subtypep (stream-element-type stream) 'character)
661 #'%ansi-stream-read-char
662 #'%ansi-stream-read-byte)))
663 (do ((rem (nthcdr start seq) (rest rem))
665 ((or (endp rem) (>= i end)) i)
666 (declare (type list rem)
667 (type sb-int:index i))
668 (let ((el (funcall read-function stream nil :eof nil)))
671 (setf (first rem) el)))))
673 (sb-kernel:with-array-data ((data seq) (offset-start start)
676 ((or (simple-array (unsigned-byte 8) (*))
677 (simple-array (signed-byte 8) (*))
679 (let* ((numbytes (- end start))
680 (bytes-read (sb-sys:read-n-bytes stream
685 (if (< bytes-read numbytes)
690 (if (subtypep (stream-element-type stream) 'character)
691 #'%ansi-stream-read-char
692 #'%ansi-stream-read-byte)))
693 (do ((i offset-start (1+ i)))
694 ((>= i offset-end) end)
695 (declare (type sb-int:index i))
696 (let ((el (funcall read-function stream nil :eof nil)))
698 (return (+ start (- i offset-start))))
699 (setf (aref data i) el)))))))))))
702 (defun %ansi-stream-write-string (string stream start end)
703 (declare (type string string)
704 (type sb-kernel:ansi-stream stream)
705 (type sb-int:index start end))
707 ;; Note that even though you might expect, based on the behavior of
708 ;; things like AREF, that the correct upper bound here is
709 ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
710 ;; "bounding index" and "length" indicate that in this case (i.e.
711 ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
712 ;; which are implemented in terms of this function), (LENGTH STRING)
713 ;; is the required upper bound. A foolish consistency is the
714 ;; hobgoblin of lesser languages..
715 (unless (<= 0 start end (length string))
716 (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
721 (if (sb-kernel:array-header-p string)
722 (sb-kernel:with-array-data ((data string) (offset-start start)
724 (funcall (sb-kernel:ansi-stream-sout stream)
725 stream data offset-start offset-end))
726 (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
729 (defun %ansi-stream-write-sequence (seq stream start %end)
730 (declare (type sequence seq)
731 (type sb-kernel:ansi-stream stream)
732 (type sb-int:index start)
733 (type sb-kernel:sequence-end %end)
735 (let ((end (or %end (length seq))))
736 (declare (type sb-int:index end))
739 (let ((write-function
740 (if (subtypep (stream-element-type stream) 'character)
741 ;; TODO: Replace these with ansi-stream specific
745 (do ((rem (nthcdr start seq) (rest rem))
747 ((or (endp rem) (>= i end)) seq)
748 (declare (type list rem)
749 (type sb-int:index i))
750 (funcall write-function (first rem) stream))))
752 (%ansi-stream-write-string seq stream start end))
754 (let ((write-function
755 (if (subtypep (stream-element-type stream) 'character)
756 ;; TODO: Replace these with ansi-stream specific
760 (do ((i start (1+ i)))
762 (declare (type sb-int:index i))
763 (funcall write-function (aref seq i) stream)))))))
767 ;;; USER-LEVEL FUNCTIONS
770 (defmethod open-stream-p ((stream simple-stream))
771 (any-stream-instance-flags stream :input :output))
773 (defmethod input-stream-p ((stream simple-stream))
774 (any-stream-instance-flags stream :input))
776 (defmethod output-stream-p ((stream simple-stream))
777 (any-stream-instance-flags stream :output))
779 (defmethod stream-element-type ((stream simple-stream))
782 (defun interactive-stream-p (stream)
783 "Return true if Stream does I/O on a terminal or other interactive device."
786 (%check stream :open)
787 (any-stream-instance-flags stream :interactive))
789 (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
793 (defun (setf interactive-stream-p) (flag stream)
796 (%check stream :open)
798 (add-stream-instance-flags stream :interactive)
799 (remove-stream-instance-flags stream :interactive)))
801 (error 'simple-type-error
803 :expected-type 'simple-stream
804 :format-control "Can't set interactive flag on ~S."
805 :format-arguments (list stream)))))
807 (defun file-string-length (stream object)
808 (declare (type (or string character) object) (type stream stream))
809 "Return the delta in STREAM's FILE-POSITION that would be caused by writing
810 OBJECT to STREAM. Non-trivial only in implementations that support
811 international character sets."
813 (simple-stream (%file-string-length stream object))
817 (string (length object))))))
819 (defun stream-external-format (stream)
820 "Returns Stream's external-format."
823 (with-stream-class (simple-stream)
824 (%check stream :open)
825 (sm external-format stream)))
831 (defun open (filename &rest options
832 &key (direction :input)
833 (element-type 'character element-type-given)
834 if-exists if-does-not-exist
835 (external-format :default)
836 class mapped input-handle output-handle
838 "Return a stream which reads from or writes to Filename.
840 :direction - one of :input, :output, :io, or :probe
841 :element-type - type of object to read or write, default BASE-CHAR
842 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
843 :overwrite, :append, :supersede or NIL
844 :if-does-not-exist - one of :error, :create or NIL
845 :external-format - :default
846 See the manual for details.
848 The following are simple-streams-specific additions:
849 :class - class of stream object to be created
850 :mapped - T to open a memory-mapped file
851 :input-handle - a stream or Unix file descriptor to read from
852 :output-handle - a stream or Unix file descriptor to write to"
853 (declare (ignore element-type external-format input-handle output-handle
854 if-exists if-does-not-exist))
855 (let ((class (or class 'sb-sys::file-stream))
856 (options (copy-list options))
857 (filespec (merge-pathnames filename)))
858 (cond ((eq class 'sb-sys::file-stream)
859 (remf options :class)
860 (remf options :mapped)
861 (remf options :input-handle)
862 (remf options :output-handle)
863 (apply #'open-fd-stream filespec options))
864 ((subtypep class 'simple-stream)
865 (when element-type-given
866 (cerror "Do it anyway."
867 "Can't create simple-streams with an element-type."))
868 (when (and (eq class 'file-simple-stream) mapped)
869 (setq class 'mapped-file-simple-stream)
870 (setf (getf options :class) 'mapped-file-simple-stream))
871 (when (subtypep class 'file-simple-stream)
872 (when (eq direction :probe)
873 (setq class 'probe-simple-stream)))
874 (apply #'make-instance class :filename filespec options))
875 ((subtypep class 'sb-gray:fundamental-stream)
876 (remf options :class)
877 (remf options :mapped)
878 (remf options :input-handle)
879 (remf options :output-handle)
880 (make-instance class :lisp-stream
881 (apply #'open-fd-stream filespec options))))))
884 (declaim (inline read-byte read-char read-char-no-hang unread-char))
886 (defun read-byte (stream &optional (eof-error-p t) eof-value)
887 "Returns the next byte of the Stream."
888 (let ((stream (sb-impl::in-synonym-of stream)))
891 (%read-byte stream eof-error-p eof-value))
893 (%ansi-stream-read-byte stream eof-error-p eof-value t))
895 (let ((char (sb-gray:stream-read-byte stream)))
897 (sb-impl::eof-or-lose stream eof-error-p eof-value)
900 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
901 eof-value recursive-p)
902 "Inputs a character from Stream and returns it."
903 (let ((stream (sb-impl::in-synonym-of stream)))
906 (%read-char stream eof-error-p eof-value recursive-p t))
908 (%ansi-stream-read-char stream eof-error-p eof-value t))
910 (let ((char (sb-gray:stream-read-char stream)))
912 (sb-impl::eof-or-lose stream eof-error-p eof-value)
915 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
916 eof-value recursive-p)
917 "Returns the next character from the Stream if one is availible, or nil."
918 (declare (ignore recursive-p))
919 (let ((stream (sb-impl::in-synonym-of stream)))
922 (%check stream :input)
923 (with-stream-class (simple-stream)
924 (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
926 (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
927 (%ansi-stream-read-char stream eof-error-p eof-value t)
930 (let ((char (sb-gray:stream-read-char-no-hang stream)))
932 (sb-impl::eof-or-lose stream eof-error-p eof-value)
935 (defun unread-char (character &optional (stream *standard-input*))
936 "Puts the Character back on the front of the input Stream."
937 (let ((stream (sb-impl::in-synonym-of stream)))
940 (%unread-char stream character))
942 (%ansi-stream-unread-char character stream))
944 (sb-gray:stream-unread-char stream character))))
947 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
949 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
950 (eof-error-p t) eof-value recursive-p)
951 "Peeks at the next character in the input Stream. See manual for details."
952 (let ((stream (sb-impl::in-synonym-of stream)))
955 (%peek-char stream peek-type eof-error-p eof-value recursive-p))
957 (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
958 (cond ((eq char eof-value) char)
959 ((characterp peek-type)
960 (do ((char char (%ansi-stream-read-char stream eof-error-p
962 ((or (eq char eof-value) (char= char peek-type))
963 (unless (eq char eof-value)
964 (%ansi-stream-unread-char char stream))
967 (do ((char char (%ansi-stream-read-char stream eof-error-p
969 ((or (eq char eof-value)
970 (not (sb-int:whitespace-char-p char)))
971 (unless (eq char eof-value)
972 (%ansi-stream-unread-char char stream))
975 (%ansi-stream-unread-char char stream)
978 (cond ((characterp peek-type)
979 (do ((char (sb-gray:stream-read-char stream)
980 (sb-gray:stream-read-char stream)))
981 ((or (eq char :eof) (char= char peek-type))
982 (cond ((eq char :eof)
983 (sb-impl::eof-or-lose stream eof-error-p eof-value))
985 (sb-gray:stream-unread-char stream char)
988 (do ((char (sb-gray:stream-read-char stream)
989 (sb-gray:stream-read-char stream)))
990 ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
991 (cond ((eq char :eof)
992 (sb-impl::eof-or-lose stream eof-error-p eof-value))
994 (sb-gray:stream-unread-char stream char)
997 (let ((char (sb-gray:stream-peek-char stream)))
999 (sb-impl::eof-or-lose stream eof-error-p eof-value)
1002 (defun listen (&optional (stream *standard-input*) (width 1))
1003 "Returns T if Width octets are available on the given Stream. If Width
1004 is given as 'character, check for a character."
1005 ;; WIDTH is number of octets which must be available; any value
1006 ;; other than 1 is treated as 'character.
1007 (let ((stream (sb-impl::in-synonym-of stream)))
1010 (%listen stream width))
1012 (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
1013 sb-impl::+ansi-stream-in-buffer-length+)
1014 ;; Test for T explicitly since misc methods return :EOF sometimes.
1015 (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
1018 (sb-gray:stream-listen stream)))))
1021 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
1022 eof-value recursive-p)
1023 "Returns a line of text read from the Stream as a string, discarding the
1025 (let ((stream (sb-impl::in-synonym-of stream)))
1028 (%read-line stream eof-error-p eof-value recursive-p))
1030 (%ansi-stream-read-line stream eof-error-p eof-value))
1032 (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
1033 (if (and eof (zerop (length string)))
1034 (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
1035 (values string eof)))))))
1037 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
1038 "Destructively modify SEQ by reading elements from STREAM.
1039 SEQ is bounded by START and END. SEQ is destructively modified by
1040 copying successive elements into it from STREAM. If the end of file
1041 for STREAM is reached before copying all elements of the subsequence,
1042 then the extra elements near the end of sequence are not updated, and
1043 the index of the next element is returned."
1044 (let ((stream (sb-impl::in-synonym-of stream))
1045 (end (or end (length seq))))
1048 (with-stream-class (simple-stream stream)
1049 (%read-sequence stream seq start end partial-fill)))
1051 (%ansi-stream-read-sequence seq stream start end))
1053 (sb-gray:stream-read-sequence stream seq start end)))))
1055 (defun clear-input (&optional (stream *standard-input*) buffer-only)
1056 "Clears any buffered input associated with the Stream."
1057 (let ((stream (sb-impl::in-synonym-of stream)))
1060 (%clear-input stream buffer-only))
1062 (setf (sb-kernel:ansi-stream-in-index stream)
1063 sb-impl::+ansi-stream-in-buffer-length+)
1064 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
1066 (sb-gray:stream-clear-input stream))))
1069 (defun write-byte (integer stream)
1070 "Outputs an octet to the Stream."
1071 (let ((stream (sb-impl::out-synonym-of stream)))
1074 (%write-byte stream integer))
1076 (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
1078 (sb-gray:stream-write-byte stream integer))))
1081 (defun write-char (character &optional (stream *standard-output*))
1082 "Outputs the Character to the Stream."
1083 (let ((stream (sb-impl::out-synonym-of stream)))
1086 (%write-char stream character))
1088 (funcall (sb-kernel:ansi-stream-out stream) stream character))
1090 (sb-gray:stream-write-char stream character))))
1093 (defun write-string (string &optional (stream *standard-output*)
1094 &key (start 0) (end nil))
1095 "Outputs the String to the given Stream."
1096 (let ((stream (sb-impl::out-synonym-of stream))
1097 (end (or end (length string))))
1100 (%write-string stream string start end)
1103 (%ansi-stream-write-string string stream start end))
1105 (sb-gray:stream-write-string stream string start end)))))
1107 (defun write-line (string &optional (stream *standard-output*)
1109 (declare (type string string))
1110 ;; FIXME: Why is there this difference between the treatments of the
1111 ;; STREAM argument in WRITE-STRING and WRITE-LINE?
1112 (let ((stream (sb-impl::out-synonym-of stream))
1113 (end (or end (length string))))
1116 (%check stream :output)
1117 (with-stream-class (simple-stream stream)
1118 (funcall-stm-handler-2 j-write-chars string stream start end)
1119 (funcall-stm-handler-2 j-write-char #\Newline stream)))
1121 (%ansi-stream-write-string string stream start end)
1122 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
1124 (sb-gray:stream-write-string stream string start end)
1125 (sb-gray:stream-terpri stream))))
1128 (defun write-sequence (seq stream &key (start 0) (end nil))
1129 "Write the elements of SEQ bounded by START and END to STREAM."
1130 (let ((stream (sb-impl::out-synonym-of stream))
1131 (end (or end (length seq))))
1134 (%write-sequence stream seq start end))
1136 (%ansi-stream-write-sequence seq stream start end))
1138 (sb-gray:stream-write-sequence stream seq start end)))))
1140 (defun terpri (&optional (stream *standard-output*))
1141 "Outputs a new line to the Stream."
1142 (let ((stream (sb-impl::out-synonym-of stream)))
1145 (%check stream :output)
1146 (with-stream-class (simple-stream stream)
1147 (funcall-stm-handler-2 j-write-char #\Newline stream)))
1149 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
1151 (sb-gray:stream-terpri stream))))
1154 (defun fresh-line (&optional (stream *standard-output*))
1155 "Outputs a new line to the Stream if it is not positioned at the beginning of
1156 a line. Returns T if it output a new line, nil otherwise."
1157 (let ((stream (sb-impl::out-synonym-of stream)))
1160 (%fresh-line stream))
1162 (when (/= (or (sb-kernel:charpos stream) 1) 0)
1163 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
1166 (sb-gray:stream-fresh-line stream)))))
1168 (defun finish-output (&optional (stream *standard-output*))
1169 "Attempts to ensure that all output sent to the Stream has reached its
1170 destination, and only then returns."
1171 (let ((stream (sb-impl::out-synonym-of stream)))
1174 (%finish-output stream))
1176 (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
1178 (sb-gray:stream-finish-output stream))))
1181 (defun force-output (&optional (stream *standard-output*))
1182 "Attempts to force any buffered output to be sent."
1183 (let ((stream (sb-impl::out-synonym-of stream)))
1186 (%force-output stream))
1188 (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
1190 (sb-gray:stream-force-output stream))))
1193 (defun clear-output (&optional (stream *standard-output*))
1194 "Clears the given output Stream."
1195 (let ((stream (sb-impl::out-synonym-of stream)))
1198 (%clear-output stream))
1200 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
1202 (sb-gray:stream-clear-output stream))))
1206 (defun file-position (stream &optional position)
1207 "With one argument returns the current position within the file
1208 File-Stream is open to. If the second argument is supplied, then
1209 this becomes the new file position. The second argument may also
1210 be :start or :end for the start and end of the file, respectively."
1211 (declare (type (or (integer 0 *) (member nil :start :end)) position))
1214 (%file-position stream position))
1218 (setf (sb-kernel:ansi-stream-in-index stream)
1219 sb-impl::+ansi-stream-in-buffer-length+)
1220 (funcall (sb-kernel:ansi-stream-misc stream)
1221 stream :file-position position))
1223 (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
1224 stream :file-position nil)))
1227 (- sb-impl::+ansi-stream-in-buffer-length+
1228 (sb-kernel:ansi-stream-in-index stream))))))))))
1230 (defun file-length (stream)
1231 "This function returns the length of the file that File-Stream is open to."
1234 (%file-length stream))
1236 (progn (sb-impl::stream-must-be-associated-with-file stream)
1237 (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
1239 (defun charpos (&optional (stream *standard-output*))
1240 "Returns the number of characters on the current line of output of the given
1241 Stream, or Nil if that information is not availible."
1242 (let ((stream (sb-impl::out-synonym-of stream)))
1245 (with-stream-class (simple-stream stream)
1246 (%check stream :open)
1247 (sm charpos stream)))
1249 (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
1251 (sb-gray:stream-line-column stream)))))
1253 (defun line-length (&optional (stream *standard-output*))
1254 "Returns the number of characters in a line of output of the given
1255 Stream, or Nil if that information is not availible."
1256 (let ((stream (sb-impl::out-synonym-of stream)))
1259 (%check stream :output)
1260 ;; TODO (sat 2003-04-02): a way to specify a line length would
1261 ;; be good, I suppose. Returning nil here means
1262 ;; sb-pretty::default-line-length is used.
1265 (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
1267 (sb-gray:stream-line-length stream)))))
1269 (defun wait-for-input-available (stream &optional timeout)
1270 "Waits for input to become available on the Stream and returns T. If
1271 Timeout expires, Nil is returned."
1272 (let ((stream (sb-impl::in-synonym-of stream)))
1275 (sb-sys:wait-until-fd-usable stream :input timeout))
1277 (%check stream :input)
1278 (with-stream-class (simple-stream stream)
1279 (or (< (sm buffpos stream) (sm buffer-ptr stream))
1280 (wait-for-input-available (sm input-handle stream) timeout))))
1282 (wait-for-input-available (two-way-stream-input-stream stream) timeout))
1284 (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
1286 (sb-sys::file-stream
1287 (or (< (sb-impl::fd-stream-in-index stream)
1288 (length (sb-impl::fd-stream-in-buffer stream)))
1289 (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
1291 ;; Make PATHNAME and NAMESTRING work
1292 (defun sb-int:file-name (stream &optional new-name)
1295 (with-stream-class (file-simple-stream stream)
1297 (%file-rename stream new-name))
1299 (%file-name stream)))))
1300 (sb-sys::file-stream
1302 (setf (sb-impl::fd-stream-pathname stream) new-name)
1303 (setf (sb-impl::fd-stream-file stream)
1304 (sb-int:unix-namestring new-name nil))
1307 (sb-impl::fd-stream-pathname stream))))))
1311 ;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or
1314 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1315 (declare (type fundamental-stream stream) ;; this is a lie
1319 (ext:stream-listen stream))
1321 (ext:stream-unread-char stream arg1))
1325 (ext:stream-clear-input stream))
1327 (ext:stream-force-output stream))
1329 (ext:stream-finish-output stream))
1331 (stream-element-type stream))
1333 (interactive-stream-p stream))
1335 (ext:stream-line-length stream))
1337 (ext:stream-line-column stream))
1339 (file-length stream))
1341 (file-position stream arg1))))