1.0.10.19: Check also for MIPS foreign_function_call lossage
[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) (sb-int:unix-namestring new-name nil))
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             (let ((lcrs (sm last-char-read-size stream)))
297               (when (and (not (any-stream-instance-flags stream :dual :string))
298                          (>= (sm mode stream) 0))
299                 ;; single-channel stream dirty -> write data before reading
300                 (flush-buffer stream nil))
301               (>= (refill-buffer stream nil) width))))))
302
303 (defun %clear-input (stream buffer-only)
304   (declare (type simple-stream stream))
305   (with-stream-class (simple-stream stream)
306     (%check stream :input)
307     (setf (sm buffpos stream) 0
308           (sm buffer-ptr stream) 0
309           (sm last-char-read-size stream) 0
310           #|(sm unread-past-soft-eof stream) nil|#)
311     #| (setf (sm reread-count stream) 0)  on dual-channel streams? |#
312     )
313   (device-clear-input stream buffer-only))
314
315
316 (defun %read-byte (stream eof-error-p eof-value)
317   (declare (type simple-stream stream))
318   (with-stream-class (simple-stream stream)
319     (%check stream :input)
320     (if (any-stream-instance-flags stream :eof)
321         (sb-impl::eof-or-lose stream eof-error-p eof-value)
322         (etypecase stream
323           (single-channel-simple-stream
324            (read-byte-internal stream eof-error-p eof-value t))
325           (dual-channel-simple-stream
326            (read-byte-internal stream eof-error-p eof-value t))
327           (string-simple-stream
328            (with-stream-class (string-simple-stream stream)
329              (let ((encap (sm input-handle stream)))
330                (unless encap
331                  (error 'simple-type-error
332                         :datum stream
333                         :expected-type 'stream
334                         :format-control "Can't read-byte on string streams"
335                         :format-arguments '()))
336                (prog1
337                    (read-byte encap eof-error-p eof-value)
338                  (setf (sm last-char-read-size stream) 0
339                        (sm encapsulated-char-read-size stream) 0)))))))))
340
341
342 (defun %write-char (stream character)
343   (declare (type simple-stream stream))
344   (with-stream-class (simple-stream stream)
345     (%check stream :output)
346     (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
347
348
349 (defun %fresh-line (stream)
350   (declare (type simple-stream stream))
351   (with-stream-class (simple-stream stream)
352     (%check stream :output)
353     (when (/= (or (sm charpos stream) 1) 0)
354       (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
355       t)))
356
357
358 (defun %write-string (stream string start end)
359   (declare (type simple-stream stream))
360   (with-stream-class (simple-stream stream)
361     (%check stream :output)
362     (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
363                            start end)))
364
365
366 (defun %line-length (stream)
367   (declare (type simple-stream stream))
368   (%check stream :output)
369   ;; implement me
370   nil)
371
372
373 (defun %finish-output (stream)
374   (declare (type simple-stream stream))
375   (with-stream-class (simple-stream stream)
376     (%check stream :output)
377     (when (sm handler stream)
378       (do ()
379           ((null (sm pending stream)))
380         (sb-sys:serve-all-events)))
381     (etypecase stream
382       (single-channel-simple-stream
383        ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
384        ;  (setf (device-file-position stream)
385        ;        (- (device-file-position stream) (sm buffer-ptr stream))))
386        ;(device-write stream :flush 0 nil t)
387        (flush-buffer stream t)
388        (setf (sm buffpos stream) 0))
389       (dual-channel-simple-stream
390        (with-stream-class (dual-channel-simple-stream stream)
391          (device-write stream :flush 0 nil t)
392          (setf (sm outpos stream) 0)))
393       (string-simple-stream
394            (device-write stream :flush 0 nil t))))
395   nil)
396
397
398 (defun %force-output (stream)
399   (declare (type simple-stream stream))
400   (with-stream-class (simple-stream stream)
401     (%check stream :output)
402     (etypecase stream
403       (single-channel-simple-stream
404        ;(when (> (sm buffer-ptr stream) 0)
405        ;  (setf (device-file-position stream)
406        ;        (- (device-file-position stream) (sm buffer-ptr stream))))
407        ;(device-write stream :flush 0 nil nil)
408        (flush-buffer stream nil)
409        (setf (sm buffpos stream) 0))
410       (dual-channel-simple-stream
411        (with-stream-class (dual-channel-simple-stream stream)
412          (device-write stream :flush 0 nil nil)
413          (setf (sm outpos stream) 0)))
414       (string-simple-stream
415        (device-write stream :flush 0 nil nil))))
416   nil)
417
418
419 (defun %clear-output (stream)
420   (declare (type simple-stream stream))
421   (with-stream-class (simple-stream stream)
422     (%check stream :output)
423     (when (sm handler stream)
424       (sb-sys:remove-fd-handler (sm handler stream))
425       (setf (sm handler stream) nil
426             (sm pending stream) nil))
427     (etypecase stream
428       (single-channel-simple-stream
429        (with-stream-class (single-channel-simple-stream stream)
430          (case (sm mode stream)
431            (1 (setf (sm buffpos stream) 0))
432            (3 (setf (sm mode stream) 0)))))
433       (dual-channel-simple-stream
434        (setf (sm outpos stream) 0))
435       (string-simple-stream
436        nil))
437     (device-clear-output stream)))
438
439
440 (defun %write-byte (stream integer)
441   (declare (type simple-stream stream))
442   (with-stream-class (simple-stream stream)
443     (%check stream :output)
444     (etypecase stream
445       (single-channel-simple-stream
446        (with-stream-class (single-channel-simple-stream stream)
447          (let ((ptr (sm buffpos stream)))
448           (when (>= ptr (sm buf-len stream))
449             (setf ptr (flush-buffer stream t)))
450           (setf (sm buffpos stream) (1+ ptr))
451           (setf (sm charpos stream) nil)
452           (setf (bref (sm buffer stream) ptr) integer)
453           (sc-set-dirty stream))))
454       (dual-channel-simple-stream
455        (with-stream-class (dual-channel-simple-stream stream)
456          (let ((ptr (sm outpos stream)))
457            (when (>= ptr (sm max-out-pos stream))
458              (setf ptr (flush-out-buffer stream t)))
459            (setf (sm outpos stream) (1+ ptr))
460            (setf (sm charpos stream) nil)
461            (setf (bref (sm out-buffer stream) ptr) integer))))
462       (string-simple-stream
463        (with-stream-class (string-simple-stream stream)
464          (let ((encap (sm output-handle stream)))
465            (unless encap
466              (error 'simple-type-error
467                     :datum stream
468                     :expected-type 'stream
469                     :format-control "Can't write-byte on string streams."
470                     :format-arguments '()))
471            (write-byte integer encap)))))))
472
473
474 (defun %read-sequence (stream seq start end partial-fill)
475   (declare (type simple-stream stream)
476            (type sequence seq)
477            (type sb-int:index start end)
478            (type boolean partial-fill))
479   (with-stream-class (simple-stream stream)
480     (%check stream :input)
481     (when (any-stream-instance-flags stream :eof)
482       (return-from %read-sequence 0))
483     (when (and (not (any-stream-instance-flags stream :dual :string))
484                (sc-dirty-p stream))
485       (flush-buffer stream t))
486     (etypecase seq
487       (string
488        (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
489                             start end
490                             (if partial-fill :bnb t)))
491       ((or (simple-array (unsigned-byte 8) (*))
492            (simple-array (signed-byte 8) (*)))
493        (when (any-stream-instance-flags stream :string)
494          (error "Can't read into byte sequence from a string stream."))
495        ;; "read-vector" equivalent, but blocking if partial-fill is NIL
496        ;; FIXME: this could be implemented faster via buffer-copy
497        (loop with encap = (sm melded-stream stream)
498             for index from start below end
499             for byte = (read-byte-internal encap nil nil t)
500               then (read-byte-internal encap nil nil partial-fill)
501             while byte
502             do (setf (bref seq index) byte)
503             finally (return index)))
504       ;; extend to work on other sequences: repeated read-byte
505       )))
506
507 (defun %write-sequence (stream seq start end)
508   (declare (type simple-stream stream)
509            (type sequence seq)
510            (type sb-int:index start end))
511   (with-stream-class (simple-stream stream)
512     (%check stream :output)
513     (etypecase seq
514       (string
515        (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
516                               start end))
517       ((or (simple-array (unsigned-byte 8) (*))
518            (simple-array (signed-byte 8) (*)))
519        ;; "write-vector" equivalent
520        (setf (sm charpos stream) nil)
521        (etypecase stream
522          (single-channel-simple-stream
523           (with-stream-class (single-channel-simple-stream stream)
524             (loop with max-ptr fixnum = (sm buf-len stream)
525                   for src-pos fixnum = start then (+ src-pos count)
526                   for src-rest fixnum = (- end src-pos)
527                   while (> src-rest 0) ; FIXME: this is non-ANSI
528                   for ptr fixnum = (let ((ptr (sm buffpos stream)))
529                                      (if (>= ptr max-ptr)
530                                          (flush-buffer stream t)
531                                          ptr))
532                   for buf-rest fixnum = (- max-ptr ptr)
533                   for count fixnum = (min buf-rest src-rest)
534                   do (progn (setf (sm mode stream) 1)
535                             (setf (sm buffpos stream) (+ ptr count))
536                             (buffer-copy seq src-pos (sm buffer stream) ptr count)))))
537          (dual-channel-simple-stream
538           (with-stream-class (dual-channel-simple-stream stream)
539             (loop with max-ptr fixnum = (sm max-out-pos stream)
540                   for src-pos fixnum = start then (+ src-pos count)
541                   for src-rest fixnum = (- end src-pos)
542                   while (> src-rest 0) ; FIXME: this is non-ANSI
543                   for ptr fixnum = (let ((ptr (sm outpos stream)))
544                                      (if (>= ptr max-ptr)
545                                          (flush-out-buffer stream t)
546                                          ptr))
547                   for buf-rest fixnum = (- max-ptr ptr)
548                   for count fixnum = (min buf-rest src-rest)
549                   do (progn (setf (sm outpos stream) (+ ptr count))
550                             (buffer-copy seq src-pos (sm out-buffer stream) ptr count)))))
551          (string-simple-stream
552           (error 'simple-type-error
553                  :datum stream
554                  :expected-type 'stream
555                  :format-control "Can't write a byte sequence to a string stream."
556                  :format-arguments '())))
557        )
558       ;; extend to work on other sequences: repeated write-byte
559       ))
560   seq)
561
562
563 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
564   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
565            (type stream stream))
566   ;; START and END are octet offsets, not vector indices!  [Except for strings]
567   ;; Return value is index of next octet to be read into (i.e., start+count)
568   (etypecase stream
569     (simple-stream
570      (with-stream-class (simple-stream stream)
571        (cond ((stringp vector)
572               (let* ((start (or start 0))
573                      (end (or end (length vector)))
574                      (encap (sm melded-stream stream))
575                      (char (funcall-stm-handler j-read-char encap nil nil t)))
576                 (when char
577                   (setf (schar vector start) char)
578                   (incf start)
579                   (+ start (funcall-stm-handler j-read-chars encap vector nil
580                                                 start end nil)))))
581              ((any-stream-instance-flags stream :string)
582               (error "Can't READ-BYTE on string streams."))
583              (t
584               (do* ((encap (sm melded-stream stream))
585                     (index (or start 0) (1+ index))
586                     (end (or end (* (length vector) (vector-elt-width vector))))
587                     (endian-swap (endian-swap-value vector endian-swap))
588                     (byte (read-byte-internal encap nil nil t)
589                           (read-byte-internal encap nil nil nil)))
590                    ((or (null byte) (>= index end)) index)
591                 (setf (bref vector (logxor index endian-swap)) byte))))))
592     ((or ansi-stream fundamental-stream)
593      (unless (typep vector '(or string
594                              (simple-array (signed-byte 8) (*))
595                              (simple-array (unsigned-byte 8) (*))))
596        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
597      (read-sequence vector stream :start (or start 0) :end end))))
598
599
600 ;;;
601 ;;; USER-LEVEL FUNCTIONS
602 ;;;
603
604 (defmethod open-stream-p ((stream simple-stream))
605   (any-stream-instance-flags stream :input :output))
606
607 (defmethod input-stream-p ((stream simple-stream))
608   (any-stream-instance-flags stream :input))
609
610 (defmethod output-stream-p ((stream simple-stream))
611   (any-stream-instance-flags stream :output))
612
613 (defmethod stream-element-type ((stream simple-stream))
614   '(unsigned-byte 8))
615
616 (defun interactive-stream-p (stream)
617   "Return true if Stream does I/O on a terminal or other interactive device."
618   (etypecase stream
619     (simple-stream
620      (%check stream :open)
621      (any-stream-instance-flags stream :interactive))
622     (ansi-stream
623      (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
624     (fundamental-stream
625      nil)))
626
627 (defun (setf interactive-stream-p) (flag stream)
628   (typecase stream
629     (simple-stream
630      (%check stream :open)
631      (if flag
632          (add-stream-instance-flags stream :interactive)
633          (remove-stream-instance-flags stream :interactive)))
634     (t
635      (error 'simple-type-error
636             :datum stream
637             :expected-type 'simple-stream
638             :format-control "Can't set interactive flag on ~S."
639             :format-arguments (list stream)))))
640
641 (defun file-string-length (stream object)
642   (declare (type (or string character) object) (type stream stream))
643   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
644    OBJECT to STREAM. Non-trivial only in implementations that support
645    international character sets."
646   (typecase stream
647     (simple-stream (%file-string-length stream object))
648     (t
649      (etypecase object
650        (character 1)
651        (string (length object))))))
652
653 (defun stream-external-format (stream)
654   "Returns Stream's external-format."
655   (etypecase stream
656     (simple-stream
657      (with-stream-class (simple-stream)
658        (%check stream :open)
659        (sm external-format stream)))
660     (ansi-stream
661      :default)
662     (fundamental-stream
663      :default)))
664
665 (defun open (filename &rest options
666              &key (direction :input)
667              (element-type 'character element-type-given)
668              if-exists if-does-not-exist
669              (external-format :default)
670              class mapped input-handle output-handle
671              &allow-other-keys)
672   "Return a stream which reads from or writes to Filename.
673   Defined keywords:
674    :direction - one of :input, :output, :io, or :probe
675    :element-type - type of object to read or write, default BASE-CHAR
676    :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
677                        :overwrite, :append, :supersede or NIL
678    :if-does-not-exist - one of :error, :create or NIL
679    :external-format - :default
680   See the manual for details.
681
682   The following are simple-streams-specific additions:
683    :class - class of stream object to be created
684    :mapped - T to open a memory-mapped file
685    :input-handle - a stream or Unix file descriptor to read from
686    :output-handle - a stream or Unix file descriptor to write to"
687   (declare (ignore element-type external-format input-handle output-handle
688                    if-exists if-does-not-exist))
689   (let ((class (or class 'sb-sys:fd-stream))
690         (options (copy-list options))
691         (filespec (merge-pathnames filename)))
692     (cond ((eq class 'sb-sys:fd-stream)
693            (remf options :class)
694            (remf options :mapped)
695            (remf options :input-handle)
696            (remf options :output-handle)
697            (apply #'open-fd-stream filespec options))
698           ((subtypep class 'simple-stream)
699            (when element-type-given
700              (cerror "Do it anyway."
701                      "Can't create simple-streams with an element-type."))
702            (when (and (eq class 'file-simple-stream) mapped)
703              (setq class 'mapped-file-simple-stream)
704              (setf (getf options :class) 'mapped-file-simple-stream))
705            (when (subtypep class 'file-simple-stream)
706              (when (eq direction :probe)
707                (setq class 'probe-simple-stream)))
708            (apply #'make-instance class :filename filespec options))
709           ((subtypep class 'sb-gray:fundamental-stream)
710            (remf options :class)
711            (remf options :mapped)
712            (remf options :input-handle)
713            (remf options :output-handle)
714            (make-instance class :lisp-stream
715                           (apply #'open-fd-stream filespec options))))))
716
717
718 (declaim (inline read-byte read-char read-char-no-hang unread-char))
719
720 (defun read-byte (stream &optional (eof-error-p t) eof-value)
721   "Returns the next byte of the Stream."
722   (let ((stream (sb-impl::in-synonym-of stream)))
723     (etypecase stream
724       (simple-stream
725        (%read-byte stream eof-error-p eof-value))
726       (ansi-stream
727        (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil))
728       (fundamental-stream
729        (let ((char (sb-gray:stream-read-byte stream)))
730          (if (eq char :eof)
731              (sb-impl::eof-or-lose stream eof-error-p eof-value)
732              char))))))
733
734 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
735                             eof-value recursive-p)
736   "Inputs a character from Stream and returns it."
737   (let ((stream (sb-impl::in-synonym-of stream)))
738     (etypecase stream
739       (simple-stream
740        (%read-char stream eof-error-p eof-value recursive-p t))
741       (ansi-stream
742        (sb-impl::ansi-stream-read-char stream eof-error-p eof-value
743                                        recursive-p))
744       (fundamental-stream
745        (let ((char (sb-gray:stream-read-char stream)))
746          (if (eq char :eof)
747              (sb-impl::eof-or-lose stream eof-error-p eof-value)
748              char))))))
749
750 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
751                                     eof-value recursive-p)
752   "Returns the next character from the Stream if one is availible, or nil."
753   (declare (ignore recursive-p))
754   (let ((stream (sb-impl::in-synonym-of stream)))
755     (etypecase stream
756       (simple-stream
757        (%check stream :input)
758        (with-stream-class (simple-stream)
759          (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
760       (ansi-stream
761        (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value
762                                                recursive-p))
763       (fundamental-stream
764        (let ((char (sb-gray:stream-read-char-no-hang stream)))
765          (if (eq char :eof)
766              (sb-impl::eof-or-lose stream eof-error-p eof-value)
767              char))))))
768
769 (defun unread-char (character &optional (stream *standard-input*))
770   "Puts the Character back on the front of the input Stream."
771   (let ((stream (sb-impl::in-synonym-of stream)))
772     (etypecase stream
773       (simple-stream
774        (%unread-char stream character))
775       (ansi-stream
776        (sb-impl::ansi-stream-unread-char character stream))
777       (fundamental-stream
778        (sb-gray:stream-unread-char stream character))))
779   nil)
780
781 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
782
783 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
784                             (eof-error-p t) eof-value recursive-p)
785   "Peeks at the next character in the input Stream.  See manual for details."
786   (let ((stream (sb-impl::in-synonym-of stream)))
787     (etypecase stream
788       (simple-stream
789        (%peek-char stream peek-type eof-error-p eof-value recursive-p))
790       ;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) --
791       ;; CSR, 2004-01-19
792       (ansi-stream
793        (sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value
794                                        recursive-p))
795       (fundamental-stream
796        (cond ((characterp peek-type)
797               (do ((char (sb-gray:stream-read-char stream)
798                          (sb-gray:stream-read-char stream)))
799                   ((or (eq char :eof) (char= char peek-type))
800                    (cond ((eq char :eof)
801                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
802                          (t
803                           (sb-gray:stream-unread-char stream char)
804                           char)))))
805              ((eq peek-type t)
806               (do ((char (sb-gray:stream-read-char stream)
807                          (sb-gray:stream-read-char stream)))
808                   ((or (eq char :eof) (not (sb-impl::whitespace[2]p char)))
809                    (cond ((eq char :eof)
810                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
811                          (t
812                           (sb-gray:stream-unread-char stream char)
813                           char)))))
814              (t
815               (let ((char (sb-gray:stream-peek-char stream)))
816                 (if (eq char :eof)
817                     (sb-impl::eof-or-lose stream eof-error-p eof-value)
818                     char))))))))
819
820 (defun listen (&optional (stream *standard-input*) (width 1))
821   "Returns T if WIDTH octets are available on STREAM.  If WIDTH is
822 given as 'CHARACTER, check for a character.  Note: the WIDTH argument
823 is supported only on simple-streams."
824   ;; WIDTH is number of octets which must be available; any value
825   ;; other than 1 is treated as 'character.
826   (let ((stream (sb-impl::in-synonym-of stream)))
827     (etypecase stream
828       (simple-stream
829        (%listen stream width))
830       (ansi-stream
831        (sb-impl::ansi-stream-listen stream))
832       (fundamental-stream
833        (sb-gray:stream-listen stream)))))
834
835
836 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
837                             eof-value recursive-p)
838   "Returns a line of text read from the Stream as a string, discarding the
839   newline character."
840   (let ((stream (sb-impl::in-synonym-of stream)))
841     (etypecase stream
842       (simple-stream
843        (%read-line stream eof-error-p eof-value recursive-p))
844       (ansi-stream
845        (sb-impl::ansi-stream-read-line stream eof-error-p eof-value
846                                        recursive-p))
847       (fundamental-stream
848        (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
849          (if (and eof (zerop (length string)))
850              (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
851              (values string eof)))))))
852
853 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
854   "Destructively modify SEQ by reading elements from STREAM.
855   SEQ is bounded by START and END. SEQ is destructively modified by
856   copying successive elements into it from STREAM. If the end of file
857   for STREAM is reached before copying all elements of the subsequence,
858   then the extra elements near the end of sequence are not updated, and
859   the index of the next element is returned."
860   (let ((stream (sb-impl::in-synonym-of stream))
861         (end (or end (length seq))))
862     (etypecase stream
863       (simple-stream
864        (with-stream-class (simple-stream stream)
865          (%read-sequence stream seq start end partial-fill)))
866       (ansi-stream
867        (sb-impl::ansi-stream-read-sequence seq stream start end))
868       (fundamental-stream
869        (sb-gray:stream-read-sequence stream seq start end)))))
870
871 (defun clear-input (&optional (stream *standard-input*) buffer-only)
872   "Clears any buffered input associated with the Stream."
873   (let ((stream (sb-impl::in-synonym-of stream)))
874     (etypecase stream
875       (simple-stream
876        (%clear-input stream buffer-only))
877       (ansi-stream
878        (sb-impl::ansi-stream-clear-input stream))
879       (fundamental-stream
880        (sb-gray:stream-clear-input stream))))
881   nil)
882
883 (defun write-byte (integer stream)
884   "Outputs an octet to the Stream."
885   (let ((stream (sb-impl::out-synonym-of stream)))
886     (etypecase stream
887       (simple-stream
888        (%write-byte stream integer))
889       (ansi-stream
890        (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
891       (fundamental-stream
892        (sb-gray:stream-write-byte stream integer))))
893   integer)
894
895 (defun write-char (character &optional (stream *standard-output*))
896   "Outputs the Character to the Stream."
897   (let ((stream (sb-impl::out-synonym-of stream)))
898     (etypecase stream
899       (simple-stream
900        (%write-char stream character))
901       (ansi-stream
902        (funcall (sb-kernel:ansi-stream-out stream) stream character))
903       (fundamental-stream
904        (sb-gray:stream-write-char stream character))))
905   character)
906
907 (defun write-string (string &optional (stream *standard-output*)
908                             &key (start 0) (end nil))
909   "Outputs the String to the given Stream."
910   (let ((stream (sb-impl::out-synonym-of stream))
911         (end (sb-impl::%check-vector-sequence-bounds string start end)))
912     (etypecase stream
913       (simple-stream
914        (%write-string stream string start end)
915        string)
916       (ansi-stream
917        (sb-impl::ansi-stream-write-string string stream start end))
918       (fundamental-stream
919        (sb-gray:stream-write-string stream string start end)))))
920
921 (defun write-line (string &optional (stream *standard-output*)
922                           &key (start 0) end)
923   (declare (type string string))
924   (let ((stream (sb-impl::out-synonym-of stream))
925         (end (sb-impl::%check-vector-sequence-bounds string start end)))
926     (etypecase stream
927       (simple-stream
928        (%check stream :output)
929        (with-stream-class (simple-stream stream)
930          (funcall-stm-handler-2 j-write-chars string stream start end)
931          (funcall-stm-handler-2 j-write-char #\Newline stream)))
932       (ansi-stream
933        (sb-impl::ansi-stream-write-string string stream start end)
934        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
935       (fundamental-stream
936        (sb-gray:stream-write-string stream string start end)
937        (sb-gray:stream-terpri stream))))
938   string)
939
940 (defun write-sequence (seq stream &key (start 0) (end nil))
941   "Write the elements of SEQ bounded by START and END to STREAM."
942   (let ((stream (sb-impl::out-synonym-of stream))
943         (end (or end (length seq))))
944     (etypecase stream
945       (simple-stream
946        (%write-sequence stream seq start end))
947       (ansi-stream
948        (sb-impl::ansi-stream-write-sequence seq stream start end))
949       (fundamental-stream
950        (sb-gray:stream-write-sequence stream seq start end)))))
951
952 (defun terpri (&optional (stream *standard-output*))
953   "Outputs a new line to the Stream."
954   (let ((stream (sb-impl::out-synonym-of stream)))
955     (etypecase stream
956       (simple-stream
957        (%check stream :output)
958        (with-stream-class (simple-stream stream)
959          (funcall-stm-handler-2 j-write-char #\Newline stream)))
960       (ansi-stream
961        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
962       (fundamental-stream
963        (sb-gray:stream-terpri stream))))
964   nil)
965
966 (defun fresh-line (&optional (stream *standard-output*))
967   "Outputs a new line to the Stream if it is not positioned at the beginning of
968    a line.  Returns T if it output a new line, nil otherwise."
969   (let ((stream (sb-impl::out-synonym-of stream)))
970     (etypecase stream
971       (simple-stream
972        (%fresh-line stream))
973       (ansi-stream
974        (sb-impl::ansi-stream-fresh-line stream))
975       (fundamental-stream
976        (sb-gray:stream-fresh-line stream)))))
977
978 (defun finish-output (&optional (stream *standard-output*))
979   "Attempts to ensure that all output sent to the Stream has reached its
980    destination, and only then returns."
981   (let ((stream (sb-impl::out-synonym-of stream)))
982     (etypecase stream
983       (simple-stream
984        (%finish-output stream))
985       (ansi-stream
986        (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
987       (fundamental-stream
988        (sb-gray:stream-finish-output stream))))
989   nil)
990
991 (defun force-output (&optional (stream *standard-output*))
992   "Attempts to force any buffered output to be sent."
993   (let ((stream (sb-impl::out-synonym-of stream)))
994     (etypecase stream
995       (simple-stream
996        (%force-output stream))
997       (ansi-stream
998        (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
999       (fundamental-stream
1000        (sb-gray:stream-force-output stream))))
1001   nil)
1002
1003 (defun clear-output (&optional (stream *standard-output*))
1004   "Clears the given output Stream."
1005   (let ((stream (sb-impl::out-synonym-of stream)))
1006     (etypecase stream
1007       (simple-stream
1008        (%clear-output stream))
1009       (ansi-stream
1010        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
1011       (fundamental-stream
1012        (sb-gray:stream-clear-output stream))))
1013   nil)
1014
1015
1016 (defun file-position (stream &optional position)
1017   "With one argument returns the current position within the file
1018    File-Stream is open to.  If the second argument is supplied, then
1019    this becomes the new file position.  The second argument may also
1020    be :start or :end for the start and end of the file, respectively."
1021   (declare (type (or sb-int:index (member nil :start :end)) position))
1022   (etypecase stream
1023     (simple-stream
1024      (%file-position stream position))
1025     (ansi-stream
1026      (sb-impl::ansi-stream-file-position stream position))))
1027
1028 (defun file-length (stream)
1029   "This function returns the length of the file that File-Stream is open to."
1030   (etypecase stream
1031     (simple-stream
1032      (%file-length stream))
1033     (ansi-stream
1034      (sb-impl::stream-must-be-associated-with-file stream)
1035      (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))
1036
1037 (defun charpos (&optional (stream *standard-output*))
1038   "Returns the number of characters on the current line of output of the given
1039   Stream, or Nil if that information is not availible."
1040   (let ((stream (sb-impl::out-synonym-of stream)))
1041     (etypecase stream
1042       (simple-stream
1043        (with-stream-class (simple-stream stream)
1044          (%check stream :open)
1045          (sm charpos stream)))
1046       (ansi-stream
1047        (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
1048       (fundamental-stream
1049        (sb-gray:stream-line-column stream)))))
1050
1051 (defun line-length (&optional (stream *standard-output*))
1052   "Returns the number of characters in a line of output of the given
1053   Stream, or Nil if that information is not availible."
1054   (let ((stream (sb-impl::out-synonym-of stream)))
1055     (etypecase stream
1056       (simple-stream
1057        (%check stream :output)
1058        ;; TODO (sat 2003-04-02): a way to specify a line length would
1059        ;; be good, I suppose.  Returning nil here means
1060        ;; sb-pretty::default-line-length is used.
1061        nil)
1062       (ansi-stream
1063        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
1064       (fundamental-stream
1065        (sb-gray:stream-line-length stream)))))
1066
1067 (defun wait-for-input-available (stream &optional timeout)
1068   "Waits for input to become available on the Stream and returns T.  If
1069   Timeout expires, Nil is returned."
1070   (let ((stream (sb-impl::in-synonym-of stream)))
1071     (etypecase stream
1072       (fixnum
1073        (sb-sys:wait-until-fd-usable stream :input timeout))
1074       (simple-stream
1075        (%check stream :input)
1076        (with-stream-class (simple-stream stream)
1077          (or (< (sm buffpos stream) (sm buffer-ptr stream))
1078              (wait-for-input-available (sm input-handle stream) timeout))))
1079       (two-way-stream
1080        (wait-for-input-available (two-way-stream-input-stream stream) timeout))
1081       (synonym-stream
1082        (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
1083                                  timeout))
1084       (sb-sys:fd-stream
1085        (or (< (sb-impl::fd-stream-in-index stream)
1086               (length (sb-impl::fd-stream-in-buffer stream)))
1087            (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
1088
1089 ;; Make PATHNAME and NAMESTRING work
1090 (defun sb-int:file-name (stream &optional new-name)
1091   (typecase stream
1092     (file-simple-stream
1093      (with-stream-class (file-simple-stream stream)
1094        (cond (new-name
1095               (%file-rename stream new-name))
1096              (t
1097               (%file-name stream)))))
1098     (sb-sys:fd-stream
1099      (cond (new-name
1100             (setf (sb-impl::fd-stream-pathname stream) new-name)
1101             (setf (sb-impl::fd-stream-file stream)
1102                   (sb-int:unix-namestring new-name nil))
1103             t)
1104            (t
1105             (sb-impl::fd-stream-pathname stream))))))