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