0.8alpha.0.27:
[sbcl.git] / contrib / sb-simple-streams / cl.lisp
1 ;;; -*- lisp -*-
2
3 ;;; This code is in the public domain.
4
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
7 ;;; Schlatte.
8
9 (in-package "SB-SIMPLE-STREAMS")
10
11
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.
17
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))
21
22 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
23   (declare (ignore blocking))
24   #+nil
25   (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
26   (sb-int:prepare-for-fast-read-byte stream
27     (prog1
28         (sb-int:fast-read-byte eof-error-p eof-value t)
29       (sb-int:done-with-fast-read-byte))))
30
31 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
32   (declare (ignore blocking))
33   #+nil
34   (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
35   (sb-int:prepare-for-fast-read-char stream
36     (prog1
37         (sb-int:fast-read-char eof-error-p eof-value)
38       (sb-int:done-with-fast-read-char))))
39
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"))
45     (cond (buffer
46            (setf (aref buffer index) (char-code character))
47            (setf (sb-kernel:ansi-stream-in-index stream) index))
48           (t
49            (funcall (sb-kernel:ansi-stream-misc stream) stream
50                     :unread character)))))
51
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))
55           (len 80)
56           (index 0))
57       (loop
58        (let ((ch (sb-int:fast-read-char nil nil)))
59          (cond (ch
60                 (when (char= ch #\newline)
61                   (sb-int:done-with-fast-read-char)
62                   (return (values (sb-kernel:shrink-vector res index) nil)))
63                 (when (= index len)
64                   (setq len (* len 2))
65                   (let ((new (make-string len)))
66                     (replace new res)
67                     (setq res new)))
68                 (setf (schar res index) ch)
69                 (incf index))
70                ((zerop index)
71                 (sb-int:done-with-fast-read-char)
72                 (return (values (sb-impl::eof-or-lose stream eof-error-p
73                                                       eof-value)
74                                 t)))
75                ;; Since FAST-READ-CHAR already hit the eof char, we
76                ;; shouldn't do another READ-CHAR.
77                (t
78                 (sb-int:done-with-fast-read-char)
79                 (return (values (sb-kernel:shrink-vector res index) t)))))))))
80
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))
89     (etypecase seq
90       (list
91        (let ((read-function
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))
96               (i start (1+ i)))
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)))
101              (when (eq el :eof)
102                (return i))
103              (setf (first rem) el)))))
104       (vector
105        (sb-kernel:with-array-data ((data seq) (offset-start start)
106                                    (offset-end end))
107          (typecase data
108            ((or (simple-array (unsigned-byte 8) (*))
109                 (simple-array (signed-byte 8) (*))
110                 simple-string)
111             (let* ((numbytes (- end start))
112                    (bytes-read (sb-sys:read-n-bytes stream
113                                                     data
114                                                     offset-start
115                                                     numbytes
116                                                     nil)))
117               (if (< bytes-read numbytes)
118                   (+ start bytes-read)
119                   end)))
120            (t
121             (let ((read-function
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)))
129                   (when (eq el :eof)
130                     (return (+ start (- i offset-start))))
131                   (setf (aref data i) el)))))))))))
132
133
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))
138
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~:>"
149            start
150            end
151            string))
152
153   (if (sb-kernel:array-header-p string)
154       (sb-kernel:with-array-data ((data string) (offset-start start)
155                                   (offset-end end))
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))
159   string)
160
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)
166            (values sequence))
167   (let ((end (or %end (length seq))))
168     (declare (type sb-int:index end))
169     (etypecase seq
170       (list
171        (let ((write-function
172               (if (subtypep (stream-element-type stream) 'character)
173                   ;; TODO: Replace these with ansi-stream specific
174                   ;; functions too.
175                   #'write-char
176                   #'write-byte)))
177          (do ((rem (nthcdr start seq) (rest rem))
178               (i start (1+ i)))
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))))
183       (string
184        (%ansi-stream-write-string seq stream start end))
185       (vector
186        (let ((write-function
187               (if (subtypep (stream-element-type stream) 'character)
188                   ;; TODO: Replace these with ansi-stream specific
189                   ;; functions too.
190                   #'write-char
191                   #'write-byte)))
192          (do ((i start (1+ i)))
193              ((>= i end) seq)
194            (declare (type sb-int:index i))
195            (funcall write-function (aref seq i) stream)))))))
196
197
198 ;;;
199 ;;; USER-LEVEL FUNCTIONS
200 ;;;
201
202 (defmethod open-stream-p ((stream simple-stream))
203   (any-stream-instance-flags stream :input :output))
204
205 (defmethod input-stream-p ((stream simple-stream))
206   (any-stream-instance-flags stream :input))
207
208 (defmethod output-stream-p ((stream simple-stream))
209   (any-stream-instance-flags stream :output))
210
211 (defmethod stream-element-type ((stream simple-stream))
212   '(unsigned-byte 8))
213
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))
217   (etypecase stream
218     (simple-stream
219      (any-stream-instance-flags stream :interactive))
220     (ansi-stream
221      (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
222     (fundamental-stream nil)))
223
224 (defun (setf interactive-stream-p) (value stream)
225   (etypecase stream
226     (simple-stream
227      (if value
228          (add-stream-instance-flags stream :interactive)
229          (remove-stream-instance-flags stream :interactive)))))
230
231 (defun stream-external-format (stream)
232   "Returns Stream's external-format."
233   (declare (type stream stream))
234   (etypecase stream
235     (simple-stream
236      (with-stream-class (simple-stream)
237        (sm external-format stream)))
238     (ansi-stream
239      :default)
240     (fundamental-stream #| not defined on Gray streams? |#
241      :default)))
242
243 (defgeneric default-open-class (name &optional element-type)
244   (:documentation
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))
250      nil)
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))))
260
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
267              &allow-other-keys)
268   "Return a stream which reads from or writes to Filename.
269   Defined keywords:
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.
277
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
283
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))
290   (let ((klass class)
291         (options (copy-list options))
292         (filespec (if (stringp filename) (parse-filespec filename) filename)))
293     (unless klass
294       (setq klass (default-open-class filespec (if element-type-given
295                                                    element-type
296                                                    nil))))
297     (unless klass
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 :claass)
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."))
323           (t
324            (if class
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))))))))
328
329 (defmacro %check-simple-stream (stream &optional direction)
330   ;; Check that STREAM is valid and open in the appropriate direction.
331   `(locally
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))
339                ,@(when direction
340                    `(((zerop (logand flags ,(%flags (list direction))))
341                       (error ,(format nil "~~S is not an ~(~A~) stream."
342                                       direction)
343                              stream)))))))))
344
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)
348     ;; @@1
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))
353           (if (plusp bytes)
354               (setf (sm buffer-ptr stream) bytes
355                     ptr 0)
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))))
361
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))
368           (if (plusp bytes)
369               (setf (sm buffer-ptr stream) bytes
370                     ptr 0)
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))))
376
377 (declaim (inline read-byte read-char read-char-no-hang unread-char))
378
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)))
382     (etypecase stream
383       (simple-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)))
391                     (unless encap
392                       (error "Can't read-byte on string streams"))
393                     (prog1
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)))))
402       (ansi-stream
403        (%ansi-stream-read-byte stream eof-error-p eof-value t))
404       (fundamental-stream
405        (let ((char (sb-gray:stream-read-byte stream)))
406          (if (eq char :eof)
407              (sb-impl::eof-or-lose stream eof-error-p eof-value)
408              char))))))
409
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)))
415     (etypecase stream
416       (simple-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)))
420       (ansi-stream
421        (%ansi-stream-read-char stream eof-error-p eof-value t))
422       (fundamental-stream
423        (let ((char (sb-gray:stream-read-char stream)))
424          (if (eq char :eof)
425              (sb-impl::eof-or-lose stream eof-error-p eof-value)
426              char))))))
427
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)))
433     (etypecase stream
434       (simple-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)))
438       (ansi-stream
439        (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
440            (%ansi-stream-read-char stream eof-error-p eof-value t)
441            nil))
442       (fundamental-stream
443        (let ((char (sb-gray:stream-read-char-no-hang stream)))
444          (if (eq char :eof)
445              (sb-impl::eof-or-lose stream eof-error-p eof-value)
446              char))))))
447
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)))
451     (etypecase stream
452       (simple-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))))
458       (ansi-stream
459        (%ansi-stream-unread-char character stream))
460       (fundamental-stream
461        (sb-gray:stream-unread-char stream character))))
462   nil)
463
464 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
465
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)))
471     (etypecase stream
472       (simple-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
480                                                        eof-error-p
481                                                        eof-value t)))
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))
485                        char)))
486                  ((eq peek-type t)
487                   (do ((char char (funcall-stm-handler j-read-char stream
488                                                        eof-error-p
489                                                        eof-value t)))
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))
494                        char)))
495                  (t
496                   (funcall-stm-handler j-unread-char stream t)
497                   char)))))
498       (ansi-stream
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
503                                                          eof-value t)))
504                      ((or (eq char eof-value) (char= char peek-type))
505                       (unless (eq char eof-value)
506                         (%ansi-stream-unread-char char stream))
507                       char)))
508                 ((eq peek-type t)
509                  (do ((char char (%ansi-stream-read-char stream eof-error-p
510                                                          eof-value t)))
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))
515                       char)))
516                 (t
517                  (%ansi-stream-unread-char char stream)
518                  char))))
519       (fundamental-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))
526                          (t
527                           (sb-gray:stream-unread-char stream char)
528                           char)))))
529              ((eq peek-type t)
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))
535                          (t
536                           (sb-gray:stream-unread-char stream char)
537                           char)))))
538              (t
539               (let ((char (sb-gray:stream-peek-char stream)))
540                 (if (eq char :eof)
541                     (sb-impl::eof-or-lose stream eof-error-p eof-value)
542                     char))))))))
543
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)))
550     (etypecase stream
551       (simple-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))
562                      (plusp ok)))))))
563       (ansi-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)
568                 t)))
569       (fundamental-stream
570        (sb-gray:stream-listen stream)))))
571
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))
585       (loop
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))
590           (incf index chars)
591           (incf total chars)
592           (when (and (eq done :eof) (zerop index))
593             (if eof-error-p
594                 (error 'end-of-file :stream stream)
595                 (return (values eof-value t))))
596           (when done
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)
600                               (eq done :eof))))
601             ;; If total fits in final buffer, use it
602             #-ignore
603             (when (<= total (length cbuf))
604               (replace cbuf cbuf :start1 (- total index) :end2 index)
605               (let ((idx 0))
606                 (declare (type fixnum idx))
607                 (dolist (buf bufs)
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)
612                               (eq done :eof))))
613             ;; Allocate new string of appropriate length
614             (let ((string (make-string total))
615                   (index 0))
616               (declare (type fixnum index))
617               (dolist (buf bufs)
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))))
624             (setf index 0)
625             (setf (cdr tail) (cons cbuf nil))
626             (setf tail (cdr tail))))))))
627
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
631   newline character."
632   (declare (ignore recursive-p))
633   (let ((stream (sb-impl::in-synonym-of stream)))
634     (etypecase stream
635       (simple-stream
636        (%check-simple-stream stream :input)
637        (%simple-stream-read-line stream eof-error-p eof-value))
638       (ansi-stream
639        (%ansi-stream-read-line stream eof-error-p eof-value))
640       (fundamental-stream
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)))))))
645
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))))
655     (etypecase stream
656       (simple-stream
657        (with-stream-class (simple-stream stream)
658          (%check-simple-stream stream :input)
659          (etypecase seq
660            (string
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")
668             ))))
669       (ansi-stream
670        (%ansi-stream-read-sequence seq stream start end))
671       (fundamental-stream
672        (sb-gray:stream-read-sequence seq stream start end)))))
673
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)))
677     (etypecase stream
678       (simple-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)))
685       (ansi-stream
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))
689       (fundamental-stream
690        (sb-gray:stream-clear-input stream))))
691   nil)
692
693 (defun write-byte (integer stream)
694   "Outputs an octet to the Stream."
695   (let ((stream (sb-impl::out-synonym-of stream)))
696     (etypecase stream
697       (simple-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                   (when (>= ptr (sm buffer-ptr stream))
712                     (sc-flush-buffer stream t)
713                     (setf ptr (1- (sm buffpos stream))))
714                   (setf (sm buffpos stream) (1+ ptr))
715                   (setf (bref (sm buffer stream) ptr) integer))))))
716       (ansi-stream
717        (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
718       (fundamental-stream
719        (sb-gray:stream-write-byte stream integer))))
720   integer)
721
722 (defun write-char (character &optional (stream *standard-output*))
723   "Outputs the Character to the Stream."
724   (let ((stream (sb-impl::out-synonym-of stream)))
725     (etypecase stream
726       (simple-stream
727        (%check-simple-stream stream :output)
728        (with-stream-class (simple-stream stream)
729          (funcall-stm-handler-2 j-write-char character stream)))
730       (ansi-stream
731        (funcall (sb-kernel:ansi-stream-out stream) stream character))
732       (fundamental-stream
733        (sb-gray:stream-write-char stream character))))
734   character)
735
736 (defun write-string (string &optional (stream *standard-output*)
737                             &key (start 0) (end nil))
738   "Outputs the String to the given Stream."
739   (let ((stream (sb-impl::out-synonym-of stream))
740         (end (or end (length string))))
741     (etypecase stream
742       (simple-stream
743        (%check-simple-stream stream :output)
744        (with-stream-class (simple-stream stream)
745          (funcall-stm-handler-2 j-write-chars string stream start end))
746        string)
747       (ansi-stream
748        (%ansi-stream-write-string string stream start end))
749       (fundamental-stream
750        (sb-gray:stream-write-string stream string start end)))))
751
752 (defun write-line (string &optional (stream *standard-output*)
753                           &key (start 0) end)
754   (declare (type string string))
755   ;; FIXME: Why is there this difference between the treatments of the
756   ;; STREAM argument in WRITE-STRING and WRITE-LINE?
757   (let ((stream (sb-impl::out-synonym-of stream))
758         (end (or end (length string))))
759     (etypecase stream
760       (simple-stream
761        (%check-simple-stream stream :output)
762        (with-stream-class (simple-stream stream)
763          (funcall-stm-handler-2 j-write-chars string stream start end)
764          (funcall-stm-handler-2 j-write-char #\Newline stream)))
765       (ansi-stream
766        (%ansi-stream-write-string string stream start end)
767        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
768       (fundamental-stream
769        (sb-gray:stream-write-string stream string start end)
770        (sb-gray:stream-terpri stream))))
771   string)
772
773 (defun write-sequence (seq stream &key (start 0) (end nil))
774   "Write the elements of SEQ bounded by START and END to STREAM."
775   (let ((stream (sb-impl::out-synonym-of stream))
776         (end (or end (length seq))))
777     (etypecase stream
778       (simple-stream
779        (%check-simple-stream stream :output)
780        (with-stream-class (simple-stream stream)
781          (etypecase seq
782            (string
783             (funcall-stm-handler-2 j-write-chars seq stream start end))
784            ((or (simple-array (unsigned-byte 8) (*))
785                 (simple-array (signed-byte 8) (*)))
786             ;; TODO: "write-vector" equivalent
787             (error "implement me")
788             ))))
789       (ansi-stream
790        (%ansi-stream-write-sequence seq stream start end))
791       (fundamental-stream
792        (sb-gray:stream-write-sequence seq stream start end)))))
793
794 (defun terpri (&optional (stream *standard-output*))
795   "Outputs a new line to the Stream."
796   (let ((stream (sb-impl::out-synonym-of stream)))
797     (etypecase stream
798       (simple-stream
799        (%check-simple-stream stream :output)
800        (with-stream-class (simple-stream stream)
801          (funcall-stm-handler-2 j-write-char #\Newline stream)))
802       (ansi-stream
803        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
804       (fundamental-stream
805        (sb-gray:stream-terpri stream))))
806   nil)
807
808 (defun fresh-line (&optional (stream *standard-output*))
809   "Outputs a new line to the Stream if it is not positioned at the beginning of
810    a line.  Returns T if it output a new line, nil otherwise."
811   (let ((stream (sb-impl::out-synonym-of stream)))
812     (etypecase stream
813       (simple-stream
814        (%check-simple-stream stream :output)
815        (with-stream-class (simple-stream stream)
816          (when (/= (or (sm charpos stream) 1) 0)
817            (funcall-stm-handler-2 j-write-char #\Newline stream)
818            t)))
819       (ansi-stream
820        (when (/= (or (sb-kernel:charpos stream) 1) 0)
821          (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
822          t))
823       (fundamental-stream
824        (sb-gray:stream-fresh-line stream)))))
825
826 (defun finish-output (&optional (stream *standard-output*))
827   "Attempts to ensure that all output sent to the Stream has reached its
828    destination, and only then returns."
829   (let ((stream (sb-impl::out-synonym-of stream)))
830     (etypecase stream
831       (simple-stream
832        (%check-simple-stream stream :output)
833        (with-stream-class (simple-stream stream)
834          (cond ((any-stream-instance-flags stream :string)
835                 #| nothing to do |#)
836                ((any-stream-instance-flags stream :dual)
837                 (dc-flush-buffer stream t))
838                (t
839                 (sc-flush-buffer stream t)))))
840       (ansi-stream
841        (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
842       (fundamental-stream
843        (sb-gray:stream-finish-output stream))))
844   nil)
845
846 (defun force-output (&optional (stream *standard-output*))
847   "Attempts to force any buffered output to be sent."
848   (let ((stream (sb-impl::out-synonym-of stream)))
849     (etypecase stream
850       (simple-stream
851        (%check-simple-stream stream :output)
852        (with-stream-class (simple-stream stream)
853          (cond ((any-stream-instance-flags stream :string)
854                 #| nothing to do |#)
855                ((any-stream-instance-flags stream :dual)
856                 (dc-flush-buffer stream nil))
857                (t
858                 (sc-flush-buffer stream nil)))))
859       (ansi-stream
860        (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
861       (fundamental-stream
862        (sb-gray:stream-force-output stream))))
863   nil)
864
865 (defun clear-output (&optional (stream *standard-output*))
866   "Clears the given output Stream."
867   (let ((stream (sb-impl::out-synonym-of stream)))
868     (etypecase stream
869       (simple-stream
870        (%check-simple-stream stream :output)
871        (with-stream-class (simple-stream stream)
872          #| clear output buffer |#
873          (device-clear-output stream)))
874       (ansi-stream
875        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
876       (fundamental-stream
877        (sb-gray:stream-clear-output stream))))
878   nil)
879
880 (defun file-position (stream &optional position)
881   "With one argument returns the current position within the file
882    File-Stream is open to.  If the second argument is supplied, then
883    this becomes the new file position.  The second argument may also
884    be :start or :end for the start and end of the file, respectively."
885   (etypecase stream
886     (simple-stream
887      (%check-simple-stream stream)
888      (cond (position
889             ;; set unread to zero
890             ;; if position is within buffer, just move pointer; else
891             ;; flush output, if necessary
892             ;; set buffer pointer to 0, to force a read
893             (setf (device-file-position stream) position))
894            (t
895             (let ((posn (device-file-position stream)))
896               ;; adjust for buffer position
897               )))
898      #| TODO: implement me |#)
899     (ansi-stream
900      (cond (position
901             (setf (sb-kernel:ansi-stream-in-index stream)
902                   sb-impl::+ansi-stream-in-buffer-length+)
903             (funcall (sb-kernel:ansi-stream-misc stream)
904                      stream :file-position position))
905            (t
906             (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
907                                 stream :file-position nil)))
908               (when res
909                 (- res
910                    (- sb-impl::+ansi-stream-in-buffer-length+
911                       (sb-kernel:ansi-stream-in-index stream))))))))
912     (fundamental-stream
913      (error "file-position not supported on Gray streams."))))
914
915 (defun file-length (stream)
916   "This function returns the length of the file that File-Stream is open to."
917   (etypecase stream
918     (simple-stream
919      (%check-simple-stream stream)
920      (device-file-length stream)
921      #| implement me |#)
922     (ansi-stream
923      (sb-impl::stream-must-be-associated-with-file stream)
924      (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))
925     (fundamental-stream
926      (error "file-length not supported on Gray streams."))))
927
928 (defun line-length (&optional (stream *standard-output*))
929   "Returns the number of characters that will fit on a line of output on the
930   given Stream, or Nil if that information is not available."
931   (let ((stream (sb-impl::out-synonym-of stream)))
932     (etypecase stream
933       (simple-stream
934        (%check-simple-stream stream :output)
935        #| implement me |#)
936       (ansi-stream
937        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
938       (fundamental-stream
939        (sb-gray:stream-line-length stream)))))
940
941 (defun charpos (&optional (stream *standard-output*))
942   "Returns the number of characters on the current line of output of the given
943   Stream, or Nil if that information is not availible."
944   (let ((stream (sb-impl::out-synonym-of stream)))
945     (etypecase stream
946       (simple-stream
947        (%check-simple-stream stream :output)
948        (with-stream-class (simple-stream) (sm charpos stream)))
949       (ansi-stream
950        (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
951       (fundamental-stream
952        (sb-gray:stream-line-column stream)))))
953
954 (defun line-length (&optional (stream *standard-output*))
955   "Returns the number of characters in a line of output of the given
956   Stream, or Nil if that information is not availible."
957   (let ((stream (sb-impl::out-synonym-of stream)))
958     (etypecase stream
959       (simple-stream
960        (%check-simple-stream stream :output)
961        ;; TODO (sat 2003-04-02): a way to specify a line length would
962        ;; be good, I suppose.  Returning nil here means
963        ;; sb-pretty::default-line-length is used.
964        nil)
965       (ansi-stream
966        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
967       (fundamental-stream
968        (sb-gray:stream-line-length stream)))))
969
970 (defun wait-for-input-available (stream &optional timeout)
971   "Waits for input to become available on the Stream and returns T.  If
972   Timeout expires, Nil is returned."
973   (let ((stream (sb-impl::in-synonym-of stream)))
974     (etypecase stream
975       (fixnum
976        (sb-sys:wait-until-fd-usable stream :input timeout))
977       (simple-stream
978        (%check-simple-stream stream :input)
979        (with-stream-class (simple-stream stream)
980          (or (< (sm buffpos stream) (sm buffer-ptr stream))
981              (wait-for-input-available (sm input-handle stream) timeout))))
982       (two-way-stream
983        (wait-for-input-available (two-way-stream-input-stream stream) timeout))
984       (synonym-stream
985        (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
986                                  timeout))
987       (sb-sys::file-stream
988        (or (< (sb-impl::fd-stream-in-index stream)
989               (length (sb-impl::fd-stream-in-buffer stream)))
990            (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
991
992 ;;;
993 ;;; SETUP
994 ;;;
995
996 (defmethod shared-initialize :after ((instance simple-stream) slot-names
997                                      &rest initargs &allow-other-keys)
998   (declare (ignore slot-names))
999   (unless (slot-boundp instance 'melded-stream)
1000     (setf (slot-value instance 'melded-stream) instance)
1001     (setf (slot-value instance 'melding-base) instance))
1002   (unless (device-open instance initargs)
1003     (device-close instance t)))
1004
1005 (defmethod close ((stream simple-stream) &key abort)
1006   (device-close stream abort))
1007
1008
1009 ;;; bugfix
1010 ;;; sat 2003-01-12: What is this for?
1011 #+nil
1012 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1013   (declare (type fundamental-stream stream) ;; this is a lie
1014            (ignore arg2))
1015   (case operation
1016     (:listen
1017      (ext:stream-listen stream))
1018     (:unread
1019      (ext:stream-unread-char stream arg1))
1020     (:close
1021      (close stream))
1022     (:clear-input
1023      (ext:stream-clear-input stream))
1024     (:force-output
1025      (ext:stream-force-output stream))
1026     (:finish-output
1027      (ext:stream-finish-output stream))
1028     (:element-type
1029      (stream-element-type stream))
1030     (:interactive-p
1031      (interactive-stream-p stream))
1032     (:line-length
1033      (ext:stream-line-length stream))
1034     (:charpos
1035      (ext:stream-line-column stream))
1036     (:file-length
1037      (file-length stream))
1038     (:file-position
1039      (file-position stream arg1))))