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