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-base-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-base-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-base-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::whitespacep 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             (when (>= (sm mode stream) 0) ;; device-connected @@ single-channel
 296               (let ((lcrs (sm last-char-read-size stream)))
 297                 (unwind-protect
 298                      (progn
 299                        (setf (sm last-char-read-size stream) (1+ lcrs))
 300                        (plusp (refill-buffer stream nil)))
 301                   (setf (sm last-char-read-size stream) lcrs))))))))
 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)
 478            (type (or null sb-int:index) end)
 479            (type boolean partial-fill))
 480   (with-stream-class (simple-stream stream)
 481     (%check stream :input)
 482     (when (any-stream-instance-flags stream :eof)
 483       (return-from %read-sequence 0))
 484     (etypecase seq
 485       (string
 486        (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
 487                             start (or end (length seq))
 488                             (if partial-fill :bnb t)))
 489       ((or (simple-array (unsigned-byte 8) (*))
 490            (simple-array (signed-byte 8) (*)))
 491        ;; "read-vector" equivalent, but blocking if partial-fill is NIL
 492        (error "implement me")
 493        )
 494       ;; extend to work on other sequences: repeated read-byte
 495       )))
 496
 497
 498 (defun %write-sequence (stream seq start end)
 499   (declare (type simple-stream stream)
 500            (type sequence seq)
 501            (type sb-int:index start)
 502            (type (or null sb-int:index) end))
 503   (with-stream-class (simple-stream stream)
 504     (%check stream :output)
 505     (etypecase seq
 506       (string
 507        (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
 508                               start (or end (length seq))))
 509       ((or (simple-array (unsigned-byte 8) (*))
 510            (simple-array (signed-byte 8) (*)))
 511        ;; "write-vector" equivalent
 512        (setf (sm charpos stream) nil)
 513        (etypecase stream
 514          (single-channel-simple-stream
 515           (with-stream-class (single-channel-simple-stream stream)
 516             (loop with max-ptr = (sm buf-len stream)
 517                   with real-end = (or end (length seq))
 518                   for src-pos = start then (+ src-pos count)
 519                   for src-rest = (- real-end src-pos)
 520                   while (> src-rest 0) ; FIXME: this is non-ANSI
 521                   for ptr = (let ((ptr (sm buffpos stream)))
 522                               (if (>= ptr max-ptr)
 523                                   (flush-buffer stream t)
 524                                   ptr))
 525                   for buf-rest = (- max-ptr ptr)
 526                   for count = (min buf-rest src-rest)
 527                   do (progn (setf (sm mode stream) 1)
 528                             (setf (sm buffpos stream) (+ ptr count))
 529                             (buffer-copy seq src-pos (sm buffer stream) ptr count)))))
 530          (dual-channel-simple-stream
 531           (error "Implement me"))
 532          (string-simple-stream
 533           (error 'simple-type-error
 534                  :datum stream
 535                  :expected-type 'stream
 536                  :format-control "Can't write-byte on string streams."
 537                  :format-arguments '())))
 538        )
 539       ;; extend to work on other sequences: repeated write-byte
 540       )))
 541
 542
 543 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
 544   (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
 545            (type stream stream))
 546   ;; START and END are octet offsets, not vector indices!  [Except for strings]
 547   ;; Return value is index of next octet to be read into (i.e., start+count)
 548   (etypecase stream
 549     (simple-stream
 550      (with-stream-class (simple-stream stream)
 551        (if (stringp vector)
 552            (let* ((start (or start 0))
 553                   (end (or end (length vector)))
 554                   (encap (sm melded-stream stream))
 555                   (char (funcall-stm-handler j-read-char encap nil nil t)))
 556              (when char
 557                (setf (schar vector start) char)
 558                (incf start)
 559                (+ start (funcall-stm-handler j-read-chars encap vector nil
 560                                              start end nil))))
 561            (do* ((j-read-byte (if (any-stream-instance-flags stream :string)
 562                                   (error "Can't READ-BYTE on string streams.")
 563                                   #'read-byte-internal))
 564                  (encap (sm melded-stream stream))
 565                  (index (or start 0) (1+ index))
 566                  (end (or end (* (length vector) (vector-elt-width vector))))
 567                  (endian-swap (endian-swap-value vector endian-swap))
 568                  (byte (funcall j-read-byte encap nil nil t)
 569                        (funcall j-read-byte encap nil nil nil)))
 570                 ((or (null byte) (>= index end)) index)
 571              (setf (bref vector (logxor index endian-swap)) byte)))))
 572     ((or ansi-stream fundamental-stream)
 573      (unless (typep vector '(or string
 574                              (simple-array (signed-byte 8) (*))
 575                              (simple-array (unsigned-byte 8) (*))))
 576        (error "Wrong vector type for read-vector on stream not of type simple-stream."))
 577      (read-sequence vector stream :start (or start 0) :end end))))
 578
 579 ;;; Basic functionality for ansi-streams.  These are separate
 580 ;;; functions because they are called in places where we already know
 581 ;;; we operate on an ansi-stream (as opposed to a simple- or
 582 ;;; gray-stream, or the symbols t or nil), so we can evade typecase
 583 ;;; and (in|out)-synonym-of calls.
 584
 585 (declaim (inline %ansi-stream-read-byte %ansi-stream-read-char
 586                  %ansi-stream-unread-char %ansi-stream-read-line
 587                  %ansi-stream-read-sequence))
 588
 589 (defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking)
 590   (declare (ignore blocking))
 591   #+nil
 592   (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value)
 593   (sb-int:prepare-for-fast-read-byte stream
 594     (prog1
 595         (sb-int:fast-read-byte eof-error-p eof-value t)
 596       (sb-int:done-with-fast-read-byte))))
 597
 598 (defun %ansi-stream-read-char (stream eof-error-p eof-value blocking)
 599   (declare (ignore blocking))
 600   #+nil
 601   (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value)
 602   (sb-int:prepare-for-fast-read-char stream
 603     (prog1
 604         (sb-int:fast-read-char eof-error-p eof-value)
 605       (sb-int:done-with-fast-read-char))))
 606
 607 (defun %ansi-stream-unread-char (character stream)
 608   (let ((index (1- (sb-kernel:ansi-stream-in-index stream)))
 609         (buffer (sb-kernel:ansi-stream-in-buffer stream)))
 610     (declare (fixnum index))
 611     (when (minusp index) (error "nothing to unread"))
 612     (cond (buffer
 613            (setf (aref buffer index) (char-code character))
 614            (setf (sb-kernel:ansi-stream-in-index stream) index))
 615           (t
 616            (funcall (sb-kernel:ansi-stream-misc stream) stream
 617                     :unread character)))))
 618
 619 (defun %ansi-stream-read-line (stream eof-error-p eof-value)
 620   (sb-int:prepare-for-fast-read-char stream
 621     (let ((res (make-string 80))
 622           (len 80)
 623           (index 0))
 624       (loop
 625        (let ((ch (sb-int:fast-read-char nil nil)))
 626          (cond (ch
 627                 (when (char= ch #\newline)
 628                   (sb-int:done-with-fast-read-char)
 629                   (return (values (sb-kernel:shrink-vector res index) nil)))
 630                 (when (= index len)
 631                   (setq len (* len 2))
 632                   (let ((new (make-string len)))
 633                     (replace new res)
 634                     (setq res new)))
 635                 (setf (schar res index) ch)
 636                 (incf index))
 637                ((zerop index)
 638                 (sb-int:done-with-fast-read-char)
 639                 (return (values (sb-impl::eof-or-lose stream eof-error-p
 640                                                       eof-value)
 641                                 t)))
 642                ;; Since FAST-READ-CHAR already hit the eof char, we
 643                ;; shouldn't do another READ-CHAR.
 644                (t
 645                 (sb-int:done-with-fast-read-char)
 646                 (return (values (sb-kernel:shrink-vector res index) t)))))))))
 647
 648 (defun %ansi-stream-read-sequence (seq stream start %end)
 649   (declare (type sequence seq)
 650            (type sb-kernel:ansi-stream stream)
 651            (type sb-int:index start)
 652            (type sb-kernel:sequence-end %end)
 653            (values sb-int:index))
 654   (let ((end (or %end (length seq))))
 655     (declare (type sb-int:index end))
 656     (etypecase seq
 657       (list
 658        (let ((read-function
 659               (if (subtypep (stream-element-type stream) 'character)
 660                   #'%ansi-stream-read-char
 661                   #'%ansi-stream-read-byte)))
 662          (do ((rem (nthcdr start seq) (rest rem))
 663               (i start (1+ i)))
 664              ((or (endp rem) (>= i end)) i)
 665            (declare (type list rem)
 666                     (type sb-int:index i))
 667            (let ((el (funcall read-function stream nil :eof nil)))
 668              (when (eq el :eof)
 669                (return i))
 670              (setf (first rem) el)))))
 671       (vector
 672        (sb-kernel:with-array-data ((data seq) (offset-start start)
 673                                    (offset-end end))
 674          (typecase data
 675            ((or (simple-array (unsigned-byte 8) (*))
 676                 (simple-array (signed-byte 8) (*))
 677                 simple-string)
 678             (let* ((numbytes (- end start))
 679                    (bytes-read (sb-sys:read-n-bytes stream
 680                                                     data
 681                                                     offset-start
 682                                                     numbytes
 683                                                     nil)))
 684               (if (< bytes-read numbytes)
 685                   (+ start bytes-read)
 686                   end)))
 687            (t
 688             (let ((read-function
 689                    (if (subtypep (stream-element-type stream) 'character)
 690                        #'%ansi-stream-read-char
 691                        #'%ansi-stream-read-byte)))
 692               (do ((i offset-start (1+ i)))
 693                   ((>= i offset-end) end)
 694                 (declare (type sb-int:index i))
 695                 (let ((el (funcall read-function stream nil :eof nil)))
 696                   (when (eq el :eof)
 697                     (return (+ start (- i offset-start))))
 698                   (setf (aref data i) el)))))))))))
 699
 700
 701 (defun %ansi-stream-write-string (string stream start end)
 702   (declare (type string string)
 703            (type sb-kernel:ansi-stream stream)
 704            (type sb-int:index start end))
 705
 706   ;; Note that even though you might expect, based on the behavior of
 707   ;; things like AREF, that the correct upper bound here is
 708   ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
 709   ;; "bounding index" and "length" indicate that in this case (i.e.
 710   ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
 711   ;; which are implemented in terms of this function), (LENGTH STRING)
 712   ;; is the required upper bound. A foolish consistency is the
 713   ;; hobgoblin of lesser languages..
 714   (unless (<= 0 start end (length string))
 715     (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
 716            start
 717            end
 718            string))
 719
 720   (if (sb-kernel:array-header-p string)
 721       (sb-kernel:with-array-data ((data string) (offset-start start)
 722                                   (offset-end end))
 723         (funcall (sb-kernel:ansi-stream-sout stream)
 724                  stream data offset-start offset-end))
 725       (funcall (sb-kernel:ansi-stream-sout stream) stream string start end))
 726   string)
 727
 728 (defun %ansi-stream-write-sequence (seq stream start %end)
 729   (declare (type sequence seq)
 730            (type sb-kernel:ansi-stream stream)
 731            (type sb-int:index start)
 732            (type sb-kernel:sequence-end %end)
 733            (values sequence))
 734   (let ((end (or %end (length seq))))
 735     (declare (type sb-int:index end))
 736     (etypecase seq
 737       (list
 738        (let ((write-function
 739               (if (subtypep (stream-element-type stream) 'character)
 740                   ;; TODO: Replace these with ansi-stream specific
 741                   ;; functions too.
 742                   #'write-char
 743                   #'write-byte)))
 744          (do ((rem (nthcdr start seq) (rest rem))
 745               (i start (1+ i)))
 746              ((or (endp rem) (>= i end)) seq)
 747            (declare (type list rem)
 748                     (type sb-int:index i))
 749            (funcall write-function (first rem) stream))))
 750       (string
 751        (%ansi-stream-write-string seq stream start end))
 752       (vector
 753        (let ((write-function
 754               (if (subtypep (stream-element-type stream) 'character)
 755                   ;; TODO: Replace these with ansi-stream specific
 756                   ;; functions too.
 757                   #'write-char
 758                   #'write-byte)))
 759          (do ((i start (1+ i)))
 760              ((>= i end) seq)
 761            (declare (type sb-int:index i))
 762            (funcall write-function (aref seq i) stream)))))))
 763
 764
 765 ;;;
 766 ;;; USER-LEVEL FUNCTIONS
 767 ;;;
 768
 769 (defmethod open-stream-p ((stream simple-stream))
 770   (any-stream-instance-flags stream :input :output))
 771
 772 (defmethod input-stream-p ((stream simple-stream))
 773   (any-stream-instance-flags stream :input))
 774
 775 (defmethod output-stream-p ((stream simple-stream))
 776   (any-stream-instance-flags stream :output))
 777
 778 (defmethod stream-element-type ((stream simple-stream))
 779   '(unsigned-byte 8))
 780
 781 (defun interactive-stream-p (stream)
 782   "Return true if Stream does I/O on a terminal or other interactive device."
 783   (etypecase stream
 784     (simple-stream
 785      (%check stream :open)
 786      (any-stream-instance-flags stream :interactive))
 787     (ansi-stream
 788      (funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
 789     (fundamental-stream
 790      nil)))
 791
 792 (defun (setf interactive-stream-p) (flag stream)
 793   (typecase stream
 794     (simple-stream
 795      (%check stream :open)
 796      (if flag
 797          (add-stream-instance-flags stream :interactive)
 798          (remove-stream-instance-flags stream :interactive)))
 799     (t
 800      (error 'simple-type-error
 801             :datum stream
 802             :expected-type 'simple-stream
 803             :format-control "Can't set interactive flag on ~S."
 804             :format-arguments (list stream)))))
 805
 806 (defun file-string-length (stream object)
 807   (declare (type (or string character) object) (type stream stream))
 808   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
 809    OBJECT to STREAM. Non-trivial only in implementations that support
 810    international character sets."
 811   (typecase stream
 812     (simple-stream (%file-string-length stream object))
 813     (t
 814      (etypecase object
 815        (character 1)
 816        (string (length object))))))
 817
 818 (defun stream-external-format (stream)
 819   "Returns Stream's external-format."
 820   (etypecase stream
 821     (simple-stream
 822      (with-stream-class (simple-stream)
 823        (%check stream :open)
 824        (sm external-format stream)))
 825     (ansi-stream
 826      :default)
 827     (fundamental-stream
 828      :default)))
 829
 830 (defun open (filename &rest options
 831              &key (direction :input)
 832              (element-type 'character element-type-given)
 833              if-exists if-does-not-exist
 834              (external-format :default)
 835              class mapped input-handle output-handle
 836              &allow-other-keys)
 837   "Return a stream which reads from or writes to Filename.
 838   Defined keywords:
 839    :direction - one of :input, :output, :io, or :probe
 840    :element-type - type of object to read or write, default BASE-CHAR
 841    :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
 842                        :overwrite, :append, :supersede or NIL
 843    :if-does-not-exist - one of :error, :create or NIL
 844    :external-format - :default
 845   See the manual for details.
 846
 847   The following are simple-streams-specific additions:
 848    :class - class of stream object to be created
 849    :mapped - T to open a memory-mapped file
 850    :input-handle - a stream or Unix file descriptor to read from
 851    :output-handle - a stream or Unix file descriptor to write to"
 852   (declare (ignore element-type external-format input-handle output-handle
 853                    if-exists if-does-not-exist))
 854   (let ((class (or class 'sb-sys::file-stream))
 855         (options (copy-list options))
 856         (filespec (merge-pathnames filename)))
 857     (cond ((eq class 'sb-sys::file-stream)
 858            (remf options :class)
 859            (remf options :mapped)
 860            (remf options :input-handle)
 861            (remf options :output-handle)
 862            (apply #'open-fd-stream filespec options))
 863           ((subtypep class 'simple-stream)
 864            (when element-type-given
 865              (cerror "Do it anyway."
 866                      "Can't create simple-streams with an element-type."))
 867            (when (and (eq class 'file-simple-stream) mapped)
 868              (setq class 'mapped-file-simple-stream)
 869              (setf (getf options :class) 'mapped-file-simple-stream))
 870            (when (subtypep class 'file-simple-stream)
 871              (when (eq direction :probe)
 872                (setq class 'probe-simple-stream)))
 873            (apply #'make-instance class :filename filespec options))
 874           ((subtypep class 'sb-gray:fundamental-stream)
 875            (remf options :class)
 876            (remf options :mapped)
 877            (remf options :input-handle)
 878            (remf options :output-handle)
 879            (make-instance class :lisp-stream
 880                           (apply #'open-fd-stream filespec options))))))
 881
 882
 883 (declaim (inline read-byte read-char read-char-no-hang unread-char))
 884
 885 (defun read-byte (stream &optional (eof-error-p t) eof-value)
 886   "Returns the next byte of the Stream."
 887   (let ((stream (sb-impl::in-synonym-of stream)))
 888     (etypecase stream
 889       (simple-stream
 890        (%read-byte stream eof-error-p eof-value))
 891       (ansi-stream
 892        (%ansi-stream-read-byte stream eof-error-p eof-value t))
 893       (fundamental-stream
 894        (let ((char (sb-gray:stream-read-byte stream)))
 895          (if (eq char :eof)
 896              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 897              char))))))
 898
 899 (defun read-char (&optional (stream *standard-input*) (eof-error-p t)
 900                             eof-value recursive-p)
 901   "Inputs a character from Stream and returns it."
 902   (let ((stream (sb-impl::in-synonym-of stream)))
 903     (etypecase stream
 904       (simple-stream
 905        (%read-char stream eof-error-p eof-value recursive-p t))
 906       (ansi-stream
 907        (%ansi-stream-read-char stream eof-error-p eof-value t))
 908       (fundamental-stream
 909        (let ((char (sb-gray:stream-read-char stream)))
 910          (if (eq char :eof)
 911              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 912              char))))))
 913
 914 (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t)
 915                                     eof-value recursive-p)
 916   "Returns the next character from the Stream if one is availible, or nil."
 917   (declare (ignore recursive-p))
 918   (let ((stream (sb-impl::in-synonym-of stream)))
 919     (etypecase stream
 920       (simple-stream
 921        (%check stream :input)
 922        (with-stream-class (simple-stream)
 923          (funcall-stm-handler j-read-char stream eof-error-p eof-value nil)))
 924       (ansi-stream
 925        (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
 926            (%ansi-stream-read-char stream eof-error-p eof-value t)
 927            nil))
 928       (fundamental-stream
 929        (let ((char (sb-gray:stream-read-char-no-hang stream)))
 930          (if (eq char :eof)
 931              (sb-impl::eof-or-lose stream eof-error-p eof-value)
 932              char))))))
 933
 934 (defun unread-char (character &optional (stream *standard-input*))
 935   "Puts the Character back on the front of the input Stream."
 936   (let ((stream (sb-impl::in-synonym-of stream)))
 937     (etypecase stream
 938       (simple-stream
 939        (%unread-char stream character))
 940       (ansi-stream
 941        (%ansi-stream-unread-char character stream))
 942       (fundamental-stream
 943        (sb-gray:stream-unread-char stream character))))
 944   nil)
 945
 946 (declaim (notinline read-byte read-char read-char-no-hang unread-char))
 947
 948 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
 949                             (eof-error-p t) eof-value recursive-p)
 950   "Peeks at the next character in the input Stream.  See manual for details."
 951   (let ((stream (sb-impl::in-synonym-of stream)))
 952     (etypecase stream
 953       (simple-stream
 954        (%peek-char stream peek-type eof-error-p eof-value recursive-p))
 955       (ansi-stream
 956        (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
 957           (cond ((eq char eof-value) char)
 958                 ((characterp peek-type)
 959                  (do ((char char (%ansi-stream-read-char stream eof-error-p
 960                                                          eof-value t)))
 961                      ((or (eq char eof-value) (char= char peek-type))
 962                       (unless (eq char eof-value)
 963                         (%ansi-stream-unread-char char stream))
 964                       char)))
 965                 ((eq peek-type t)
 966                  (do ((char char (%ansi-stream-read-char stream eof-error-p
 967                                                          eof-value t)))
 968                      ((or (eq char eof-value)
 969                           (not (sb-int:whitespace-char-p char)))
 970                       (unless (eq char eof-value)
 971                         (%ansi-stream-unread-char char stream))
 972                       char)))
 973                 (t
 974                  (%ansi-stream-unread-char char stream)
 975                  char))))
 976       (fundamental-stream
 977        (cond ((characterp peek-type)
 978               (do ((char (sb-gray:stream-read-char stream)
 979                          (sb-gray:stream-read-char stream)))
 980                   ((or (eq char :eof) (char= char peek-type))
 981                    (cond ((eq char :eof)
 982                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
 983                          (t
 984                           (sb-gray:stream-unread-char stream char)
 985                           char)))))
 986              ((eq peek-type t)
 987               (do ((char (sb-gray:stream-read-char stream)
 988                          (sb-gray:stream-read-char stream)))
 989                   ((or (eq char :eof) (not (sb-int:whitespace-char-p char)))
 990                    (cond ((eq char :eof)
 991                           (sb-impl::eof-or-lose stream eof-error-p eof-value))
 992                          (t
 993                           (sb-gray:stream-unread-char stream char)
 994                           char)))))
 995              (t
 996               (let ((char (sb-gray:stream-peek-char stream)))
 997                 (if (eq char :eof)
 998                     (sb-impl::eof-or-lose stream eof-error-p eof-value)
 999                     char))))))))
1000
1001 (defun listen (&optional (stream *standard-input*) (width 1))
1002   "Returns T if Width octets are available on the given Stream.  If Width
1003   is given as 'character, check for a character."
1004   ;; WIDTH is number of octets which must be available; any value
1005   ;; other than 1 is treated as 'character.
1006   (let ((stream (sb-impl::in-synonym-of stream)))
1007     (etypecase stream
1008       (simple-stream
1009        (%listen stream width))
1010       (ansi-stream
1011        (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
1012                sb-impl::+ansi-stream-in-buffer-length+)
1013             ;; Test for T explicitly since misc methods return :EOF sometimes.
1014             (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen)
1015                 t)))
1016       (fundamental-stream
1017        (sb-gray:stream-listen stream)))))
1018
1019
1020 (defun read-line (&optional (stream *standard-input*) (eof-error-p t)
1021                             eof-value recursive-p)
1022   "Returns a line of text read from the Stream as a string, discarding the
1023   newline character."
1024   (let ((stream (sb-impl::in-synonym-of stream)))
1025     (etypecase stream
1026       (simple-stream
1027        (%read-line stream eof-error-p eof-value recursive-p))
1028       (ansi-stream
1029        (%ansi-stream-read-line stream eof-error-p eof-value))
1030       (fundamental-stream
1031        (multiple-value-bind (string eof) (sb-gray:stream-read-line stream)
1032          (if (and eof (zerop (length string)))
1033              (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t)
1034              (values string eof)))))))
1035
1036 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
1037   "Destructively modify SEQ by reading elements from STREAM.
1038   SEQ is bounded by START and END. SEQ is destructively modified by
1039   copying successive elements into it from STREAM. If the end of file
1040   for STREAM is reached before copying all elements of the subsequence,
1041   then the extra elements near the end of sequence are not updated, and
1042   the index of the next element is returned."
1043   (let ((stream (sb-impl::in-synonym-of stream))
1044         (end (or end (length seq))))
1045     (etypecase stream
1046       (simple-stream
1047        (with-stream-class (simple-stream stream)
1048          (%read-sequence stream seq start end partial-fill)))
1049       (ansi-stream
1050        (%ansi-stream-read-sequence seq stream start end))
1051       (fundamental-stream
1052        (sb-gray:stream-read-sequence stream seq start end)))))
1053
1054 (defun clear-input (&optional (stream *standard-input*) buffer-only)
1055   "Clears any buffered input associated with the Stream."
1056   (let ((stream (sb-impl::in-synonym-of stream)))
1057     (etypecase stream
1058       (simple-stream
1059        (%clear-input stream buffer-only))
1060       (ansi-stream
1061        (setf (sb-kernel:ansi-stream-in-index stream)
1062              sb-impl::+ansi-stream-in-buffer-length+)
1063        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input))
1064       (fundamental-stream
1065        (sb-gray:stream-clear-input stream))))
1066   nil)
1067
1068 (defun write-byte (integer stream)
1069   "Outputs an octet to the Stream."
1070   (let ((stream (sb-impl::out-synonym-of stream)))
1071     (etypecase stream
1072       (simple-stream
1073        (%write-byte stream integer))
1074       (ansi-stream
1075        (funcall (sb-kernel:ansi-stream-bout stream) stream integer))
1076       (fundamental-stream
1077        (sb-gray:stream-write-byte stream integer))))
1078   integer)
1079
1080 (defun write-char (character &optional (stream *standard-output*))
1081   "Outputs the Character to the Stream."
1082   (let ((stream (sb-impl::out-synonym-of stream)))
1083     (etypecase stream
1084       (simple-stream
1085        (%write-char stream character))
1086       (ansi-stream
1087        (funcall (sb-kernel:ansi-stream-out stream) stream character))
1088       (fundamental-stream
1089        (sb-gray:stream-write-char stream character))))
1090   character)
1091
1092 (defun write-string (string &optional (stream *standard-output*)
1093                             &key (start 0) (end nil))
1094   "Outputs the String to the given Stream."
1095   (let ((stream (sb-impl::out-synonym-of stream))
1096         (end (or end (length string))))
1097     (etypecase stream
1098       (simple-stream
1099        (%write-string stream string start end)
1100        string)
1101       (ansi-stream
1102        (%ansi-stream-write-string string stream start end))
1103       (fundamental-stream
1104        (sb-gray:stream-write-string stream string start end)))))
1105
1106 (defun write-line (string &optional (stream *standard-output*)
1107                           &key (start 0) end)
1108   (declare (type string string))
1109   ;; FIXME: Why is there this difference between the treatments of the
1110   ;; STREAM argument in WRITE-STRING and WRITE-LINE?
1111   (let ((stream (sb-impl::out-synonym-of stream))
1112         (end (or end (length string))))
1113     (etypecase stream
1114       (simple-stream
1115        (%check stream :output)
1116        (with-stream-class (simple-stream stream)
1117          (funcall-stm-handler-2 j-write-chars string stream start end)
1118          (funcall-stm-handler-2 j-write-char #\Newline stream)))
1119       (ansi-stream
1120        (%ansi-stream-write-string string stream start end)
1121        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
1122       (fundamental-stream
1123        (sb-gray:stream-write-string stream string start end)
1124        (sb-gray:stream-terpri stream))))
1125   string)
1126
1127 (defun write-sequence (seq stream &key (start 0) (end nil))
1128   "Write the elements of SEQ bounded by START and END to STREAM."
1129   (let ((stream (sb-impl::out-synonym-of stream))
1130         (end (or end (length seq))))
1131     (etypecase stream
1132       (simple-stream
1133        (%write-sequence stream seq start end))
1134       (ansi-stream
1135        (%ansi-stream-write-sequence seq stream start end))
1136       (fundamental-stream
1137        (sb-gray:stream-write-sequence stream seq start end)))))
1138
1139 (defun terpri (&optional (stream *standard-output*))
1140   "Outputs a new line to the Stream."
1141   (let ((stream (sb-impl::out-synonym-of stream)))
1142     (etypecase stream
1143       (simple-stream
1144        (%check stream :output)
1145        (with-stream-class (simple-stream stream)
1146          (funcall-stm-handler-2 j-write-char #\Newline stream)))
1147       (ansi-stream
1148        (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline))
1149       (fundamental-stream
1150        (sb-gray:stream-terpri stream))))
1151   nil)
1152
1153 (defun fresh-line (&optional (stream *standard-output*))
1154   "Outputs a new line to the Stream if it is not positioned at the beginning of
1155    a line.  Returns T if it output a new line, nil otherwise."
1156   (let ((stream (sb-impl::out-synonym-of stream)))
1157     (etypecase stream
1158       (simple-stream
1159        (%fresh-line stream))
1160       (ansi-stream
1161        (when (/= (or (sb-kernel:charpos stream) 1) 0)
1162          (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
1163          t))
1164       (fundamental-stream
1165        (sb-gray:stream-fresh-line stream)))))
1166
1167 (defun finish-output (&optional (stream *standard-output*))
1168   "Attempts to ensure that all output sent to the Stream has reached its
1169    destination, and only then returns."
1170   (let ((stream (sb-impl::out-synonym-of stream)))
1171     (etypecase stream
1172       (simple-stream
1173        (%finish-output stream))
1174       (ansi-stream
1175        (funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
1176       (fundamental-stream
1177        (sb-gray:stream-finish-output stream))))
1178   nil)
1179
1180 (defun force-output (&optional (stream *standard-output*))
1181   "Attempts to force any buffered output to be sent."
1182   (let ((stream (sb-impl::out-synonym-of stream)))
1183     (etypecase stream
1184       (simple-stream
1185        (%force-output stream))
1186       (ansi-stream
1187        (funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
1188       (fundamental-stream
1189        (sb-gray:stream-force-output stream))))
1190   nil)
1191
1192 (defun clear-output (&optional (stream *standard-output*))
1193   "Clears the given output Stream."
1194   (let ((stream (sb-impl::out-synonym-of stream)))
1195     (etypecase stream
1196       (simple-stream
1197        (%clear-output stream))
1198       (ansi-stream
1199        (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
1200       (fundamental-stream
1201        (sb-gray:stream-clear-output stream))))
1202   nil)
1203
1204
1205 (defun file-position (stream &optional position)
1206   "With one argument returns the current position within the file
1207    File-Stream is open to.  If the second argument is supplied, then
1208    this becomes the new file position.  The second argument may also
1209    be :start or :end for the start and end of the file, respectively."
1210   (declare (type (or (integer 0 *) (member nil :start :end)) position))
1211   (etypecase stream
1212     (simple-stream
1213      (%file-position stream position))
1214     (ansi-stream
1215      (cond
1216        (position
1217         (setf (sb-kernel:ansi-stream-in-index stream)
1218               sb-impl::+ansi-stream-in-buffer-length+)
1219         (funcall (sb-kernel:ansi-stream-misc stream)
1220                  stream :file-position position))
1221        (t
1222         (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
1223                             stream :file-position nil)))
1224           (when res
1225             (- res
1226                (- sb-impl::+ansi-stream-in-buffer-length+
1227                   (sb-kernel:ansi-stream-in-index stream))))))))))
1228
1229 (defun file-length (stream)
1230   "This function returns the length of the file that File-Stream is open to."
1231   (etypecase stream
1232     (simple-stream
1233      (%file-length stream))
1234     (ansi-stream
1235      (progn (sb-impl::stream-must-be-associated-with-file stream)
1236             (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
1237
1238 (defun charpos (&optional (stream *standard-output*))
1239   "Returns the number of characters on the current line of output of the given
1240   Stream, or Nil if that information is not availible."
1241   (let ((stream (sb-impl::out-synonym-of stream)))
1242     (etypecase stream
1243       (simple-stream
1244        (with-stream-class (simple-stream stream)
1245          (%check stream :open)
1246          (sm charpos stream)))
1247       (ansi-stream
1248        (funcall (sb-kernel:ansi-stream-misc stream) stream :charpos))
1249       (fundamental-stream
1250        (sb-gray:stream-line-column stream)))))
1251
1252 (defun line-length (&optional (stream *standard-output*))
1253   "Returns the number of characters in a line of output of the given
1254   Stream, or Nil if that information is not availible."
1255   (let ((stream (sb-impl::out-synonym-of stream)))
1256     (etypecase stream
1257       (simple-stream
1258        (%check stream :output)
1259        ;; TODO (sat 2003-04-02): a way to specify a line length would
1260        ;; be good, I suppose.  Returning nil here means
1261        ;; sb-pretty::default-line-length is used.
1262        nil)
1263       (ansi-stream
1264        (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
1265       (fundamental-stream
1266        (sb-gray:stream-line-length stream)))))
1267
1268 (defun wait-for-input-available (stream &optional timeout)
1269   "Waits for input to become available on the Stream and returns T.  If
1270   Timeout expires, Nil is returned."
1271   (let ((stream (sb-impl::in-synonym-of stream)))
1272     (etypecase stream
1273       (fixnum
1274        (sb-sys:wait-until-fd-usable stream :input timeout))
1275       (simple-stream
1276        (%check stream :input)
1277        (with-stream-class (simple-stream stream)
1278          (or (< (sm buffpos stream) (sm buffer-ptr stream))
1279              (wait-for-input-available (sm input-handle stream) timeout))))
1280       (two-way-stream
1281        (wait-for-input-available (two-way-stream-input-stream stream) timeout))
1282       (synonym-stream
1283        (wait-for-input-available (symbol-value (synonym-stream-symbol stream))
1284                                  timeout))
1285       (sb-sys::file-stream
1286        (or (< (sb-impl::fd-stream-in-index stream)
1287               (length (sb-impl::fd-stream-in-buffer stream)))
1288            (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
1289
1290 ;; Make PATHNAME and NAMESTRING work
1291 (defun sb-int:file-name (stream &optional new-name)
1292   (typecase stream
1293     (file-simple-stream
1294      (with-stream-class (file-simple-stream stream)
1295        (cond (new-name
1296               (%file-rename stream new-name))
1297              (t
1298               (%file-name stream)))))
1299     (sb-sys::file-stream
1300      (cond (new-name
1301             (setf (sb-impl::fd-stream-pathname stream) new-name)
1302             (setf (sb-impl::fd-stream-file stream)
1303                   (sb-int:unix-namestring new-name nil))
1304             t)
1305            (t
1306             (sb-impl::fd-stream-pathname stream))))))
1307
1308 ;;; bugfix
1309
1310 ;;; TODO: Rudi 2003-01-12: What is this for?  Incorporate into sbcl or
1311 ;;; remove it.
1312 #+nil
1313 (defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
1314   (declare (type fundamental-stream stream) ;; this is a lie
1315            (ignore arg2))
1316   (case operation
1317     (:listen
1318      (ext:stream-listen stream))
1319     (:unread
1320      (ext:stream-unread-char stream arg1))
1321     (:close
1322      (close stream))
1323     (:clear-input
1324      (ext:stream-clear-input stream))
1325     (:force-output
1326      (ext:stream-force-output stream))
1327     (:finish-output
1328      (ext:stream-finish-output stream))
1329     (:element-type
1330      (stream-element-type stream))
1331     (:interactive-p
1332      (interactive-stream-p stream))
1333     (:line-length
1334      (ext:stream-line-length stream))
1335     (:charpos
1336      (ext:stream-line-column stream))
1337     (:file-length
1338      (file-length stream))
1339     (:file-position
1340      (file-position stream arg1))))