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")
11 ;;; Implementations of standard Common Lisp functions for simple-streams
13 (defmacro %check-simple-stream (stream &optional direction)
14 ;; Check that STREAM is valid and open in the appropriate direction.
16 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
17 (with-stream-class (simple-stream ,stream)
18 (let ((flags (sm %flags ,stream)))
19 (cond ((zerop (logand flags ,(%flags '(:simple))))
20 (error "~S is not properly initialized." stream))
21 ((zerop (logand flags ,(%flags '(:input :output))))
22 (error "~S is closed." stream))
24 `(((zerop (logand flags ,(%flags (list direction))))
25 (error ,(format nil "~~S is not an ~(~A~) stream."
30 (defun %simple-stream-file-position (stream position)
31 (if (typep stream 'file-simple-stream)
32 (with-stream-class (file-simple-stream stream)
34 (let ((posn (device-file-position stream)))
36 ;; Adjust for data read from device but not yet
37 ;; consumed from buffer, or written after the end of
39 (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
42 (setf (sm last-char-read-size stream) 0)
44 (cond ((numberp position) position)
45 ((eq position :start) 0)
47 (%simple-stream-file-length stream))
48 (t (error "Invalid position-spec: ~A" position))))
49 (device-position (device-file-position stream)))
50 (if (and (<= (- device-position (sm buffer-ptr stream))
53 (not (any-stream-instance-flags stream :dirty)))
54 ;; new position is within buffer; just move pointer
55 (setf (sm buffpos stream)
56 (- position (- device-position (sm buffer-ptr stream))))
58 (when (any-stream-instance-flags stream :dirty)
59 (sc-flush-buffer stream t))
60 (setf (device-file-position stream) position
61 (sm buffer-ptr stream) 0
62 (sm buffpos stream) 0)))))))
63 ;; TODO: implement file-position for other types of stream where
68 (defun %simple-stream-file-length (stream)
69 (declare (type simple-stream stream))
70 (%check-simple-stream stream)
71 (device-file-length stream)
76 (defun %simple-stream-file-name (stream)
77 (declare (type simple-stream stream))
78 (if (typep stream 'file-simple-stream)
79 (with-stream-class (file-simple-stream stream)
84 (defun %simple-stream-file-rename (stream new-name)
85 (declare (type simple-stream stream))
86 (if (typep stream 'file-simple-stream)
87 (with-stream-class (file-simple-stream stream)
88 (setf (sm pathname stream) new-name)
89 (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
94 (defun %simple-stream-file-string-length (stream object)
95 (declare (type simple-stream stream))
98 (string (length object))))
101 (defun %simple-stream-read-char (stream eof-error-p eof-value
102 recursive-p blocking-p)
103 (declare (type simple-stream stream)
104 (ignore recursive-p))
105 (with-stream-class (simple-stream stream)
106 (%check-simple-stream stream :input)
107 (funcall-stm-handler j-read-char (sm melded-stream stream)
108 eof-error-p eof-value blocking-p)))
111 (defun %simple-stream-unread-char (stream character)
112 (declare (type simple-stream stream) (ignore character))
113 (%check-simple-stream stream :input)
114 (with-stream-class (simple-stream)
115 (if (zerop (sm last-char-read-size stream))
116 (error "Nothing to unread.")
117 (funcall-stm-handler j-unread-char stream nil))))
119 (defun %simple-stream-peek-char (stream peek-type eof-error-p
120 eof-value recursive-p)
121 (declare (type simple-stream stream)
122 (ignore recursive-p))
123 (with-stream-class (simple-stream stream)
124 (%check-simple-stream stream :input)
125 (let* ((encap (sm melded-stream stream))
126 (char (funcall-stm-handler j-read-char encap
127 eof-error-p stream t)))
128 (cond ((eq char stream) eof-value)
129 ((characterp peek-type)
130 (do ((char char (funcall-stm-handler j-read-char encap
133 ((or (eq char stream) (char= char peek-type))
134 (unless (eq char stream)
135 (funcall-stm-handler j-unread-char encap t))
136 (if (eq char stream) eof-value char))))
138 (do ((char char (funcall-stm-handler j-read-char stream
141 ((or (eq char stream)
142 (not (sb-impl::whitespacep char)))
143 (unless (eq char stream)
144 (funcall-stm-handler j-unread-char encap t))
145 (if (eq char stream) eof-value char))))
147 (funcall-stm-handler j-unread-char encap t)
151 (defun %simple-stream-read-line (stream eof-error-p eof-value recursive-p)
152 (declare (type simple-stream stream)
154 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
155 (%check-simple-stream stream :input)
156 (with-stream-class (simple-stream stream)
157 (let* ((encap (sm melded-stream stream)) ; encapsulating stream
158 (cbuf (make-string 80)) ; current buffer
159 (bufs (list cbuf)) ; list of buffers
160 (tail bufs) ; last cons of bufs list
161 (index 0) ; current index in current buffer
162 (total 0)) ; total characters
163 (declare (type simple-stream encap)
164 (type simple-base-string cbuf)
165 (type cons bufs tail)
166 (type fixnum index total))
168 (multiple-value-bind (chars done)
169 (funcall-stm-handler j-read-chars encap cbuf
170 #\Newline index (length cbuf) t)
171 (declare (type fixnum chars))
174 (when (and (eq done :eof) (zerop index))
176 (error 'end-of-file :stream stream)
177 (return (values eof-value t))))
179 ;; If there's only one buffer in use, return it directly
180 (when (null (cdr bufs))
181 (return (values (sb-kernel:shrink-vector cbuf index)
183 ;; If total fits in final buffer, use it
185 (when (<= total (length cbuf))
186 (replace cbuf cbuf :start1 (- total index) :end2 index)
188 (declare (type fixnum idx))
190 (declare (type simple-base-string buf))
191 (replace cbuf buf :start1 idx)
192 (incf idx (length buf))))
193 (return (values (sb-kernel:shrink-vector cbuf index)
195 ;; Allocate new string of appropriate length
196 (let ((string (make-string total))
198 (declare (type fixnum index))
200 (declare (type simple-base-string buf))
201 (replace string buf :start1 index)
202 (incf index (length buf)))
203 (return (values string (eq done :eof)))))
204 (when (>= index (length cbuf))
205 (setf cbuf (make-string (the fixnum (* 2 index))))
207 (setf (cdr tail) (cons cbuf nil))
208 (setf tail (cdr tail))))))))
211 (defun %simple-stream-listen (stream width)
212 (declare (type simple-stream stream))
213 ;; WIDTH is number of octets which must be available; any value
214 ;; other than 1 is treated as 'character.
215 (%check-simple-stream stream :input)
216 (simple-stream-dispatch stream
217 ;; single-channel-simple-stream
218 (with-stream-class (single-channel-simple-stream stream)
219 (if (not (eql width 1))
220 (funcall-stm-handler j-listen stream)
221 (or (< (sm buffpos stream) (sm buffer-ptr stream))
222 (when (>= (sm mode stream) 0) ;; device-connected
223 (incf (sm last-char-read-size stream))
224 (let ((ok (sc-refill-buffer stream nil)))
225 (decf (sm last-char-read-size stream))
227 ;; dual-channel-simple-stream
228 (error "Implement %LISTEN")
229 ;; string-simple-stream
230 (error "Implement %LISTEN")))
233 (defun %simple-stream-clear-input (stream buffer-only)
234 (declare (type simple-stream stream))
235 (%check-simple-stream stream :input)
236 (simple-stream-dispatch stream
237 ;; single-channel-simple-stream
238 (with-stream-class (single-channel-simple-stream stream)
239 (setf (sm buffpos stream) 0
240 (sm buffer-ptr stream) 0
241 (sm last-char-read-size stream) 0))
242 ;; dual-channel-simple-stream
243 (with-stream-class (dual-channel-simple-stream stream)
244 (setf (sm buffpos stream) 0
245 (sm buffer-ptr stream) 0
246 (sm last-char-read-size stream) 0))
247 ;; string-simple-stream
249 (unless buffer-only (device-clear-input stream buffer-only)))
252 (defun %simple-stream-read-byte (stream eof-error-p eof-value)
253 (declare (type simple-stream stream))
254 (%check-simple-stream stream :input)
255 (with-stream-class (simple-stream stream)
256 (if (any-stream-instance-flags stream :eof)
257 (sb-impl::eof-or-lose stream eof-error-p eof-value)
258 (simple-stream-dispatch stream
259 ;; single-channel-simple-stream
260 (sc-read-byte stream eof-error-p eof-value t)
261 ;; dual-channel-simple-stream
262 (dc-read-byte stream eof-error-p eof-value t)
263 ;; string-simple-stream
264 (with-stream-class (string-simple-stream stream)
265 (let ((encap (sm input-handle stream)))
267 (error 'simple-type-error
269 :expected-type 'stream
270 :format-control "Can't read-byte on string streams"
271 :format-arguments '()))
273 (locally (declare (notinline read-byte))
274 (read-byte encap eof-error-p eof-value))
275 (setf (sm last-char-read-size stream) 0
276 (sm encapsulated-char-read-size stream) 0))))))))
279 (defun %simple-stream-write-char (stream character)
280 (declare (type simple-stream stream))
281 (%check-simple-stream stream :output)
282 (with-stream-class (simple-stream stream)
283 (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
286 (defun %simple-stream-fresh-line (stream)
287 (declare (type simple-stream stream))
288 (%check-simple-stream stream :output)
289 (with-stream-class (simple-stream stream)
290 (when (/= (or (sm charpos stream) 1) 0)
291 (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
295 (defun %simple-stream-write-string (stream string start end)
296 (declare (type simple-stream stream))
297 (%check-simple-stream stream :output)
298 (with-stream-class (simple-stream stream)
299 (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
303 (defun %simple-stream-line-length (stream)
304 (declare (type simple-stream stream))
305 (%check-simple-stream stream :output)
306 #| TODO: implement me |#
311 (defun %simple-stream-finish-output (stream)
312 (declare (type simple-stream stream))
313 (with-stream-class (simple-stream stream)
314 (%check-simple-stream stream :output)
315 (simple-stream-dispatch stream
316 ;; single-channel-simple-stream
317 (sc-flush-buffer stream t)
318 ;; dual-channel-simple-stream
319 (dc-flush-buffer stream t)
320 ;; string-simple-stream
324 (defun %simple-stream-force-output (stream)
325 (declare (type simple-stream stream))
326 (with-stream-class (simple-stream stream)
327 (%check-simple-stream stream :output)
328 (simple-stream-dispatch stream
329 ;; single-channel-simple-stream
330 (sc-flush-buffer stream nil)
331 ;; dual-channel-simple-stream
332 (dc-flush-buffer stream nil)
333 ;; string-simple-stream
337 (defun %simple-stream-clear-output (stream)
338 (declare (type simple-stream stream))
339 (%check-simple-stream stream :output)
340 (with-stream-class (simple-stream stream)
341 #| TODO: clear output buffer |#
342 (device-clear-output stream)))
345 (defun %simple-stream-write-byte (stream integer)
346 (declare (type simple-stream stream))
347 (with-stream-class (simple-stream stream)
348 (%check-simple-stream stream :output)
349 (simple-stream-dispatch stream
350 ;; single-channel-simple-stream
351 (with-stream-class (single-channel-simple-stream stream)
352 (let ((ptr (sm buffpos stream)))
353 (when (>= ptr (sm buffer-ptr stream))
354 (setf ptr (sc-flush-buffer stream t)))
355 (add-stream-instance-flags stream :dirty)
356 (setf (sm buffpos stream) (1+ ptr))
357 (setf (bref (sm buffer stream) ptr) integer)))
358 ;; dual-channel-simple-stream
359 (with-stream-class (dual-channel-simple-stream stream)
360 (let ((ptr (sm outpos stream)))
361 (when (>= ptr (sm max-out-pos stream))
362 (setf ptr (dc-flush-buffer stream t)))
363 (setf (sm outpos stream) (1+ ptr))
364 (setf (bref (sm out-buffer stream) ptr) integer)))
365 ;; string-simple-stream
366 (error 'simple-type-error
368 :expected-type 'stream
369 :format-control "Can't write-byte on string streams."
370 :format-arguments '()))))
373 (defun %simple-stream-read-sequence (stream seq start end partial-fill)
374 (declare (type simple-stream stream))
375 (with-stream-class (simple-stream stream)
376 (%check-simple-stream stream :input)
379 (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
380 start (or end (length seq))
381 (if partial-fill :bnb t)))
382 ((or (simple-array (unsigned-byte 8) (*))
383 (simple-array (signed-byte 8) (*)))
384 ;; TODO: "read-vector" equivalent, but blocking if partial-fill is NIL
385 (error "implement me")
389 (defun %simple-stream-write-sequence (stream seq start end)
390 (declare (type simple-stream stream))
391 (with-stream-class (simple-stream stream)
392 (%check-simple-stream stream :output)
395 (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
396 start (or end (length seq))))
397 ((or (simple-array (unsigned-byte 8) (*))
398 (simple-array (signed-byte 8) (*)))
399 ;; "write-vector" equivalent
400 (error "implement me")
404 ;;; Basic functionality for ansi-streams. These are separate
405 ;;; functions because they are called in places where we already know
406 ;;; we operate on an ansi-stream (as opposed to a simple- or
407 ;;; gray-stream, or the symbols t or nil), so we can evade typecase
408 ;;; and (in|out)-synonym-of calls.
410 (declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
411 %ansi-stream-unread-char %ansi-stream-read-line
412 %ansi-stream-read-sequence))
414 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
415 (declare (ignore blocking))
417 (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
418 (sb-int:prepare-for-fast-read-byte stream
420 (sb-int:fast-read-byte eof-error-p eof-value t)
421 (sb-int:done-with-fast-read-byte))))
423 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
424 (declare (ignore blocking))
426 (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
427 (sb-int:prepare-for-fast-read-char stream
429 (sb-int:fast-read-char eof-error-p eof-value)
430 (sb-int:done-with-fast-read-char))))
432 (defun %ansi-stream-unread-char (character stream)
433 (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
434 (buffer (sb-kernel:ansi-stream-in-buffer stream)))
435 (declare (fixnum index))
436 (when (minusp index) (error "nothing to unread"))
438 (setf (aref buffer index) (char-code character))
439 (setf (sb-kernel:ansi-stream-in-index stream) index))
441 (funcall (sb-kernel:ansi-stream-misc stream) stream
442 :unread character)))))
444 (defun %ansi-stream-read-line (stream eof-error-p eof-value)
445 (sb-int:prepare-for-fast-read-char stream
446 (let ((res (make-string 80))
450 (let ((ch (sb-int:fast-read-char nil nil)))
452 (when (char= ch #\newline)
453 (sb-int:done-with-fast-read-char)
454 (return (values (sb-kernel:shrink-vector res index) nil)))
457 (let ((new (make-string len)))
460 (setf (schar res index) ch)
463 (sb-int:done-with-fast-read-char)
464 (return (values (sb-impl::eof-or-lose stream eof-error-p
467 ;; Since FAST-READ-CHAR already hit the eof char, we
468 ;; shouldn't do another READ-CHAR.
470 (sb-int:done-with-fast-read-char)
471 (return (values (sb-kernel:shrink-vector res index) t)))))))))
473 (defun %ansi-stream-read-sequence (seq stream start %end)
474 (declare (type sequence seq)
475 (type sb-kernel:ansi-stream stream)
476 (type sb-int:index start)
477 (type sb-kernel:sequence-end %end)
478 (values sb-int:index))
479 (let ((end (or %end (length seq))))
480 (declare (type sb-int:index end))
484 (if (subtypep (stream-element-type stream) 'character)
485 #'%ansi-stream-read-char
486 #'%ansi-stream-read-byte)))
487 (do ((rem (nthcdr start seq) (rest rem))
489 ((or (endp rem) (>= i end)) i)
490 (declare (type list rem)
491 (type sb-int:index i))
492 (let ((el (funcall read-function stream nil :eof nil)))
495 (setf (first rem) el)))))
497 (sb-kernel:with-array-data ((data seq) (offset-start start)
500 ((or (simple-array (unsigned-byte 8) (*))
501 (simple-array (signed-byte 8) (*))
503 (let* ((numbytes (- end start))
504 (bytes-read (sb-sys:read-n-bytes stream
509 (if (< bytes-read numbytes)
514 (if (subtypep (stream-element-type stream) 'character)
515 #'%ansi-stream-read-char
516 #'%ansi-stream-read-byte)))
517 (do ((i offset-start (1+ i)))
518 ((>= i offset-end) end)
519 (declare (type sb-int:index i))
520 (let ((el (funcall read-function stream nil :eof nil)))
522 (return (+ start (- i offset-start))))
523 (setf (aref data i) el)))))))))))
526 (defun %ansi-stream-write-string (string stream start end)
527 (declare (type string string)
528 (type sb-kernel:ansi-stream stream)
529 (type sb-int:index start end))
531 ;; Note that even though you might expect, based on the behavior of
532 ;; things like AREF, that the correct upper bound here is
533 ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
534 ;; "bounding index" and "length" indicate that in this case (i.e.
535 ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
536 ;; which are implemented in terms of this function), (LENGTH STRING)
537 ;; is the required upper bound. A foolish consistency is the
538 ;; hobgoblin of lesser languages..
539 (unless (<= 0 start end (length string))
540 (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
545 (if (sb-kernel:array-header-p string)
546 (sb-kernel:with-array-data ((data string) (offset-start start)
548 (funcall (sb-kernel:ansi-stream-sout stream)
549 stream data offset-start offset-end))
550 (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
553 (defun %ansi-stream-write-sequence (seq stream start %end)
554 (declare (type sequence seq)
555 (type sb-kernel:ansi-stream stream)
556 (type sb-int:index start)
557 (type sb-kernel:sequence-end %end)
559 (let ((end (or %end (length seq))))
560 (declare (type sb-int:index end))
563 (let ((write-function
564 (if (subtypep (stream-element-type stream) 'character)
565 ;; TODO: Replace these with ansi-stream specific
569 (do ((rem (nthcdr start seq) (rest rem))
571 ((or (endp rem) (>= i end)) seq)
572 (declare (type list rem)
573 (type sb-int:index i))
574 (funcall write-function (first rem) stream))))
576 (%ansi-stream-write-string seq stream start end))
578 (let ((write-function
579 (if (subtypep (stream-element-type stream) 'character)
580 ;; TODO: Replace these with ansi-stream specific
584 (do ((i start (1+ i)))
586 (declare (type sb-int:index i))
587 (funcall write-function (aref seq i) stream)))))))
591 ;;; USER-LEVEL FUNCTIONS
594 (defmethod open-stream-p ((stream simple-stream))
595 (any-stream-instance-flags stream :input :output))
597 (defmethod input-stream-p ((stream simple-stream))
598 (any-stream-instance-flags stream :input))
600 (defmethod output-stream-p ((stream simple-stream))
601 (any-stream-instance-flags stream :output))
603 (defmethod stream-element-type ((stream simple-stream))
606 (defun interactive-stream-p (stream)
607 "Return true if Stream does I/O on a terminal or other interactive device."
610 (any-stream-instance-flags stream :interactive))
612 (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
616 (defun (setf interactive-stream-p) (flag stream)
620 (add-stream-instance-flags stream :interactive)
621 (remove-stream-instance-flags stream :interactive)))
623 (error 'simple-type-error
625 :expected-type 'simple-stream
626 :format-control "Can't set interactive flag on ~S."
627 :format-arguments (list stream)))))
629 (defun file-string-length (stream object)
630 (declare (type (or string character) object) (type stream stream))
631 "Return the delta in STREAM's FILE-POSITION that would be caused by writing
632 OBJECT to STREAM. Non-trivial only in implementations that support
633 international character sets."
635 (simple-stream (%simple-stream-file-string-length stream object))
639 (string (length object))))))
641 (defun stream-external-format (stream)
642 "Returns Stream's external-format."
645 (with-stream-class (simple-stream)
646 (sm external-format stream)))
652 (defun open (filename &rest options
653 &key (direction :input)
654 (element-type 'character element-type-given)
655 if-exists if-does-not-exist
656 (external-format :default)
657 class mapped input-handle output-handle
659 "Return a stream which reads from or writes to Filename.
661 :direction - one of :input, :output, :io, or :probe
662 :element-type - type of object to read or write, default BASE-CHAR
663 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
664 :overwrite, :append, :supersede or NIL
665 :if-does-not-exist - one of :error, :create or NIL
666 :external-format - :default
667 See the manual for details.
669 The following are simple-streams-specific additions:
670 :class - class of stream object to be created
671 :mapped - T to open a memory-mapped file
672 :input-handle - a stream or Unix file descriptor to read from
673 :output-handle - a stream or Unix file descriptor to write to"
674 (declare (ignore external-format input-handle output-handle
675 if-exists if-does-not-exist))
676 (let ((class (or class 'sb-sys::file-stream))
677 (options (copy-list options))
678 (filespec (merge-pathnames filename)))
679 (cond ((eq class 'sb-sys::file-stream)
680 (remf options :class)
681 (remf options :mapped)
682 (remf options :input-handle)
683 (remf options :output-handle)
684 (apply #'open-fd-stream filespec options))
685 ((subtypep class 'simple-stream)
686 (when element-type-given
687 (error "Can't create simple-streams with an element-type."))
688 (when (and (eq class 'file-simple-stream) mapped)
689 (setq class 'mapped-file-simple-stream)
690 (setf (getf options :class) 'mapped-file-simple-stream))
691 (when (subtypep class 'file-simple-stream)
692 (when (eq direction :probe)
693 (setq class 'probe-simple-stream)))
694 (apply #'make-instance class :filename filespec options))
695 ((subtypep class 'sb-gray:fundamental-stream)
696 (remf options :class)
697 (remf options :mapped)
698 (remf options :input-handle)
699 (remf options :output-handle)
700 (make-instance class :lisp-stream
701 (apply #'open-fd-stream filespec options))))))
704 (declaim (inline read-byte read-char read-char-no-hang unread-char))
706 (defun read-byte (stream &optional (eof-error-p t) eof-value)
707 "Returns the next byte of the Stream."
708 (let ((stream (sb-impl::in-synonym-of stream)))
711 (%simple-stream-read-byte stream eof-error-p eof-value))
713 (%ansi-stream-read-byte stream eof-error-p eof-value t))
715 (let ((char (sb-gray:stream-read-byte stream)))
717 (sb-impl::eof-or-lose stream eof-error-p eof-value)
720 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
721 eof-value recursive-p)
722 "Inputs a character from Stream and returns it."
723 (let ((stream (sb-impl::in-synonym-of stream)))
726 (%simple-stream-read-char stream eof-error-p eof-value recursive-p t))
728 (%ansi-stream-read-char stream eof-error-p eof-value t))
730 (let ((char (sb-gray:stream-read-char stream)))
732 (sb-impl::eof-or-lose stream eof-error-p eof-value)
735 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
736 eof-value recursive-p)
737 "Returns the next character from the Stream if one is availible, or nil."
738 (declare (ignore recursive-p))
739 (let ((stream (sb-impl::in-synonym-of stream)))
742 (%check-simple-stream stream :input)
743 (with-stream-class (simple-stream)
744 (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
746 (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
747 (%ansi-stream-read-char stream eof-error-p eof-value t)
750 (let ((char (sb-gray:stream-read-char-no-hang stream)))
752 (sb-impl::eof-or-lose stream eof-error-p eof-value)
755 (defun unread-char (character &optional (stream *standard-input*))
756 "Puts the Character back on the front of the input Stream."
757 (let ((stream (sb-impl::in-synonym-of stream)))
760 (%simple-stream-unread-char stream character))
762 (%ansi-stream-unread-char character stream))
764 (sb-gray:stream-unread-char stream character))))
767 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
769 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
770 (eof-error-p t) eof-value recursive-p)
771 "Peeks at the next character in the input Stream. See manual for details."
772 (let ((stream (sb-impl::in-synonym-of stream)))
775 (%simple-stream-peek-char stream peek-type eof-error-p eof-value
778 (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
779 (cond ((eq char eof-value) char)
780 ((characterp peek-type)
781 (do ((char char (%ansi-stream-read-char stream eof-error-p
783 ((or (eq char eof-value) (char= char peek-type))
784 (unless (eq char eof-value)
785 (%ansi-stream-unread-char char stream))
788 (do ((char char (%ansi-stream-read-char stream eof-error-p
790 ((or (eq char eof-value)
791 (not (sb-int:whitespace-char-p char)))
792 (unless (eq char eof-value)
793 (%ansi-stream-unread-char char stream))
796 (%ansi-stream-unread-char char stream)
799 (cond ((characterp peek-type)
800 (do ((char (sb-gray:stream-read-char stream)
801 (sb-gray:stream-read-char stream)))
802 ((or (eq char :eof) (char= char peek-type))
803 (cond ((eq char :eof)
804 (sb-impl::eof-or-lose stream eof-error-p eof-value))
806 (sb-gray:stream-unread-char stream char)
809 (do ((char (sb-gray:stream-read-char stream)
810 (sb-gray:stream-read-char stream)))
811 ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
812 (cond ((eq char :eof)
813 (sb-impl::eof-or-lose stream eof-error-p eof-value))
815 (sb-gray:stream-unread-char stream char)
818 (let ((char (sb-gray:stream-peek-char stream)))
820 (sb-impl::eof-or-lose stream eof-error-p eof-value)
823 (defun listen (&optional (stream *standard-input*) (width 1))
824 "Returns T if Width octets are available on the given Stream. If Width
825 is given as 'character, check for a character."
826 ;; WIDTH is number of octets which must be available; any value
827 ;; other than 1 is treated as 'character.
828 (let ((stream (sb-impl::in-synonym-of stream)))
831 (%simple-stream-listen stream width))
833 (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
834 sb-impl::+ansi-stream-in-buffer-length+)
835 ;; Test for T explicitly since misc methods return :EOF sometimes.
836 (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
839 (sb-gray:stream-listen stream)))))
842 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
843 eof-value recursive-p)
844 "Returns a line of text read from the Stream as a string, discarding the
846 (declare (ignore recursive-p))
847 (let ((stream (sb-impl::in-synonym-of stream)))
850 (%simple-stream-read-line stream eof-error-p eof-value recursive-p))
852 (%ansi-stream-read-line stream eof-error-p eof-value))
854 (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
855 (if (and eof (zerop (length string)))
856 (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
857 (values string eof)))))))
859 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
860 "Destructively modify SEQ by reading elements from STREAM.
861 SEQ is bounded by START and END. SEQ is destructively modified by
862 copying successive elements into it from STREAM. If the end of file
863 for STREAM is reached before copying all elements of the subsequence,
864 then the extra elements near the end of sequence are not updated, and
865 the index of the next element is returned."
866 (let ((stream (sb-impl::in-synonym-of stream))
867 (end (or end (length seq))))
870 (with-stream-class (simple-stream stream)
871 (%simple-stream-read-sequence stream seq start end partial-fill)))
873 (%ansi-stream-read-sequence seq stream start end))
875 (sb-gray:stream-read-sequence stream seq start end)))))
877 (defun clear-input (&optional (stream *standard-input*) buffer-only)
878 "Clears any buffered input associated with the Stream."
879 (let ((stream (sb-impl::in-synonym-of stream)))
882 (%simple-stream-clear-input stream buffer-only))
884 (setf (sb-kernel:ansi-stream-in-index stream)
885 sb-impl::+ansi-stream-in-buffer-length+)
886 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
888 (sb-gray:stream-clear-input stream))))
891 (defun write-byte (integer stream)
892 "Outputs an octet to the Stream."
893 (let ((stream (sb-impl::out-synonym-of stream)))
896 (%simple-stream-write-byte stream integer))
898 (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
900 (sb-gray:stream-write-byte stream integer))))
903 (defun write-char (character &optional (stream *standard-output*))
904 "Outputs the Character to the Stream."
905 (let ((stream (sb-impl::out-synonym-of stream)))
908 (%simple-stream-write-char stream character))
910 (funcall (sb-kernel:ansi-stream-out stream) stream character))
912 (sb-gray:stream-write-char stream character))))
915 (defun write-string (string &optional (stream *standard-output*)
916 &key (start 0) (end nil))
917 "Outputs the String to the given Stream."
918 (let ((stream (sb-impl::out-synonym-of stream))
919 (end (or end (length string))))
922 (%simple-stream-write-string stream string start end)
925 (%ansi-stream-write-string string stream start end))
927 (sb-gray:stream-write-string stream string start end)))))
929 (defun write-line (string &optional (stream *standard-output*)
931 (declare (type string string))
932 ;; FIXME: Why is there this difference between the treatments of the
933 ;; STREAM argument in WRITE-STRING and WRITE-LINE?
934 (let ((stream (sb-impl::out-synonym-of stream))
935 (end (or end (length string))))
938 (%check-simple-stream stream :output)
939 (with-stream-class (simple-stream stream)
940 (funcall-stm-handler-2 j-write-chars string stream start end)
941 (funcall-stm-handler-2 j-write-char #\Newline stream)))
943 (%ansi-stream-write-string string stream start end)
944 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
946 (sb-gray:stream-write-string stream string start end)
947 (sb-gray:stream-terpri stream))))
950 (defun write-sequence (seq stream &key (start 0) (end nil))
951 "Write the elements of SEQ bounded by START and END to STREAM."
952 (let ((stream (sb-impl::out-synonym-of stream))
953 (end (or end (length seq))))
956 (%simple-stream-write-sequence stream seq start end))
958 (%ansi-stream-write-sequence seq stream start end))
960 (sb-gray:stream-write-sequence stream seq start end)))))
962 (defun terpri (&optional (stream *standard-output*))
963 "Outputs a new line to the Stream."
964 (let ((stream (sb-impl::out-synonym-of stream)))
967 (%check-simple-stream stream :output)
968 (with-stream-class (simple-stream stream)
969 (funcall-stm-handler-2 j-write-char #\Newline stream)))
971 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
973 (sb-gray:stream-terpri stream))))
976 (defun fresh-line (&optional (stream *standard-output*))
977 "Outputs a new line to the Stream if it is not positioned at the beginning of
978 a line. Returns T if it output a new line, nil otherwise."
979 (let ((stream (sb-impl::out-synonym-of stream)))
982 (%simple-stream-fresh-line stream))
984 (when (/= (or (sb-kernel:charpos stream) 1) 0)
985 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
988 (sb-gray:stream-fresh-line stream)))))
990 (defun finish-output (&optional (stream *standard-output*))
991 "Attempts to ensure that all output sent to the Stream has reached its
992 destination, and only then returns."
993 (let ((stream (sb-impl::out-synonym-of stream)))
996 (%simple-stream-finish-output stream))
998 (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
1000 (sb-gray:stream-finish-output stream))))
1003 (defun force-output (&optional (stream *standard-output*))
1004 "Attempts to force any buffered output to be sent."
1005 (let ((stream (sb-impl::out-synonym-of stream)))
1008 (%simple-stream-force-output stream))
1010 (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
1012 (sb-gray:stream-force-output stream))))
1015 (defun clear-output (&optional (stream *standard-output*))
1016 "Clears the given output Stream."
1017 (let ((stream (sb-impl::out-synonym-of stream)))
1020 (%simple-stream-clear-output stream))
1022 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
1024 (sb-gray:stream-clear-output stream))))
1028 (defun file-position (stream &optional position)
1029 "With one argument returns the current position within the file
1030 File-Stream is open to. If the second argument is supplied, then
1031 this becomes the new file position. The second argument may also
1032 be :start or :end for the start and end of the file, respectively."
1033 (declare (type (or (integer 0 *) (member nil :start :end)) position))
1036 (%simple-stream-file-position stream position))
1040 (setf (sb-kernel:ansi-stream-in-index stream)
1041 sb-impl::+ansi-stream-in-buffer-length+)
1042 (funcall (sb-kernel:ansi-stream-misc stream)
1043 stream :file-position position))
1045 (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
1046 stream :file-position nil)))
1049 (- sb-impl::+ansi-stream-in-buffer-length+
1050 (sb-kernel:ansi-stream-in-index stream))))))))))
1052 (defun file-length (stream)
1053 "This function returns the length of the file that File-Stream is open to."
1056 (%simple-stream-file-length stream))
1058 (progn (sb-impl::stream-must-be-associated-with-file stream)
1059 (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
1061 (defun charpos (&optional (stream *standard-output*))
1062 "Returns the number of characters on the current line of output of the given
1063 Stream, or Nil if that information is not availible."
1064 (let ((stream (sb-impl::out-synonym-of stream)))
1067 (%check-simple-stream stream :output)
1068 (with-stream-class (simple-stream) (sm charpos stream)))
1070 (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
1072 (sb-gray:stream-line-column stream)))))
1074 (defun line-length (&optional (stream *standard-output*))
1075 "Returns the number of characters in a line of output of the given
1076 Stream, or Nil if that information is not availible."
1077 (let ((stream (sb-impl::out-synonym-of stream)))
1080 (%check-simple-stream stream :output)
1081 ;; TODO (sat 2003-04-02): a way to specify a line length would
1082 ;; be good, I suppose. Returning nil here means
1083 ;; sb-pretty::default-line-length is used.
1086 (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
1088 (sb-gray:stream-line-length stream)))))
1090 (defun wait-for-input-available (stream &optional timeout)
1091 "Waits for input to become available on the Stream and returns T. If
1092 Timeout expires, Nil is returned."
1093 (let ((stream (sb-impl::in-synonym-of stream)))
1096 (sb-sys:wait-until-fd-usable stream :input timeout))
1098 (%check-simple-stream stream :input)
1099 (with-stream-class (simple-stream stream)
1100 (or (< (sm buffpos stream) (sm buffer-ptr stream))
1101 (wait-for-input-available (sm input-handle stream) timeout))))
1103 (wait-for-input-available (two-way-stream-input-stream stream) timeout))
1105 (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
1107 (sb-sys::file-stream
1108 (or (< (sb-impl::fd-stream-in-index stream)
1109 (length (sb-impl::fd-stream-in-buffer stream)))
1110 (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
1112 ;; Make PATHNAME and NAMESTRING work
1113 (defun sb-int:file-name (stream &optional new-name)
1116 (with-stream-class (file-simple-stream stream)
1118 (%simple-stream-file-rename stream new-name))
1120 (%simple-stream-file-name stream)))))
1121 (sb-sys::file-stream
1123 (setf (sb-impl::fd-stream-pathname stream) new-name)
1124 (setf (sb-impl::fd-stream-file stream)
1125 (sb-int:unix-namestring new-name nil))
1128 (sb-impl::fd-stream-pathname stream))))))
1132 ;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or
1135 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1136 (declare (type fundamental-stream stream) ;; this is a lie
1140 (ext:stream-listen stream))
1142 (ext:stream-unread-char stream arg1))
1146 (ext:stream-clear-input stream))
1148 (ext:stream-force-output stream))
1150 (ext:stream-finish-output stream))
1152 (stream-element-type stream))
1154 (interactive-stream-p stream))
1156 (ext:stream-line-length stream))
1158 (ext:stream-line-column stream))
1160 (file-length stream))
1162 (file-position stream arg1))))