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 ;;; Basic functionality for ansi-streams. These are separate
13 ;;; functions because they are called in places where we already know
14 ;;; we operate on an ansi-stream (as opposed to a simple- or
15 ;;; gray-stream, or the symbols t or nil), so we can evade typecase
16 ;;; and (in|out)-synonym-of calls.
18 (declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
19 %ansi-stream-unread-char %ansi-stream-read-line
20 %ansi-stream-read-sequence))
22 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
23 (declare (ignore blocking))
25 (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
26 (sb-int:prepare-for-fast-read-byte stream
28 (sb-int:fast-read-byte eof-error-p eof-value t)
29 (sb-int:done-with-fast-read-byte))))
31 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
32 (declare (ignore blocking))
34 (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
35 (sb-int:prepare-for-fast-read-char stream
37 (sb-int:fast-read-char eof-error-p eof-value)
38 (sb-int:done-with-fast-read-char))))
40 (defun %ansi-stream-unread-char (character stream)
41 (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
42 (buffer (sb-kernel:ansi-stream-in-buffer stream)))
43 (declare (fixnum index))
44 (when (minusp index) (error "nothing to unread"))
46 (setf (aref buffer index) (char-code character))
47 (setf (sb-kernel:ansi-stream-in-index stream) index))
49 (funcall (sb-kernel:ansi-stream-misc stream) stream
50 :unread character)))))
52 (defun %ansi-stream-read-line (stream eof-error-p eof-value)
53 (sb-int:prepare-for-fast-read-char stream
54 (let ((res (make-string 80))
58 (let ((ch (sb-int:fast-read-char nil nil)))
60 (when (char= ch #\newline)
61 (sb-int:done-with-fast-read-char)
62 (return (values (sb-kernel:shrink-vector res index) nil)))
65 (let ((new (make-string len)))
68 (setf (schar res index) ch)
71 (sb-int:done-with-fast-read-char)
72 (return (values (sb-impl::eof-or-lose stream eof-error-p
75 ;; Since FAST-READ-CHAR already hit the eof char, we
76 ;; shouldn't do another READ-CHAR.
78 (sb-int:done-with-fast-read-char)
79 (return (values (sb-kernel:shrink-vector res index) t)))))))))
81 (defun %ansi-stream-read-sequence (seq stream start %end)
82 (declare (type sequence seq)
83 (type sb-kernel:ansi-stream stream)
84 (type sb-int:index start)
85 (type sb-kernel:sequence-end %end)
86 (values sb-int:index))
87 (let ((end (or %end (length seq))))
88 (declare (type sb-int:index end))
92 (if (subtypep (stream-element-type stream) 'character)
93 #'%ansi-stream-read-char
94 #'%ansi-stream-read-byte)))
95 (do ((rem (nthcdr start seq) (rest rem))
97 ((or (endp rem) (>= i end)) i)
98 (declare (type list rem)
99 (type sb-int:index i))
100 (let ((el (funcall read-function stream nil :eof)))
103 (setf (first rem) el)))))
105 (sb-kernel:with-array-data ((data seq) (offset-start start)
108 ((or (simple-array (unsigned-byte 8) (*))
109 (simple-array (signed-byte 8) (*))
111 (let* ((numbytes (- end start))
112 (bytes-read (sb-sys:read-n-bytes stream
117 (if (< bytes-read numbytes)
122 (if (subtypep (stream-element-type stream) 'character)
123 #'%ansi-stream-read-char
124 #'%ansi-stream-read-byte)))
125 (do ((i offset-start (1+ i)))
126 ((>= i offset-end) end)
127 (declare (type sb-int:index i))
128 (let ((el (funcall read-function stream nil :eof)))
130 (return (+ start (- i offset-start))))
131 (setf (aref data i) el)))))))))))
134 (defun %ansi-stream-write-string (string stream start end)
135 (declare (type string string)
136 (type sb-kernel:ansi-stream stream)
137 (type sb-int:index start end))
139 ;; Note that even though you might expect, based on the behavior of
140 ;; things like AREF, that the correct upper bound here is
141 ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
142 ;; "bounding index" and "length" indicate that in this case (i.e.
143 ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
144 ;; which are implemented in terms of this function), (LENGTH STRING)
145 ;; is the required upper bound. A foolish consistency is the
146 ;; hobgoblin of lesser languages..
147 (unless (<= 0 start end (length string))
148 (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
153 (if (sb-kernel:array-header-p string)
154 (sb-kernel:with-array-data ((data string) (offset-start start)
156 (funcall (sb-kernel:ansi-stream-sout stream)
157 stream data offset-start offset-end))
158 (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
161 (defun %ansi-stream-write-sequence (seq stream start %end)
162 (declare (type sequence seq)
163 (type sb-kernel:ansi-stream stream)
164 (type sb-int:index start)
165 (type sb-kernel:sequence-end %end)
167 (let ((end (or %end (length seq))))
168 (declare (type sb-int:index end))
171 (let ((write-function
172 (if (subtypep (stream-element-type stream) 'character)
173 ;; TODO: Replace these with ansi-stream specific
177 (do ((rem (nthcdr start seq) (rest rem))
179 ((or (endp rem) (>= i end)) seq)
180 (declare (type list rem)
181 (type sb-int:index i))
182 (funcall write-function (first rem) stream))))
184 (%ansi-stream-write-string seq stream start end))
186 (let ((write-function
187 (if (subtypep (stream-element-type stream) 'character)
188 ;; TODO: Replace these with ansi-stream specific
192 (do ((i start (1+ i)))
194 (declare (type sb-int:index i))
195 (funcall write-function (aref seq i) stream)))))))
199 ;;; USER-LEVEL FUNCTIONS
202 (defmethod open-stream-p ((stream simple-stream))
203 (any-stream-instance-flags stream :input :output))
205 (defmethod input-stream-p ((stream simple-stream))
206 (any-stream-instance-flags stream :input))
208 (defmethod output-stream-p ((stream simple-stream))
209 (any-stream-instance-flags stream :output))
211 (defmethod stream-element-type ((stream simple-stream))
214 (defun interactive-stream-p (stream)
215 "Return true if Stream does I/O on a terminal or other interactive device."
216 (declare (type stream stream))
219 (any-stream-instance-flags stream :interactive))
221 (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
222 (fundamental-stream nil)))
224 (defun (setf interactive-stream-p) (value stream)
228 (add-stream-instance-flags stream :interactive)
229 (remove-stream-instance-flags stream :interactive)))))
231 (defun stream-external-format (stream)
232 "Returns Stream's external-format."
233 (declare (type stream stream))
236 (with-stream-class (simple-stream)
237 (sm external-format stream)))
240 (fundamental-stream #| not defined on Gray streams? |#
243 (defgeneric default-open-class (name &optional element-type)
245 "Determine the stream class to be created when an attempt is made
246 to open NAME. This is a CMUCL- and SBCL-specific extension to Franz's
247 simple-streams proposal.")
248 (:method ((name t) &optional element-type)
249 (declare (ignore element-type))
251 (:method ((name pathname) &optional element-type)
252 (declare (ignore element-type))
253 'sb-sys::file-stream)
254 (:method ((name string) &optional element-type)
255 (declare (ignore element-type))
256 'sb-sys::file-stream)
257 (:method ((name stream) &optional element-type)
258 (declare (ignore element-type))
259 (class-name (class-of name))))
261 (defun open (filename &rest options
262 &key (direction :input)
263 (element-type 'character element-type-given)
264 if-exists if-does-not-exist
265 (external-format :default)
266 class mapped input-handle output-handle
268 "Return a stream which reads from or writes to Filename.
270 :direction - one of :input, :output, :io, or :probe
271 :element-type - type of object to read or write, default BASE-CHAR
272 :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
273 :overwrite, :append, :supersede or NIL
274 :if-does-not-exist - one of :error, :create or NIL
275 :external-format - :default
276 See the manual for details.
278 The following are simple-streams-specific additions:
279 :class - class of stream object to be created
280 :mapped - T to open a memory-mapped file
281 :input-handle - a stream or Unix file descriptor to read from
282 :output-handle - a stream or Unix file descriptor to write to
284 If Class is NIL or not supplied, DEFAULT-OPEN-CLASS is called on
285 Filename to determine its value, thus Filename need not be an actual
286 file name; it could be any arbitrary user-defined object for which a
287 method of DEFAULT-OPEN-CLASS is applicable."
288 (declare (ignore if-exists if-does-not-exist external-format
289 input-handle output-handle))
291 (options (copy-list options))
292 (filespec (if (stringp filename) (parse-filespec filename) filename)))
294 (setq klass (default-open-class filespec (if element-type-given
298 (error 'type-error :datum filename
299 :expected-type '(or pathname stream base-string)))
300 (cond ((eql klass 'sb-sys::file-stream)
301 (remf options :class)
302 (remf options :mapped)
303 ;; INPUT-HANDLE and OUTPUT-HANDLE must be fixnums or NIL.
304 ;; If both are given, they must be the same -- or maybe
305 ;; we should make a TWO-WAY-STREAM in that case??
306 ;; If they are given, use SYS:MAKE-FD-STREAM to make the
307 ;; stream. Direction must be appropriate, too.
308 (remf options :input-handle)
309 (remf options :output-handle)
310 (apply #'open-fd-stream filespec options))
311 ((subtypep klass 'simple-stream)
312 (when element-type-given
313 (error "Can't create simple-streams with an element-type."))
314 (when (and (eq klass 'file-simple-stream) mapped)
315 (setq klass 'mapped-file-simple-stream)
316 (setf (getf options :class) 'mapped-file-simple-stream))
317 (when (subtypep klass 'file-simple-stream)
318 (when (eq direction :probe)
319 (setq klass 'probe-simple-stream)))
320 (apply #'make-instance klass (list* :filename filespec options)))
321 ((subtypep klass 'fundamental-stream)
322 (error "Gray streams are not supported by OPEN."))
325 (error "Unable to open streams of class ~S." class)
326 (error "DEFAULT-OPEN-CLASS method on ~S instances is broken!"
327 (class-name (class-of filespec))))))))
329 (defmacro %check-simple-stream (stream &optional direction)
330 ;; Check that STREAM is valid and open in the appropriate direction.
332 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
333 (with-stream-class (simple-stream ,stream)
334 (let ((flags (sm %flags ,stream)))
335 (cond ((zerop (logand flags ,(%flags '(:simple))))
336 (error "~S is not properly initialized." stream))
337 ((zerop (logand flags ,(%flags '(:input :output))))
338 (error "~S is closed." stream))
340 `(((zerop (logand flags ,(%flags (list direction))))
341 (error ,(format nil "~~S is not an ~(~A~) stream."
345 (declaim (inline sc-read-byte dc-read-byte))
346 (defun sc-read-byte (stream eof-error-p eof-value blocking)
347 (with-stream-class (single-channel-simple-stream stream)
349 (let ((ptr (sm buffpos stream)))
350 (when (>= ptr (sm buffer-ptr stream))
351 (let ((bytes (device-read stream nil 0 nil blocking)))
352 (declare (type fixnum bytes))
354 (setf (sm buffer-ptr stream) bytes
356 (return-from sc-read-byte
357 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
358 (setf (sm buffpos stream) (1+ ptr))
359 (setf (sm last-char-read-size stream) 0)
360 (bref (sm buffer stream) ptr))))
362 (defun dc-read-byte (stream eof-error-p eof-value blocking)
363 (with-stream-class (dual-channel-simple-stream stream)
364 (let ((ptr (sm buffpos stream)))
365 (when (>= ptr (sm buffer-ptr stream))
366 (let ((bytes (device-read stream nil 0 nil blocking)))
367 (declare (type fixnum bytes))
369 (setf (sm buffer-ptr stream) bytes
371 (return-from dc-read-byte
372 (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
373 (setf (sm buffpos stream) (1+ ptr))
374 (setf (sm last-char-read-size stream) 0)
375 (bref (sm buffer stream) ptr))))
377 (declaim (inline read-byte read-char read-char-no-hang unread-char))
379 (defun read-byte (stream &optional (eof-error-p t) eof-value)
380 "Returns the next byte of the Stream."
381 (let ((stream (sb-impl::in-synonym-of stream)))
384 (%check-simple-stream stream :input)
385 (with-stream-class (simple-stream stream)
386 (cond ((any-stream-instance-flags stream :eof)
387 (sb-impl::eof-or-lose stream eof-error-p eof-value))
388 ((any-stream-instance-flags stream :string)
389 (with-stream-class (string-simple-stream stream)
390 (let ((encap (sm input-handle stream)))
392 (error "Can't read-byte on string streams"))
394 (locally (declare (notinline read-byte))
395 (read-byte encap eof-error-p eof-value))
396 (setf (sm last-char-read-size stream) 0
397 (sm encapsulated-char-read-size stream) 0)))))
398 ((any-stream-instance-flags stream :dual)
399 (dc-read-byte stream eof-error-p eof-value t))
400 (t ;; single-channel-simple-stream
401 (sc-read-byte stream eof-error-p eof-value t)))))
403 (%ansi-stream-read-byte stream eof-error-p eof-value t))
405 (let ((char (sb-gray:stream-read-byte stream)))
407 (sb-impl::eof-or-lose stream eof-error-p eof-value)
410 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
411 eof-value recursive-p)
412 "Inputs a character from Stream and returns it."
413 (declare (ignore recursive-p))
414 (let ((stream (sb-impl::in-synonym-of stream)))
417 (%check-simple-stream stream :input)
418 (with-stream-class (simple-stream)
419 (funcall-stm-handler j-read-char stream eof-error-p eof-value t)))
421 (%ansi-stream-read-char stream eof-error-p eof-value t))
423 (let ((char (sb-gray:stream-read-char stream)))
425 (sb-impl::eof-or-lose stream eof-error-p eof-value)
428 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
429 eof-value recursive-p)
430 "Returns the next character from the Stream if one is availible, or nil."
431 (declare (ignore recursive-p))
432 (let ((stream (sb-impl::in-synonym-of stream)))
435 (%check-simple-stream stream :input)
436 (with-stream-class (simple-stream)
437 (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
439 (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
440 (%ansi-stream-read-char stream eof-error-p eof-value t)
443 (let ((char (sb-gray:stream-read-char-no-hang stream)))
445 (sb-impl::eof-or-lose stream eof-error-p eof-value)
448 (defun unread-char (character &optional (stream *standard-input*))
449 "Puts the Character back on the front of the input Stream."
450 (let ((stream (sb-impl::in-synonym-of stream)))
453 (%check-simple-stream stream :input)
454 (with-stream-class (simple-stream)
455 (if (zerop (sm last-char-read-size stream))
456 (error "Nothing to unread.")
457 (funcall-stm-handler j-unread-char stream nil))))
459 (%ansi-stream-unread-char character stream))
461 (sb-gray:stream-unread-char stream character))))
464 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
466 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
467 (eof-error-p t) eof-value recursive-p)
468 "Peeks at the next character in the input Stream. See manual for details."
469 (declare (ignore recursive-p))
470 (let ((stream (sb-impl::in-synonym-of stream)))
473 (%check-simple-stream stream :input)
474 (with-stream-class (simple-stream)
475 (let ((char (funcall-stm-handler j-read-char stream
476 eof-error-p eof-value t)))
477 (cond ((eq char eof-value) char)
478 ((characterp peek-type)
479 (do ((char char (funcall-stm-handler j-read-char stream
482 ((or (eq char eof-value) (char= char peek-type))
483 (unless (eq char eof-value)
484 (funcall-stm-handler j-unread-char stream t))
487 (do ((char char (funcall-stm-handler j-read-char stream
490 ((or (eq char eof-value)
491 (not (sb-int:whitespace-char-p char)))
492 (unless (eq char eof-value)
493 (funcall-stm-handler j-unread-char stream t))
496 (funcall-stm-handler j-unread-char stream t)
499 (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
500 (cond ((eq char eof-value) char)
501 ((characterp peek-type)
502 (do ((char char (%ansi-stream-read-char stream eof-error-p
504 ((or (eq char eof-value) (char= char peek-type))
505 (unless (eq char eof-value)
506 (%ansi-stream-unread-char char stream))
509 (do ((char char (%ansi-stream-read-char stream eof-error-p
511 ((or (eq char eof-value)
512 (not (sb-int:whitespace-char-p char)))
513 (unless (eq char eof-value)
514 (%ansi-stream-unread-char char stream))
517 (%ansi-stream-unread-char char stream)
520 (cond ((characterp peek-type)
521 (do ((char (sb-gray:stream-read-char stream)
522 (sb-gray:stream-read-char stream)))
523 ((or (eq char :eof) (char= char peek-type))
524 (cond ((eq char :eof)
525 (sb-impl::eof-or-lose stream eof-error-p eof-value))
527 (sb-gray:stream-unread-char stream char)
530 (do ((char (sb-gray:stream-read-char stream)
531 (sb-gray:stream-read-char stream)))
532 ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
533 (cond ((eq char :eof)
534 (sb-impl::eof-or-lose stream eof-error-p eof-value))
536 (sb-gray:stream-unread-char stream char)
539 (let ((char (sb-gray:stream-peek-char stream)))
541 (sb-impl::eof-or-lose stream eof-error-p eof-value)
544 (defun listen (&optional (stream *standard-input*) (width 1))
545 "Returns T if Width octets are available on the given Stream. If Width
546 is given as 'character, check for a character."
547 ;; WIDTH is number of octets which must be available; any value
548 ;; other than 1 is treated as 'character.
549 (let ((stream (sb-impl::in-synonym-of stream)))
552 (%check-simple-stream stream :input)
553 (with-stream-class (simple-stream stream)
554 (if (not (eql width 1))
555 (funcall-stm-handler j-listen stream)
556 (or (< (sm buffpos stream) (sm buffer-ptr stream))
557 ;; Note: should try DEVICE-EXTEND for more on buffer streams
558 (when (>= (sm mode stream) 0) ;; device-connected
559 (incf (sm last-char-read-size stream))
560 (let ((ok (refill-buffer stream nil)))
561 (decf (sm last-char-read-size stream))
564 (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
565 sb-impl::+ansi-stream-in-buffer-length+)
566 ;; Test for T explicitly since misc methods return :EOF sometimes.
567 (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
570 (sb-gray:stream-listen stream)))))
572 (declaim (inline %simple-stream-read-line))
573 (defun %simple-stream-read-line (stream eof-error-p eof-value)
574 (declare (type simple-stream stream)
575 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
576 (with-stream-class (simple-stream)
577 (let* ((cbuf (make-string 80)) ; current buffer
578 (bufs (list cbuf)) ; list of buffers
579 (tail bufs) ; last cons of bufs list
580 (index 0) ; current index in current buffer
581 (total 0)) ; total characters
582 (declare (type simple-base-string cbuf)
583 (type cons bufs tail)
584 (type fixnum index total))
586 (multiple-value-bind (chars done)
587 (funcall-stm-handler j-read-chars stream cbuf
588 #\Newline index (length cbuf) t)
589 (declare (type fixnum chars))
592 (when (and (eq done :eof) (zerop index))
594 (error 'end-of-file :stream stream)
595 (return (values eof-value t))))
597 ;; If there's only one buffer in use, return it directly
598 (when (null (cdr bufs))
599 (return (values (sb-kernel:shrink-vector cbuf index)
601 ;; If total fits in final buffer, use it
603 (when (<= total (length cbuf))
604 (replace cbuf cbuf :start1 (- total index) :end2 index)
606 (declare (type fixnum idx))
608 (declare (type simple-base-string buf))
609 (replace cbuf buf :start1 idx)
610 (incf idx (length buf))))
611 (return (values (sb-kernel:shrink-vector cbuf index)
613 ;; Allocate new string of appropriate length
614 (let ((string (make-string total))
616 (declare (type fixnum index))
618 (declare (type simple-base-string buf))
619 (replace string buf :start1 index)
620 (incf index (length buf)))
621 (return (values string (eq done :eof)))))
622 (when (>= index (length cbuf))
623 (setf cbuf (make-string (the fixnum (* 2 index))))
625 (setf (cdr tail) (cons cbuf nil))
626 (setf tail (cdr tail))))))))
628 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
629 eof-value recursive-p)
630 "Returns a line of text read from the Stream as a string, discarding the
632 (declare (ignore recursive-p))
633 (let ((stream (sb-impl::in-synonym-of stream)))
636 (%check-simple-stream stream :input)
637 (%simple-stream-read-line stream eof-error-p eof-value))
639 (%ansi-stream-read-line stream eof-error-p eof-value))
641 (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
642 (if (and eof (zerop (length string)))
643 (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
644 (values string eof)))))))
646 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
647 "Destructively modify SEQ by reading elements from STREAM.
648 SEQ is bounded by START and END. SEQ is destructively modified by
649 copying successive elements into it from STREAM. If the end of file
650 for STREAM is reached before copying all elements of the subsequence,
651 then the extra elements near the end of sequence are not updated, and
652 the index of the next element is returned."
653 (let ((stream (sb-impl::in-synonym-of stream))
654 (end (or end (length seq))))
657 (with-stream-class (simple-stream stream)
658 (%check-simple-stream stream :input)
661 (funcall-stm-handler j-read-chars stream seq nil start end
662 (if partial-fill :bnb t)))
663 ((or (simple-array (unsigned-byte 8) (*))
664 (simple-array (signed-byte 8) (*)))
665 ;; TODO: "read-vector" equivalent, but blocking if
666 ;; partial-fill is NIL
667 (error "implement me")
670 (%ansi-stream-read-sequence seq stream start end))
672 (sb-gray:stream-read-sequence seq stream start end)))))
674 (defun clear-input (&optional (stream *standard-input*) buffer-only)
675 "Clears any buffered input associated with the Stream."
676 (let ((stream (sb-impl::in-synonym-of stream)))
679 (with-stream-class (simple-stream stream)
680 (%check-simple-stream stream :input)
681 (setf (sm buffpos stream) 0
682 (sm buffer-ptr stream) 0
683 (sm last-char-read-size stream) 0) ;; ??
684 (device-clear-input stream buffer-only)))
686 (setf (sb-kernel:ansi-stream-in-index stream)
687 sb-impl::+ansi-stream-in-buffer-length+)
688 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
690 (sb-gray:stream-clear-input stream))))
693 (defun write-byte (integer stream)
694 "Outputs an octet to the Stream."
695 (let ((stream (sb-impl::out-synonym-of stream)))
698 (%check-simple-stream stream :output)
699 (with-stream-class (simple-stream stream)
700 (cond ((any-stream-instance-flags stream :string)
701 (error "Can't write-byte on string streams"))
702 ((any-stream-instance-flags stream :dual)
703 (let ((ptr (sm outpos stream)))
704 (when (>= ptr (sm max-out-pos stream))
705 (dc-flush-buffer stream t)
706 (setf ptr (1- (sm outpos stream))))
707 (setf (sm outpos stream) (1+ ptr))
708 (setf (bref (sm out-buffer stream) ptr) integer)))
709 (t ;; single-channel-simple-stream
710 (let ((ptr (sm buffpos stream)))
711 ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
712 (when (>= ptr (sm buffer-ptr stream))
713 (sc-flush-buffer stream t)
714 (setf ptr (1- (sm buffpos stream))))
715 (setf (sm buffpos stream) (1+ ptr))
716 (setf (bref (sm buffer stream) ptr) integer))))))
718 (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
720 (sb-gray:stream-write-byte stream integer))))
723 (defun write-char (character &optional (stream *standard-output*))
724 "Outputs the Character to the Stream."
725 (let ((stream (sb-impl::out-synonym-of stream)))
728 (%check-simple-stream stream :output)
729 (with-stream-class (simple-stream stream)
730 (funcall-stm-handler-2 j-write-char character stream)))
732 (funcall (sb-kernel:ansi-stream-out stream) stream character))
734 (sb-gray:stream-write-char stream character))))
737 (defun write-string (string &optional (stream *standard-output*)
738 &key (start 0) (end nil))
739 "Outputs the String to the given Stream."
740 (let ((stream (sb-impl::out-synonym-of stream))
741 (end (or end (length string))))
744 (%check-simple-stream stream :output)
745 (with-stream-class (simple-stream stream)
746 (funcall-stm-handler-2 j-write-chars string stream start end))
749 (%ansi-stream-write-string string stream start end))
751 (sb-gray:stream-write-string stream string start end)))))
753 (defun write-line (string &optional (stream *standard-output*)
755 (declare (type string string))
756 ;; FIXME: Why is there this difference between the treatments of the
757 ;; STREAM argument in WRITE-STRING and WRITE-LINE?
758 (let ((stream (sb-impl::out-synonym-of stream))
759 (end (or end (length string))))
762 (%check-simple-stream stream :output)
763 (with-stream-class (simple-stream stream)
764 (funcall-stm-handler-2 j-write-chars string stream start end)
765 (funcall-stm-handler-2 j-write-char #\Newline stream)))
767 (%ansi-stream-write-string string stream start end)
768 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
770 (sb-gray:stream-write-string stream string start end)
771 (sb-gray:stream-terpri stream))))
774 (defun write-sequence (seq stream &key (start 0) (end nil))
775 "Write the elements of SEQ bounded by START and END to STREAM."
776 (let ((stream (sb-impl::out-synonym-of stream))
777 (end (or end (length seq))))
780 (%check-simple-stream stream :output)
781 (with-stream-class (simple-stream stream)
784 (funcall-stm-handler-2 j-write-chars seq stream start end))
785 ((or (simple-array (unsigned-byte 8) (*))
786 (simple-array (signed-byte 8) (*)))
787 ;; TODO: "write-vector" equivalent
788 (error "implement me")
791 (%ansi-stream-write-sequence seq stream start end))
793 (sb-gray:stream-write-sequence seq stream start end)))))
795 (defun terpri (&optional (stream *standard-output*))
796 "Outputs a new line to the Stream."
797 (let ((stream (sb-impl::out-synonym-of stream)))
800 (%check-simple-stream stream :output)
801 (with-stream-class (simple-stream stream)
802 (funcall-stm-handler-2 j-write-char #\Newline stream)))
804 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
806 (sb-gray:stream-terpri stream))))
809 (defun fresh-line (&optional (stream *standard-output*))
810 "Outputs a new line to the Stream if it is not positioned at the beginning of
811 a line. Returns T if it output a new line, nil otherwise."
812 (let ((stream (sb-impl::out-synonym-of stream)))
815 (%check-simple-stream stream :output)
816 (with-stream-class (simple-stream stream)
817 (when (/= (or (sm charpos stream) 1) 0)
818 (funcall-stm-handler-2 j-write-char #\Newline stream)
821 (when (/= (or (sb-kernel:charpos stream) 1) 0)
822 (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
825 (sb-gray:stream-fresh-line stream)))))
827 (defun finish-output (&optional (stream *standard-output*))
828 "Attempts to ensure that all output sent to the Stream has reached its
829 destination, and only then returns."
830 (let ((stream (sb-impl::out-synonym-of stream)))
833 (%check-simple-stream stream :output)
834 (with-stream-class (simple-stream stream)
835 (cond ((any-stream-instance-flags stream :string)
837 ((any-stream-instance-flags stream :dual)
838 (dc-flush-buffer stream t))
840 (sc-flush-buffer stream t)))))
842 (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
844 (sb-gray:stream-finish-output stream))))
847 (defun force-output (&optional (stream *standard-output*))
848 "Attempts to force any buffered output to be sent."
849 (let ((stream (sb-impl::out-synonym-of stream)))
852 (%check-simple-stream stream :output)
853 (with-stream-class (simple-stream stream)
854 (cond ((any-stream-instance-flags stream :string)
856 ((any-stream-instance-flags stream :dual)
857 (dc-flush-buffer stream nil))
859 (sc-flush-buffer stream nil)))))
861 (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
863 (sb-gray:stream-force-output stream))))
866 (defun clear-output (&optional (stream *standard-output*))
867 "Clears the given output Stream."
868 (let ((stream (sb-impl::out-synonym-of stream)))
871 (%check-simple-stream stream :output)
872 (with-stream-class (simple-stream stream)
873 #| clear output buffer |#
874 (device-clear-output stream)))
876 (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
878 (sb-gray:stream-clear-output stream))))
881 (defun file-position (stream &optional position)
882 "With one argument returns the current position within the file
883 File-Stream is open to. If the second argument is supplied, then
884 this becomes the new file position. The second argument may also
885 be :start or :end for the start and end of the file, respectively."
888 (%check-simple-stream stream)
890 ;; set unread to zero
891 ;; if position is within buffer, just move pointer; else
892 ;; flush output, if necessary
893 ;; set buffer pointer to 0, to force a read
894 (setf (device-file-position stream) position))
896 (let ((posn (device-file-position stream)))
897 ;; adjust for buffer position
899 #| TODO: implement me |#)
902 (setf (sb-kernel:ansi-stream-in-index stream)
903 sb-impl::+ansi-stream-in-buffer-length+)
904 (funcall (sb-kernel:ansi-stream-misc stream)
905 stream :file-position position))
907 (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
908 stream :file-position nil)))
911 (- sb-impl::+ansi-stream-in-buffer-length+
912 (sb-kernel:ansi-stream-in-index stream))))))))
914 (error "file-position not supported on Gray streams."))))
916 (defun file-length (stream)
917 "This function returns the length of the file that File-Stream is open to."
920 (%check-simple-stream stream)
921 (device-file-length stream)
924 (sb-impl::stream-must-be-associated-with-file stream)
925 (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))
927 (error "file-length not supported on Gray streams."))))
929 (defun line-length (&optional (stream *standard-output*))
930 "Returns the number of characters that will fit on a line of output on the
931 given Stream, or Nil if that information is not available."
932 (let ((stream (sb-impl::out-synonym-of stream)))
935 (%check-simple-stream stream :output)
938 (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
940 (sb-gray:stream-line-length stream)))))
942 (defun charpos (&optional (stream *standard-output*))
943 "Returns the number of characters on the current line of output of the given
944 Stream, or Nil if that information is not availible."
945 (let ((stream (sb-impl::out-synonym-of stream)))
948 (%check-simple-stream stream :output)
949 (with-stream-class (simple-stream) (sm charpos stream)))
951 (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
953 (sb-gray:stream-line-column stream)))))
955 (defun line-length (&optional (stream *standard-output*))
956 "Returns the number of characters in a line of output of the given
957 Stream, or Nil if that information is not availible."
958 (let ((stream (sb-impl::out-synonym-of stream)))
961 (%check-simple-stream stream :output)
962 ;; TODO (sat 2003-04-02): a way to specify a line length would
963 ;; be good, I suppose. Returning nil here means
964 ;; sb-pretty::default-line-length is used.
967 (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
969 (sb-gray:stream-line-length stream)))))
971 (defun wait-for-input-available (stream &optional timeout)
972 "Waits for input to become available on the Stream and returns T. If
973 Timeout expires, Nil is returned."
974 (let ((stream (sb-impl::in-synonym-of stream)))
977 (sb-sys:wait-until-fd-usable stream :input timeout))
979 (%check-simple-stream stream :input)
980 (with-stream-class (simple-stream stream)
981 (or (< (sm buffpos stream) (sm buffer-ptr stream))
982 (wait-for-input-available (sm input-handle stream) timeout))))
984 (wait-for-input-available (two-way-stream-input-stream stream) timeout))
986 (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
989 (or (< (sb-impl::fd-stream-in-index stream)
990 (length (sb-impl::fd-stream-in-buffer stream)))
991 (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
997 (defmethod shared-initialize :after ((instance simple-stream) slot-names
998 &rest initargs &allow-other-keys)
999 (declare (ignore slot-names))
1000 (unless (slot-boundp instance 'melded-stream)
1001 (setf (slot-value instance 'melded-stream) instance)
1002 (setf (slot-value instance 'melding-base) instance))
1003 (unless (device-open instance initargs)
1004 (device-close instance t)))
1006 ;;; From the simple-streams documentation: "A generic function implies
1007 ;;; a specialization capability that does not exist for
1008 ;;; simple-streams; simple-stream specializations should be on
1009 ;;; device-close." So don't do it.
1010 (defmethod close ((stream simple-stream) &key abort)
1011 (device-close stream abort))
1015 ;;; sat 2003-01-12: What is this for?
1017 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1018 (declare (type fundamental-stream stream) ;; this is a lie
1022 (ext:stream-listen stream))
1024 (ext:stream-unread-char stream arg1))
1028 (ext:stream-clear-input stream))
1030 (ext:stream-force-output stream))
1032 (ext:stream-finish-output stream))
1034 (stream-element-type stream))
1036 (interactive-stream-p stream))
1038 (ext:stream-line-length stream))
1040 (ext:stream-line-column stream))
1042 (file-length stream))
1044 (file-position stream arg1))))