contrib/sb-simple-streams/impl.lisp

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