Suppress warnings about possible slot name conflicts with slots from SB-PCL.
[sbcl.git] / contrib / sb-simple-streams / impl.lisp
1 ;;; -*- lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
5 ;;; domain.
6 ;;;
7
8 ;;; Sbcl port by Rudi Schlatte.
9
10 (in-package "SB-SIMPLE-STREAMS")
11
12 ;;;
13 ;;; **********************************************************************
14 ;;;
15 ;;; Implementations of standard Common Lisp functions for simple-streams
16
17 (defun %uninitialized (stream)
18   (error "~S has not been initialized." stream))
19
20 (defun %check (stream kind)
21   (declare (type simple-stream stream)
22            (optimize (speed 3) (space 1) (debug 0) (safety 0)))
23   (with-stream-class (simple-stream stream)
24     (cond ((not (any-stream-instance-flags stream :simple))
25            (%uninitialized stream))
26           ((and (eq kind :open)
27                 (not (any-stream-instance-flags stream :input :output)))
28            (sb-kernel:closed-flame stream))
29           ((and (or (eq kind :input) (eq kind :io))
30                 (not (any-stream-instance-flags stream :input)))
31            (sb-kernel:ill-in stream))
32           ((and (or (eq kind :output) (eq kind :io))
33                 (not (any-stream-instance-flags stream :output)))
34            (sb-kernel:ill-out stream)))))
35
36 (defmethod input-stream-p ((stream simple-stream))
37   (any-stream-instance-flags stream :input))
38
39 (defmethod output-stream-p ((stream simple-stream))
40   (any-stream-instance-flags stream :output))
41
42 (defmethod open-stream-p ((stream simple-stream))
43   (any-stream-instance-flags stream :input :output))
44
45 ;;; From the simple-streams documentation: "A generic function implies
46 ;;; a specialization capability that does not exist for
47 ;;; simple-streams; simple-stream specializations should be on
48 ;;; device-close."  So don't do it.
49 (defmethod close ((stream simple-stream) &key abort)
50   (device-close stream abort))
51
52 (defun %file-position (stream position)
53   (declare (type simple-stream stream)
54            (type (or (integer 0 *) (member nil :start :end)) position))
55   (with-stream-class (simple-stream stream)
56     (%check stream :open)
57     (if position
58         ;; Adjust current position
59         (let ((position (case position (:start 0) (:end -1)
60                               (otherwise position))))
61           (etypecase stream
62             (single-channel-simple-stream
63              (when (sc-dirty-p stream)
64                (flush-buffer stream t)))
65             (dual-channel-simple-stream
66              (with-stream-class (dual-channel-simple-stream stream)
67                (when (> (sm outpos stream) 0)
68                  (device-write stream :flush 0 nil t))))
69             (string-simple-stream
70              nil))
71
72           (setf (sm last-char-read-size stream) 0)
73           (setf (sm buffpos stream) 0   ; set pointer to 0 to force a read
74                 (sm buffer-ptr stream) 0)
75           (setf (sm charpos stream) nil)
76           (remove-stream-instance-flags stream :eof)
77           (setf (device-file-position stream) position))
78         ;; Just report current position
79         (let ((posn (device-file-position stream)))
80           (when posn
81             (when (sm handler stream)
82               (dolist (queued (sm pending stream))
83                 (incf posn (- (the sb-int:index (third queued))
84                               (the sb-int:index (second queued))))))
85             (etypecase stream
86               (single-channel-simple-stream
87                (case (sm mode stream)
88                  ((0 3)         ; read, read-modify
89                   ;; Note that posn can increase here if we wrote
90                   ;; past the end of previously-read data
91                   (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
92                  (1                     ; write
93                   (incf posn (sm buffpos stream)))))
94               (dual-channel-simple-stream
95                (with-stream-class (dual-channel-simple-stream stream)
96                  (incf posn (sm outpos stream))
97                  (when (>= (sm buffer-ptr stream) 0)
98                    (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))))
99               (string-simple-stream
100                nil)))
101           posn))))
102
103 (defun %file-length (stream)
104   (declare (type simple-stream stream))
105   (%check stream :open)
106   (device-file-length stream))
107
108
109 (defun %file-name (stream)
110   (declare (type simple-stream stream))
111   (%check stream nil)
112   (typecase stream
113     (file-simple-stream
114      (with-stream-class (file-simple-stream stream)
115        (sm pathname stream)))
116     (probe-simple-stream
117      (with-stream-class (probe-simple-stream stream)
118        (sm pathname stream)))
119     (otherwise
120      nil)))
121
122
123 (defun %file-rename (stream new-name)
124   (declare (type simple-stream stream))
125   (%check stream nil)
126   (if (typep stream 'file-simple-stream)
127       (with-stream-class (file-simple-stream stream)
128         (setf (sm pathname stream) new-name)
129         (setf (sm filename stream) (file-namestring new-name))
130         t)
131       nil))
132
133
134 (defun %file-string-length (stream object)
135   (declare (type simple-stream stream))
136   (with-stream-class (simple-stream stream)
137     (%check stream :output)
138     ;; FIXME: need to account for compositions on the stream...
139     (let ((count 0))
140       (flet ((fn (octet)
141                (declare (ignore octet))
142                (incf count)))
143         (etypecase object
144           (character
145            (let ((x nil))
146              (char-to-octets (sm external-format stream) object x #'fn)))
147           (string
148            (let ((x nil)
149                  (ef (sm external-format stream)))
150              (dotimes (i (length object))
151                (declare (type sb-int:index i))
152                (char-to-octets ef (char object i) x #'fn))))))
153       count)))
154
155
156 (defun %read-line (stream eof-error-p eof-value recursive-p)
157   (declare (optimize (speed 3) (space 1) (safety 0) (debug 0))
158            (type simple-stream stream)
159            (ignore recursive-p))
160   (with-stream-class (simple-stream stream)
161     (%check stream :input)
162     (when (any-stream-instance-flags stream :eof)
163       (return-from %read-line
164         (sb-impl::eof-or-lose stream eof-error-p eof-value)))
165     ;; for interactive streams, finish output first to force prompt
166     (when (and (any-stream-instance-flags stream :output)
167                (any-stream-instance-flags stream :interactive))
168       (%finish-output stream))
169     (let* ((encap (sm melded-stream stream)) ; encapsulating stream
170            (cbuf (make-string 80))      ; current buffer
171            (bufs (list cbuf))           ; list of buffers
172            (tail bufs)                  ; last cons of bufs list
173            (index 0)                    ; current index in current buffer
174            (total 0))                   ; total characters
175       (declare (type simple-stream encap)
176                (type simple-string cbuf)
177                (type cons bufs tail)
178                (type sb-int:index index total))
179       (loop
180         (multiple-value-bind (chars done)
181             (funcall-stm-handler j-read-chars encap cbuf
182                                  #\Newline index (length cbuf) t)
183           (declare (type sb-int:index chars))
184           (incf index chars)
185           (incf total chars)
186           (when (and (eq done :eof) (zerop total))
187             (if eof-error-p
188                 (error 'end-of-file :stream stream)
189                 (return (values eof-value t))))
190           (when done
191             ;; If there's only one buffer in use, return it directly
192             (when (null (cdr bufs))
193               (return (values (sb-kernel:shrink-vector cbuf total)
194                               (eq done :eof))))
195             ;; If total fits in final buffer, use it
196             (when (<= total (length cbuf))
197               (replace cbuf cbuf :start1 (- total index) :end2 index)
198               (let ((idx 0))
199                 (declare (type sb-int:index idx))
200                 (do ((list bufs (cdr list)))
201                     ((eq list tail))
202                   (let ((buf (car list)))
203                     (declare (type simple-string buf))
204                     (replace cbuf buf :start1 idx)
205                     (incf idx (length buf)))))
206               (return (values (sb-kernel:shrink-vector cbuf total)
207                               (eq done :eof))))
208             ;; Allocate new string of appropriate length
209             (let ((string (make-string total))
210                   (index 0))
211               (declare (type sb-int:index index))
212               (dolist (buf bufs)
213                 (declare (type simple-string buf))
214                 (replace string buf :start1 index)
215                 (incf index (length buf)))
216               (return  (values string (eq done :eof)))))
217           (when (>= index (length cbuf))
218             (setf cbuf (make-string (the sb-int:index (* 2 index))))
219             (setf index 0)
220             (setf (cdr tail) (cons cbuf nil))
221             (setf tail (cdr tail))))))))
222
223 (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p)
224   (declare (type simple-stream stream)
225            (ignore recursive-p))
226   (with-stream-class (simple-stream stream)
227     (%check stream :input)
228     (when (any-stream-instance-flags stream :eof)
229       (return-from %read-char
230         (sb-impl::eof-or-lose stream eof-error-p eof-value)))
231     ;; for interactive streams, finish output first to force prompt
232     (when (and (any-stream-instance-flags stream :output)
233                (any-stream-instance-flags stream :interactive))
234       (%finish-output stream))
235     (funcall-stm-handler j-read-char (sm melded-stream stream)
236                          eof-error-p eof-value blocking-p)))
237
238
239 (defun %unread-char (stream character)
240   (declare (type simple-stream stream) (ignore character))
241   (with-stream-class (simple-stream stream)
242     (%check stream :input)
243     (if (zerop (sm last-char-read-size stream))
244         (error "Nothing to unread.")
245         (progn
246           (funcall-stm-handler j-unread-char (sm melded-stream stream) nil)
247           (remove-stream-instance-flags stream :eof)
248           (setf (sm last-char-read-size stream) 0)))))
249
250
251 (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p)
252   (declare (type simple-stream stream)
253            (ignore recursive-p))
254   (with-stream-class (simple-stream stream)
255     (%check stream :input)
256     (when (any-stream-instance-flags stream :eof)
257       (return-from %peek-char
258         (sb-impl::eof-or-lose stream eof-error-p eof-value)))
259     (let* ((encap (sm melded-stream stream))
260            (char (funcall-stm-handler j-read-char encap
261                                      eof-error-p stream t)))
262       (cond ((eq char stream) eof-value)
263             ((characterp peek-type)
264              (do ((char char (funcall-stm-handler j-read-char encap
265                                                   eof-error-p
266                                                   stream t)))
267                  ((or (eq char stream) (char= char peek-type))
268                   (unless (eq char stream)
269                     (funcall-stm-handler j-unread-char encap t))
270                   (if (eq char stream) eof-value char))))
271             ((eq peek-type t)
272              (do ((char char (funcall-stm-handler j-read-char encap
273                                                   eof-error-p
274                                                   stream t)))
275                  ((or (eq char stream)
276                       (not (sb-impl::whitespace[2]p char)))
277                   (unless (eq char stream)
278                     (funcall-stm-handler j-unread-char encap t))
279                   (if (eq char stream) eof-value char))))
280             (t
281              (funcall-stm-handler j-unread-char encap t)
282              char)))))
283
284 (defun %listen (stream width)
285   (declare (type simple-stream stream))
286   ;; WIDTH is number of octets which must be available; any value
287   ;; other than 1 is treated as 'character.
288   (with-stream-class (simple-stream stream)
289     (%check stream :input)
290     (when (any-stream-instance-flags stream :eof)
291       (return-from %listen nil))
292     (if (not (or (eql width 1) (null width)))
293         (funcall-stm-handler j-listen (sm melded-stream stream))
294         (or (< (sm buffpos stream) (sm buffer-ptr stream))
295             ;; Attempt buffer refill
296             (when (and (not (any-stream-instance-flags stream :dual :string))
297                        (>= (sm mode stream) 0))
298               ;; single-channel stream dirty -> write data before reading
299               (flush-buffer stream nil))
300             (>= (refill-buffer stream nil) width)))))
301
302 (defun %clear-input (stream buffer-only)
303   (declare (type simple-stream stream))
304   (with-stream-class (simple-stream stream)
305     (%check stream :input)
306     (setf (sm buffpos stream) 0
307           (sm buffer-ptr stream) 0
308           (sm last-char-read-size stream) 0
309           #|(sm unread-past-soft-eof stream) nil|#)
310     #| (setf (sm reread-count stream) 0)  on dual-channel streams? |#
311     )
312   (device-clear-input stream buffer-only))
313
314
315 (defun %read-byte (stream eof-error-p eof-value)
316   (declare (type simple-stream stream))
317   (with-stream-class (simple-stream stream)
318     (%check stream :input)
319     (if (any-stream-instance-flags stream :eof)
320         (sb-impl::eof-or-lose stream eof-error-p eof-value)
321         (etypecase stream
322           (single-channel-simple-stream
323            (read-byte-internal stream eof-error-p eof-value t))
324           (dual-channel-simple-stream
325            (read-byte-internal stream eof-error-p eof-value t))
326           (string-simple-stream
327            (with-stream-class (string-simple-stream stream)
328              (let ((encap (sm input-handle stream)))
329                (unless encap
330                  (error 'simple-type-error
331                         :datum stream
332                         :expected-type 'stream
333                         :format-control "Can't read-byte on string streams"
334                         :format-arguments '()))
335                (prog1
336                    (read-byte encap eof-error-p eof-value)
337                  (setf (sm last-char-read-size stream) 0
338                        (sm encapsulated-char-read-size stream) 0)))))))))
339
340
341 (defun %write-char (stream character)
342   (declare (type simple-stream stream))
343   (with-stream-class (simple-stream stream)
344     (%check stream :output)
345     (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
346
347
348 (defun %fresh-line (stream)
349   (declare (type simple-stream stream))
350   (with-stream-class (simple-stream stream)
351     (%check stream :output)
352     (when (/= (or (sm charpos stream) 1) 0)
353       (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
354       t)))
355
356
357 (defun %write-string (stream string start end)
358   (declare (type simple-stream stream))
359   (with-stream-class (simple-stream stream)
360     (%check stream :output)
361     (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
362                            start end)))
363
364
365 (defun %line-length (stream)
366   (declare (type simple-stream stream))
367   (%check stream :output)
368   ;; implement me
369   nil)
370
371
372 (defun %finish-output (stream)
373   (declare (type simple-stream stream))
374   (with-stream-class (simple-stream stream)
375     (%check stream :output)
376     (when (sm handler stream)
377       (do ()
378           ((null (sm pending stream)))
379         (sb-sys:serve-all-events)))
380     (etypecase stream
381       (single-channel-simple-stream
382        ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
383        ;  (setf (device-file-position stream)
384        ;        (- (device-file-position stream) (sm buffer-ptr stream))))
385        ;(device-write stream :flush 0 nil t)
386        (flush-buffer stream t)
387        (setf (sm buffpos stream) 0))
388       (dual-channel-simple-stream
389        (with-stream-class (dual-channel-simple-stream stream)
390          (device-write stream :flush 0 nil t)
391          (setf (sm outpos stream) 0)))
392       (string-simple-stream
393            (device-write stream :flush 0 nil t))))
394   nil)
395
396
397 (defun %force-output (stream)
398   (declare (type simple-stream stream))
399   (with-stream-class (simple-stream stream)
400     (%check stream :output)
401     (etypecase stream
402       (single-channel-simple-stream
403        ;(when (> (sm buffer-ptr stream) 0)
404        ;  (setf (device-file-position stream)
405        ;        (- (device-file-position stream) (sm buffer-ptr stream))))
406        ;(device-write stream :flush 0 nil nil)
407        (flush-buffer stream nil)
408        (setf (sm buffpos stream) 0))
409       (dual-channel-simple-stream
410        (with-stream-class (dual-channel-simple-stream stream)
411          (device-write stream :flush 0 nil nil)
412          (setf (sm outpos stream) 0)))
413       (string-simple-stream
414        (device-write stream :flush 0 nil nil))))
415   nil)
416
417
418 (defun %clear-output (stream)
419   (declare (type simple-stream stream))
420   (with-stream-class (simple-stream stream)
421     (%check stream :output)
422     (when (sm handler stream)
423       (sb-sys:remove-fd-handler (sm handler stream))
424       (setf (sm handler stream) nil
425             (sm pending stream) nil))
426     (etypecase stream
427       (single-channel-simple-stream
428        (with-stream-class (single-channel-simple-stream stream)
429          (case (sm mode stream)
430            (1 (setf (sm buffpos stream) 0))
431            (3 (setf (sm mode stream) 0)))))
432       (dual-channel-simple-stream
433        (setf (sm outpos stream) 0))
434       (string-simple-stream
435        nil))
436     (device-clear-output stream)))
437
438
439 (defun %write-byte (stream integer)
440   (declare (type simple-stream stream))
441   (with-stream-class (simple-stream stream)
442     (%check stream :output)
443     (etypecase stream
444       (single-channel-simple-stream
445        (with-stream-class (single-channel-simple-stream stream)
446          (let ((ptr (sm buffpos stream)))
447           (when (>= ptr (sm buf-len stream))
448             (setf ptr (flush-buffer stream t)))
449           (setf (sm buffpos stream) (1+ ptr))
450           (setf (sm charpos stream) nil)
451           (setf (bref (sm buffer stream) ptr) integer)
452           (sc-set-dirty stream))))
453       (dual-channel-simple-stream
454        (with-stream-class (dual-channel-simple-stream stream)
455          (let ((ptr (sm outpos stream)))
456            (when (>= ptr (sm max-out-pos stream))
457              (setf ptr (flush-out-buffer stream t)))
458            (setf (sm outpos stream) (1+ ptr))
459            (setf (sm charpos stream) nil)
460            (setf (bref (sm out-buffer stream) ptr) integer))))
461       (string-simple-stream
462        (with-stream-class (string-simple-stream stream)
463          (let ((encap (sm output-handle stream)))
464            (unless encap
465              (error 'simple-type-error
466                     :datum stream
467                     :expected-type 'stream
468                     :format-control "Can't write-byte on string streams."
469                     :format-arguments '()))
470            (write-byte integer encap)))))))
471
472
473 (defun %read-sequence (stream seq start end partial-fill)
474   (declare (type simple-stream stream)
475            (type sequence seq)
476            (type sb-int:index start end)
477            (type boolean partial-fill))
478   (with-stream-class (simple-stream stream)
479     (%check stream :input)
480     (when (any-stream-instance-flags stream :eof)
481       (return-from %read-sequence 0))
482     (when (and (not (any-stream-instance-flags stream :dual :string))
483                (sc-dirty-p stream))
484       (flush-buffer stream t))
485     (etypecase seq
486       (string
487        (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
488                             start end
489                             (if partial-fill :bnb t)))
490       ((or (simple-array (unsigned-byte 8) (*))
491            (simple-array (signed-byte 8) (*)))
492        (when (any-stream-instance-flags stream :string)
493          (error "Can't read into byte sequence from a string stream."))
494        ;; "read-vector" equivalent, but blocking if partial-fill is NIL
495        ;; FIXME: this could be implemented faster via buffer-copy
496        (loop with encap = (sm melded-stream stream)
497             for index from start below end
498             for byte = (read-byte-internal encap nil nil t)
499               then (read-byte-internal encap nil nil partial-fill)
500             while byte
501             do (setf (bref seq index) byte)
502             finally (return index)))
503       ;; extend to work on other sequences: repeated read-byte
504       )))
505
506 (defun %write-sequence (stream seq start end)
507   (declare (type simple-stream stream)
508            (type sequence seq)
509            (type sb-int:index start end))
510   (with-stream-class (simple-stream stream)
511     (%check stream :output)
512     (etypecase seq
513       (string
514        (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
515                               start end))
516       ((or (simple-array (unsigned-byte 8) (*))
517            (simple-array (signed-byte 8) (*)))
518        ;; "write-vector" equivalent
519        (setf (sm charpos stream) nil)
520        (etypecase stream
521          (single-channel-simple-stream
522           (with-stream-class (single-channel-simple-stream stream)
523             (loop with max-ptr fixnum = (sm buf-len stream)
524                   for src-pos fixnum = start then (+ src-pos count)
525                   for src-rest fixnum = (- end src-pos)
526                   while (> src-rest 0) ; FIXME: this is non-ANSI
527                   for ptr fixnum = (let ((ptr (sm buffpos stream)))
528                                      (if (>= ptr max-ptr)
529                                          (flush-buffer stream t)
530                                          ptr))
531                   for buf-rest fixnum = (- max-ptr ptr)
532                   for count fixnum = (min buf-rest src-rest)
533                   do (progn (setf (sm mode stream) 1)
534                             (setf (sm buffpos stream) (+ ptr count))
535                             (buffer-copy seq src-pos (sm buffer stream) ptr count)))))
536          (dual-channel-simple-stream
537           (with-stream-class (dual-channel-simple-stream stream)
538             (loop with max-ptr fixnum = (sm max-out-pos stream)
539                   for src-pos fixnum = start then (+ src-pos count)
540                   for src-rest fixnum = (- end src-pos)
541                   while (> src-rest 0) ; FIXME: this is non-ANSI
542                   for ptr fixnum = (let ((ptr (sm outpos stream)))
543                                      (if (>= ptr max-ptr)
544                                          (flush-out-buffer stream t)
545                                          ptr))
546                   for buf-rest fixnum = (- max-ptr ptr)
547                   for count fixnum = (min buf-rest src-rest)
548                   do (progn (setf (sm outpos stream) (+ ptr count))
549                             (buffer-copy seq src-pos (sm out-buffer stream) ptr count)))))
550          (string-simple-stream
551           (error 'simple-type-error
552                  :datum stream
553                  :expected-type 'stream
554                  :format-control "Can't write a byte sequence to a string stream."
555                  :format-arguments '())))
556        )
557       ;; extend to work on other sequences: repeated write-byte
558       ))
559   seq)
560
561
562 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
563   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
564            (type stream stream))
565   ;; START and END are octet offsets, not vector indices!  [Except for strings]
566   ;; Return value is index of next octet to be read into (i.e., start+count)
567   (etypecase stream
568     (simple-stream
569      (with-stream-class (simple-stream stream)
570        (cond ((stringp vector)
571               (let* ((start (or start 0))
572                      (end (or end (length vector)))
573                      (encap (sm melded-stream stream))
574                      (char (funcall-stm-handler j-read-char encap nil nil t)))
575                 (when char
576                   (setf (schar vector start) char)
577                   (incf start)
578                   (+ start (funcall-stm-handler j-read-chars encap vector nil
579                                                 start end nil)))))
580              ((any-stream-instance-flags stream :string)
581               (error "Can't READ-BYTE on string streams."))
582              (t
583               (do* ((encap (sm melded-stream stream))
584                     (index (or start 0) (1+ index))
585                     (end (or end (* (length vector) (vector-elt-width vector))))
586                     (endian-swap (endian-swap-value vector endian-swap))
587                     (flag t nil))
588                    ((>= index end) index)
589                 (let ((byte (read-byte-internal encap nil nil flag)))
590                   (unless byte
591                     (return index))
592                   (setf (bref vector (logxor index endian-swap)) byte)))))))
593     ((or ansi-stream fundamental-stream)
594      (unless (typep vector '(or string
595                              (simple-array (signed-byte 8) (*))
596                              (simple-array (unsigned-byte 8) (*))))
597        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
598      (read-sequence vector stream :start (or start 0) :end end))))
599
600
601 ;;;
602 ;;; USER-LEVEL FUNCTIONS
603 ;;;
604
605 (defmethod open-stream-p ((stream simple-stream))
606   (any-stream-instance-flags stream :input :output))
607
608 (defmethod input-stream-p ((stream simple-stream))
609   (any-stream-instance-flags stream :input))
610
611 (defmethod output-stream-p ((stream simple-stream))
612   (any-stream-instance-flags stream :output))
613
614 (defmethod stream-element-type ((stream simple-stream))
615   '(unsigned-byte 8))
616
617 (defun interactive-stream-p (stream)
618   "Return true if Stream does I/O on a terminal or other interactive device."
619   (etypecase stream
620     (simple-stream
621      (%check stream :open)
622      (any-stream-instance-flags stream :interactive))
623     (ansi-stream
624      (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
625     (fundamental-stream
626      nil)))
627
628 (defun (setf interactive-stream-p) (flag stream)
629   (typecase stream
630     (simple-stream
631      (%check stream :open)
632      (if flag
633          (add-stream-instance-flags stream :interactive)
634          (remove-stream-instance-flags stream :interactive)))
635     (t
636      (error 'simple-type-error
637             :datum stream
638             :expected-type 'simple-stream
639             :format-control "Can't set interactive flag on ~S."
640             :format-arguments (list stream)))))
641
642 (defun file-string-length (stream object)
643   (declare (type (or string character) object) (type stream stream))
644   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
645    OBJECT to STREAM. Non-trivial only in implementations that support
646    international character sets."
647   (typecase stream
648     (simple-stream (%file-string-length stream object))
649     (t
650      (etypecase object
651        (character 1)
652        (string (length object))))))
653
654 (defun stream-external-format (stream)
655   "Returns Stream's external-format."
656   (etypecase stream
657     (simple-stream
658      (with-stream-class (simple-stream)
659        (%check stream :open)
660        (sm external-format stream)))
661     (ansi-stream
662      :default)
663     (fundamental-stream
664      :default)))
665
666 (defun open (filename &rest options
667              &key (direction :input)
668              (element-type 'character element-type-given)
669              if-exists if-does-not-exist
670              (external-format :default)
671              class mapped input-handle output-handle
672              &allow-other-keys)
673   "Return a stream which reads from or writes to Filename.
674   Defined keywords:
675    :direction - one of :input, :output, :io, or :probe
676    :element-type - type of object to read or write, default BASE-CHAR
677    :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
678                        :overwrite, :append, :supersede or NIL
679    :if-does-not-exist - one of :error, :create or NIL
680    :external-format - :default
681   See the manual for details.
682
683   The following are simple-streams-specific additions:
684    :class - class of stream object to be created
685    :mapped - T to open a memory-mapped file
686    :input-handle - a stream or Unix file descriptor to read from
687    :output-handle - a stream or Unix file descriptor to write to"
688   (declare (ignore element-type external-format input-handle output-handle
689                    if-exists if-does-not-exist))
690   (let ((class (or class 'sb-sys:fd-stream))
691         (options (copy-list options))
692         (filespec (merge-pathnames filename)))
693     (cond ((eq class 'sb-sys:fd-stream)
694            (remf options :class)
695            (remf options :mapped)
696            (remf options :input-handle)
697            (remf options :output-handle)
698            (apply #'open-fd-stream filespec options))
699           ((subtypep class 'simple-stream)
700            (when element-type-given
701              (cerror "Do it anyway."
702                      "Can't create simple-streams with an element-type."))
703            (when (and (eq class 'file-simple-stream) mapped)
704              (setq class 'mapped-file-simple-stream)
705              (setf (getf options :class) 'mapped-file-simple-stream))
706            (when (subtypep class 'file-simple-stream)
707              (when (eq direction :probe)
708                (setq class 'probe-simple-stream)))
709            (apply #'make-instance class :filename filespec options))
710           ((subtypep class 'sb-gray:fundamental-stream)
711            (remf options :class)
712            (remf options :mapped)
713            (remf options :input-handle)
714            (remf options :output-handle)
715            (make-instance class :lisp-stream
716                           (apply #'open-fd-stream filespec options)))
717           (t (error "Don't know how to handle the stream class ~A"
718                     (etypecase class
719                       (symbol (find-class class t))
720                       (class class)))))))
721
722
723 (declaim (inline read-byte read-char read-char-no-hang unread-char))
724
725 (defun read-byte (stream &optional (eof-error-p t) eof-value)
726   "Returns the next byte of the Stream."
727   (let ((stream (sb-impl::in-synonym-of stream)))
728     (etypecase stream
729       (simple-stream
730        (%read-byte stream eof-error-p eof-value))
731       (ansi-stream
732        (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil))
733       (fundamental-stream
734        (let ((char (sb-gray:stream-read-byte stream)))
735          (if (eq char :eof)
736              (sb-impl::eof-or-lose stream eof-error-p eof-value)
737              char))))))
738
739 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
740                             eof-value recursive-p)
741   "Inputs a character from Stream and returns it."
742   (let ((stream (sb-impl::in-synonym-of stream)))
743     (etypecase stream
744       (simple-stream
745        (%read-char stream eof-error-p eof-value recursive-p t))
746       (ansi-stream
747        (sb-impl::ansi-stream-read-char stream eof-error-p eof-value
748                                        recursive-p))
749       (fundamental-stream
750        (let ((char (sb-gray:stream-read-char stream)))
751          (if (eq char :eof)
752              (sb-impl::eof-or-lose stream eof-error-p eof-value)
753              char))))))
754
755 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
756                                     eof-value recursive-p)
757   "Returns the next character from the Stream if one is availible, or nil."
758   (let ((stream (sb-impl::in-synonym-of stream)))
759     (etypecase stream
760       (simple-stream
761        (%check stream :input)
762        (with-stream-class (simple-stream)
763          (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
764       (ansi-stream
765        (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value
766                                                recursive-p))
767       (fundamental-stream
768        (let ((char (sb-gray:stream-read-char-no-hang stream)))
769          (if (eq char :eof)
770              (sb-impl::eof-or-lose stream eof-error-p eof-value)
771              char))))))
772
773 (defun unread-char (character &optional (stream *standard-input*))
774   "Puts the Character back on the front of the input Stream."
775   (let ((stream (sb-impl::in-synonym-of stream)))
776     (etypecase stream
777       (simple-stream
778        (%unread-char stream character))
779       (ansi-stream
780        (sb-impl::ansi-stream-unread-char character stream))
781       (fundamental-stream
782        (sb-gray:stream-unread-char stream character))))
783   nil)
784
785 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
786
787 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
788                             (eof-error-p t) eof-value recursive-p)
789   "Peeks at the next character in the input Stream.  See manual for details."
790   (let ((stream (sb-impl::in-synonym-of stream)))
791     (etypecase stream
792       (simple-stream
793        (%peek-char stream peek-type eof-error-p eof-value recursive-p))
794       ;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) --
795       ;; CSR, 2004-01-19
796       (ansi-stream
797        (sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value
798                                        recursive-p))
799       (fundamental-stream
800        (cond ((characterp peek-type)
801               (do ((char (sb-gray:stream-read-char stream)
802                          (sb-gray:stream-read-char stream)))
803                   ((or (eq char :eof) (char= char peek-type))
804                    (cond ((eq char :eof)
805                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
806                          (t
807                           (sb-gray:stream-unread-char stream char)
808                           char)))))
809              ((eq peek-type t)
810               (do ((char (sb-gray:stream-read-char stream)
811                          (sb-gray:stream-read-char stream)))
812                   ((or (eq char :eof) (not (sb-impl::whitespace[2]p char)))
813                    (cond ((eq char :eof)
814                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
815                          (t
816                           (sb-gray:stream-unread-char stream char)
817                           char)))))
818              (t
819               (let ((char (sb-gray:stream-peek-char stream)))
820                 (if (eq char :eof)
821                     (sb-impl::eof-or-lose stream eof-error-p eof-value)
822                     char))))))))
823
824 (defun listen (&optional (stream *standard-input*) (width 1))
825   "Returns T if WIDTH octets are available on STREAM.  If WIDTH is
826 given as 'CHARACTER, check for a character.  Note: the WIDTH argument
827 is supported only on simple-streams."
828   ;; WIDTH is number of octets which must be available; any value
829   ;; other than 1 is treated as 'character.
830   (let ((stream (sb-impl::in-synonym-of stream)))
831     (etypecase stream
832       (simple-stream
833        (%listen stream width))
834       (ansi-stream
835        (sb-impl::ansi-stream-listen stream))
836       (fundamental-stream
837        (sb-gray:stream-listen stream)))))
838
839
840 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
841                             eof-value recursive-p)
842   "Returns a line of text read from the Stream as a string, discarding the
843   newline character."
844   (let ((stream (sb-impl::in-synonym-of stream)))
845     (etypecase stream
846       (simple-stream
847        (%read-line stream eof-error-p eof-value recursive-p))
848       (ansi-stream
849        (sb-impl::ansi-stream-read-line stream eof-error-p eof-value
850                                        recursive-p))
851       (fundamental-stream
852        (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
853          (if (and eof (zerop (length string)))
854              (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
855              (values string eof)))))))
856
857 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
858   "Destructively modify SEQ by reading elements from STREAM.
859   SEQ is bounded by START and END. SEQ is destructively modified by
860   copying successive elements into it from STREAM. If the end of file
861   for STREAM is reached before copying all elements of the subsequence,
862   then the extra elements near the end of sequence are not updated, and
863   the index of the next element is returned."
864   (let ((stream (sb-impl::in-synonym-of stream))
865         (end (or end (length seq))))
866     (etypecase stream
867       (simple-stream
868        (with-stream-class (simple-stream stream)
869          (%read-sequence stream seq start end partial-fill)))
870       (ansi-stream
871        (sb-impl::ansi-stream-read-sequence seq stream start end))
872       (fundamental-stream
873        (sb-gray:stream-read-sequence stream seq start end)))))
874
875 (defun clear-input (&optional (stream *standard-input*) buffer-only)
876   "Clears any buffered input associated with the Stream."
877   (let ((stream (sb-impl::in-synonym-of stream)))
878     (etypecase stream
879       (simple-stream
880        (%clear-input stream buffer-only))
881       (ansi-stream
882        (sb-impl::ansi-stream-clear-input stream))
883       (fundamental-stream
884        (sb-gray:stream-clear-input stream))))
885   nil)
886
887 (defun write-byte (integer stream)
888   "Outputs an octet to the Stream."
889   (let ((stream (sb-impl::out-synonym-of stream)))
890     (etypecase stream
891       (simple-stream
892        (%write-byte stream integer))
893       (ansi-stream
894        (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
895       (fundamental-stream
896        (sb-gray:stream-write-byte stream integer))))
897   integer)
898
899 (defun write-char (character &optional (stream *standard-output*))
900   "Outputs the Character to the Stream."
901   (let ((stream (sb-impl::out-synonym-of stream)))
902     (etypecase stream
903       (simple-stream
904        (%write-char stream character))
905       (ansi-stream
906        (funcall (sb-kernel:ansi-stream-out stream) stream character))
907       (fundamental-stream
908        (sb-gray:stream-write-char stream character))))
909   character)
910
911 (defun write-string (string &optional (stream *standard-output*)
912                             &key (start 0) (end nil))
913   "Outputs the String to the given Stream."
914   (let ((stream (sb-impl::out-synonym-of stream))
915         (end (sb-impl::%check-vector-sequence-bounds string start end)))
916     (etypecase stream
917       (simple-stream
918        (%write-string stream string start end)
919        string)
920       (ansi-stream
921        (sb-impl::ansi-stream-write-string string stream start end))
922       (fundamental-stream
923        (sb-gray:stream-write-string stream string start end)))))
924
925 (defun write-line (string &optional (stream *standard-output*)
926                           &key (start 0) end)
927   (declare (type string string))
928   (let ((stream (sb-impl::out-synonym-of stream))
929         (end (sb-impl::%check-vector-sequence-bounds string start end)))
930     (etypecase stream
931       (simple-stream
932        (%check stream :output)
933        (with-stream-class (simple-stream stream)
934          (funcall-stm-handler-2 j-write-chars string stream start end)
935          (funcall-stm-handler-2 j-write-char #\Newline stream)))
936       (ansi-stream
937        (sb-impl::ansi-stream-write-string string stream start end)
938        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
939       (fundamental-stream
940        (sb-gray:stream-write-string stream string start end)
941        (sb-gray:stream-terpri stream))))
942   string)
943
944 (defun write-sequence (seq stream &key (start 0) (end nil))
945   "Write the elements of SEQ bounded by START and END to STREAM."
946   (let ((stream (sb-impl::out-synonym-of stream))
947         (end (or end (length seq))))
948     (etypecase stream
949       (simple-stream
950        (%write-sequence stream seq start end))
951       (ansi-stream
952        (sb-impl::ansi-stream-write-sequence seq stream start end))
953       (fundamental-stream
954        (sb-gray:stream-write-sequence stream seq start end)))))
955
956 (defun terpri (&optional (stream *standard-output*))
957   "Outputs a new line to the Stream."
958   (let ((stream (sb-impl::out-synonym-of stream)))
959     (etypecase stream
960       (simple-stream
961        (%check stream :output)
962        (with-stream-class (simple-stream stream)
963          (funcall-stm-handler-2 j-write-char #\Newline stream)))
964       (ansi-stream
965        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
966       (fundamental-stream
967        (sb-gray:stream-terpri stream))))
968   nil)
969
970 (defun fresh-line (&optional (stream *standard-output*))
971   "Outputs a new line to the Stream if it is not positioned at the beginning of
972    a line.  Returns T if it output a new line, nil otherwise."
973   (let ((stream (sb-impl::out-synonym-of stream)))
974     (etypecase stream
975       (simple-stream
976        (%fresh-line stream))
977       (ansi-stream
978        (sb-impl::ansi-stream-fresh-line stream))
979       (fundamental-stream
980        (sb-gray:stream-fresh-line stream)))))
981
982 (defun finish-output (&optional (stream *standard-output*))
983   "Attempts to ensure that all output sent to the Stream has reached its
984    destination, and only then returns."
985   (let ((stream (sb-impl::out-synonym-of stream)))
986     (etypecase stream
987       (simple-stream
988        (%finish-output stream))
989       (ansi-stream
990        (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
991       (fundamental-stream
992        (sb-gray:stream-finish-output stream))))
993   nil)
994
995 (defun force-output (&optional (stream *standard-output*))
996   "Attempts to force any buffered output to be sent."
997   (let ((stream (sb-impl::out-synonym-of stream)))
998     (etypecase stream
999       (simple-stream
1000        (%force-output stream))
1001       (ansi-stream
1002        (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
1003       (fundamental-stream
1004        (sb-gray:stream-force-output stream))))
1005   nil)
1006
1007 (defun clear-output (&optional (stream *standard-output*))
1008   "Clears the given output Stream."
1009   (let ((stream (sb-impl::out-synonym-of stream)))
1010     (etypecase stream
1011       (simple-stream
1012        (%clear-output stream))
1013       (ansi-stream
1014        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
1015       (fundamental-stream
1016        (sb-gray:stream-clear-output stream))))
1017   nil)
1018
1019
1020 (defun file-position (stream &optional position)
1021   "With one argument returns the current position within the file
1022    File-Stream is open to.  If the second argument is supplied, then
1023    this becomes the new file position.  The second argument may also
1024    be :start or :end for the start and end of the file, respectively."
1025   (declare (type (or sb-int:index (member nil :start :end)) position))
1026   (etypecase stream
1027     (simple-stream
1028      (%file-position stream position))
1029     (ansi-stream
1030      (sb-impl::ansi-stream-file-position stream position))))
1031
1032 (defun file-length (stream)
1033   "This function returns the length of the file that File-Stream is open to."
1034   (etypecase stream
1035     (simple-stream
1036      (%file-length stream))
1037     (ansi-stream
1038      (sb-impl::stream-must-be-associated-with-file stream)
1039      (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))
1040
1041 (defun charpos (&optional (stream *standard-output*))
1042   "Returns the number of characters on the current line of output of the given
1043   Stream, or Nil if that information is not availible."
1044   (let ((stream (sb-impl::out-synonym-of stream)))
1045     (etypecase stream
1046       (simple-stream
1047        (with-stream-class (simple-stream stream)
1048          (%check stream :open)
1049          (sm charpos stream)))
1050       (ansi-stream
1051        (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
1052       (fundamental-stream
1053        (sb-gray:stream-line-column stream)))))
1054
1055 (defun line-length (&optional (stream *standard-output*))
1056   "Returns the number of characters in a line of output of the given
1057   Stream, or Nil if that information is not availible."
1058   (let ((stream (sb-impl::out-synonym-of stream)))
1059     (etypecase stream
1060       (simple-stream
1061        (%check stream :output)
1062        ;; TODO (sat 2003-04-02): a way to specify a line length would
1063        ;; be good, I suppose.  Returning nil here means
1064        ;; sb-pretty::default-line-length is used.
1065        nil)
1066       (ansi-stream
1067        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
1068       (fundamental-stream
1069        (sb-gray:stream-line-length stream)))))
1070
1071 (defun wait-for-input-available (stream &optional timeout)
1072   "Waits for input to become available on the Stream and returns T.  If
1073   Timeout expires, Nil is returned."
1074   (let ((stream (sb-impl::in-synonym-of stream)))
1075     (etypecase stream
1076       (fixnum
1077        (sb-sys:wait-until-fd-usable stream :input timeout))
1078       (simple-stream
1079        (%check stream :input)
1080        (with-stream-class (simple-stream stream)
1081          (or (< (sm buffpos stream) (sm buffer-ptr stream))
1082              (wait-for-input-available (sm input-handle stream) timeout))))
1083       (two-way-stream
1084        (wait-for-input-available (two-way-stream-input-stream stream) timeout))
1085       (synonym-stream
1086        (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
1087                                  timeout))
1088       (sb-sys:fd-stream
1089        (or (< (sb-impl::fd-stream-in-index stream)
1090               (length (sb-impl::fd-stream-in-buffer stream)))
1091            (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
1092
1093 ;; Make PATHNAME and NAMESTRING work
1094 (defun sb-int:file-name (stream &optional new-name)
1095   (typecase stream
1096     (file-simple-stream
1097      (with-stream-class (file-simple-stream stream)
1098        (cond (new-name
1099               (%file-rename stream new-name))
1100              (t
1101               (%file-name stream)))))
1102     (sb-sys:fd-stream
1103      (cond (new-name
1104             (setf (sb-impl::fd-stream-pathname stream) new-name)
1105             (setf (sb-impl::fd-stream-file stream)
1106                   (file-namestring new-name))
1107             t)
1108            (t
1109             (sb-impl::fd-stream-pathname stream))))))