src/code/stream.lisp

   1 ;;;; os-independent stream functions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;;; standard streams
  15
  16 ;;; The initialization of these streams is performed by
  17 ;;; STREAM-COLD-INIT-OR-RESET.
  18 (defvar *terminal-io* () #!+sb-doc "terminal I/O stream")
  19 (defvar *standard-input* () #!+sb-doc "default input stream")
  20 (defvar *standard-output* () #!+sb-doc "default output stream")
  21 (defvar *error-output* () #!+sb-doc "error output stream")
  22 (defvar *query-io* () #!+sb-doc "query I/O stream")
  23 (defvar *trace-output* () #!+sb-doc "trace output stream")
  24 (defvar *debug-io* () #!+sb-doc "interactive debugging stream")
  25
  26 (defun ill-in (stream &rest ignore)
  27   (declare (ignore ignore))
  28   (error 'simple-type-error
  29          :datum stream
  30          :expected-type '(satisfies input-stream-p)
  31          :format-control "~S is not a character input stream."
  32          :format-arguments (list stream)))
  33 (defun ill-out (stream &rest ignore)
  34   (declare (ignore ignore))
  35   (error 'simple-type-error
  36          :datum stream
  37          :expected-type '(satisfies output-stream-p)
  38          :format-control "~S is not a character output stream."
  39          :format-arguments (list stream)))
  40 (defun ill-bin (stream &rest ignore)
  41   (declare (ignore ignore))
  42   (error 'simple-type-error
  43          :datum stream
  44          :expected-type '(satisfies input-stream-p)
  45          :format-control "~S is not a binary input stream."
  46          :format-arguments (list stream)))
  47 (defun ill-bout (stream &rest ignore)
  48   (declare (ignore ignore))
  49   (error 'simple-type-error
  50          :datum stream
  51          :expected-type '(satisfies output-stream-p)
  52          :format-control "~S is not a binary output stream."
  53          :format-arguments (list stream)))
  54 (defun closed-flame (stream &rest ignore)
  55   (declare (ignore ignore))
  56   (error "~S is closed." stream))
  57 (defun no-op-placeholder (&rest ignore)
  58   (declare (ignore ignore)))
  59 \f
  60 ;;; stream manipulation functions
  61
  62 (declaim (inline ansi-stream-input-stream-p))
  63 (defun ansi-stream-input-stream-p (stream)
  64   (declare (type ansi-stream stream))
  65
  66   (when (synonym-stream-p stream)
  67     (setf stream
  68           (symbol-value (synonym-stream-symbol stream))))
  69
  70   (and (not (eq (ansi-stream-in stream) #'closed-flame))
  71        ;;; KLUDGE: It's probably not good to have EQ tests on function
  72        ;;; values like this. What if someone's redefined the function?
  73        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
  74        ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
  75        (or (not (eq (ansi-stream-in stream) #'ill-in))
  76            (not (eq (ansi-stream-bin stream) #'ill-bin)))))
  77
  78 (defun input-stream-p (stream)
  79   (declare (type stream stream))
  80   (and (ansi-stream-p stream)
  81        (ansi-stream-input-stream-p stream)))
  82
  83 (declaim (inline ansi-stream-output-stream-p))
  84 (defun ansi-stream-output-stream-p (stream)
  85   (declare (type ansi-stream stream))
  86
  87   (when (synonym-stream-p stream)
  88     (setf stream (symbol-value
  89                   (synonym-stream-symbol stream))))
  90
  91   (and (not (eq (ansi-stream-in stream) #'closed-flame))
  92        (or (not (eq (ansi-stream-out stream) #'ill-out))
  93            (not (eq (ansi-stream-bout stream) #'ill-bout)))))
  94
  95 (defun output-stream-p (stream)
  96   (declare (type stream stream))
  97
  98   (and (ansi-stream-p stream)
  99        (ansi-stream-output-stream-p stream)))
 100
 101 (declaim (inline ansi-stream-open-stream-p))
 102 (defun ansi-stream-open-stream-p (stream)
 103   (declare (type ansi-stream stream))
 104   ;; CLHS 22.1.4 lets us not worry about synonym streams here.
 105   (not (eq (ansi-stream-in stream) #'closed-flame)))
 106
 107 (defun open-stream-p (stream)
 108   (ansi-stream-open-stream-p stream))
 109
 110 (declaim (inline ansi-stream-element-type))
 111 (defun ansi-stream-element-type (stream)
 112   (declare (type ansi-stream stream))
 113   (funcall (ansi-stream-misc stream) stream :element-type))
 114
 115 (defun stream-element-type (stream)
 116   (ansi-stream-element-type stream))
 117
 118 (defun interactive-stream-p (stream)
 119   (declare (type stream stream))
 120   (funcall (ansi-stream-misc stream) stream :interactive-p))
 121
 122 (declaim (inline ansi-stream-close))
 123 (defun ansi-stream-close (stream abort)
 124   (declare (type ansi-stream stream))
 125   (when (open-stream-p stream)
 126     (funcall (ansi-stream-misc stream) stream :close abort))
 127   t)
 128
 129 (defun close (stream &key abort)
 130   (ansi-stream-close stream abort))
 131
 132 (defun set-closed-flame (stream)
 133   (setf (ansi-stream-in stream) #'closed-flame)
 134   (setf (ansi-stream-bin stream) #'closed-flame)
 135   (setf (ansi-stream-n-bin stream) #'closed-flame)
 136   (setf (ansi-stream-in stream) #'closed-flame)
 137   (setf (ansi-stream-out stream) #'closed-flame)
 138   (setf (ansi-stream-bout stream) #'closed-flame)
 139   (setf (ansi-stream-sout stream) #'closed-flame)
 140   (setf (ansi-stream-misc stream) #'closed-flame))
 141 \f
 142 ;;;; file position and file length
 143
 144 ;;; Call the MISC method with the :FILE-POSITION operation.
 145 #!-sb-fluid (declaim (inline ansi-stream-file-position))
 146 (defun ansi-stream-file-position (stream position)
 147   (declare (type stream stream))
 148   (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
 149                  position))
 150   (cond
 151     (position
 152      (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 153      (funcall (ansi-stream-misc stream) stream :file-position position))
 154     (t
 155      (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
 156        (when res
 157          (- res
 158             (- +ansi-stream-in-buffer-length+
 159                (ansi-stream-in-index stream))))))))
 160
 161
 162 (defun file-position (stream &optional position)
 163   (ansi-stream-file-position stream position))
 164
 165 ;;; This is a literal translation of the ANSI glossary entry "stream
 166 ;;; associated with a file".
 167 ;;;
 168 ;;; KLUDGE: Note that since Unix famously thinks "everything is a
 169 ;;; file", and in particular stdin, stdout, and stderr are files, we
 170 ;;; end up with this test being satisfied for weird things like
 171 ;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the
 172 ;;; ANSI spec really had in mind, especially since this is used as a
 173 ;;; qualification for operations like FILE-LENGTH (so that ANSI was
 174 ;;; probably thinking of something like what Unix calls block devices)
 175 ;;; but I can't see any better way to do it. -- WHN 2001-04-14
 176 (defun stream-associated-with-file-p (x)
 177   "Test for the ANSI concept \"stream associated with a file\"."
 178   (or (typep x 'file-stream)
 179       (and (synonym-stream-p x)
 180            (stream-associated-with-file-p (symbol-value
 181                                            (synonym-stream-symbol x))))))
 182
 183 (defun stream-must-be-associated-with-file (stream)
 184   (declare (type stream stream))
 185   (unless (stream-associated-with-file-p stream)
 186     (error 'simple-type-error
 187            ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
 188            ;; this should be TYPE-ERROR. But what then can we use for
 189            ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
 190            ;; private predicate function..) is ugly and confusing, but
 191            ;; I can't see any other way. -- WHN 2001-04-14
 192            :expected-type '(satisfies stream-associated-with-file-p)
 193            :format-control
 194            "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
 195            :format-arguments (list stream))))
 196
 197 ;;; like FILE-POSITION, only using :FILE-LENGTH
 198 (defun file-length (stream)
 199   ;; FIXME: The following declaration uses yet undefined types, which
 200   ;; cause cross-compiler hangup.
 201   ;;
 202   ;; (declare (type (or file-stream synonym-stream) stream))
 203   (stream-must-be-associated-with-file stream)
 204   (funcall (ansi-stream-misc stream) stream :file-length))
 205 \f
 206 ;;;; input functions
 207
 208 #!-sb-fluid (declaim (inline ansi-stream-read-line))
 209 (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
 210   (declare (ignore recursive-p))
 211   (prepare-for-fast-read-char stream
 212           (let ((res (make-string 80))
 213                 (len 80)
 214                 (index 0))
 215             (loop
 216              (let ((ch (fast-read-char nil nil)))
 217                (cond (ch
 218                       (when (char= ch #\newline)
 219                         (done-with-fast-read-char)
 220                         (return (values (shrink-vector res index) nil)))
 221                       (when (= index len)
 222                         (setq len (* len 2))
 223                         (let ((new (make-string len)))
 224                           (replace new res)
 225                           (setq res new)))
 226                       (setf (schar res index) ch)
 227                       (incf index))
 228                      ((zerop index)
 229                       (done-with-fast-read-char)
 230                       (return (values (eof-or-lose stream
 231                                                    eof-error-p
 232                                                    eof-value)
 233                                       t)))
 234                      ;; Since FAST-READ-CHAR already hit the eof char, we
 235                      ;; shouldn't do another READ-CHAR.
 236                      (t
 237                       (done-with-fast-read-char)
 238                       (return (values (shrink-vector res index) t)))))))))
 239
 240 (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
 241                             recursive-p)
 242   (let ((stream (in-synonym-of stream)))
 243     (if (ansi-stream-p stream)
 244         (ansi-stream-read-line stream eof-error-p eof-value recursive-p)
 245         ;; must be Gray streams FUNDAMENTAL-STREAM
 246         (multiple-value-bind (string eof) (stream-read-line stream)
 247           (if (and eof (zerop (length string)))
 248               (values (eof-or-lose stream eof-error-p eof-value) t)
 249               (values string eof))))))
 250
 251 ;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on,
 252 ;;; so, except in this file, they are not inline by default, but they can be.
 253 #!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
 254
 255 #!-sb-fluid (declaim (inline ansi-stream-read-char))
 256 (defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p)
 257   (declare (ignore recursive-p))
 258   (prepare-for-fast-read-char stream
 259     (prog1
 260         (fast-read-char eof-error-p eof-value)
 261       (done-with-fast-read-char))))
 262
 263 (defun read-char (&optional (stream *standard-input*)
 264                             (eof-error-p t)
 265                             eof-value
 266                             recursive-p)
 267   (let ((stream (in-synonym-of stream)))
 268     (if (ansi-stream-p stream)
 269         (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
 270         ;; must be Gray streams FUNDAMENTAL-STREAM
 271         (let ((char (stream-read-char stream)))
 272           (if (eq char :eof)
 273               (eof-or-lose stream eof-error-p eof-value)
 274               char)))))
 275
 276 #!-sb-fluid (declaim (inline ansi-stream-unread-char))
 277 (defun ansi-stream-unread-char (character stream)
 278   (let ((index (1- (ansi-stream-in-index stream)))
 279         (buffer (ansi-stream-cin-buffer stream)))
 280     (declare (fixnum index))
 281     (when (minusp index) (error "nothing to unread"))
 282     (cond (buffer
 283            (setf (aref buffer index) character)
 284            (setf (ansi-stream-in-index stream) index))
 285           (t
 286            (funcall (ansi-stream-misc stream) stream
 287                     :unread character)))))
 288
 289 (defun unread-char (character &optional (stream *standard-input*))
 290   (let ((stream (in-synonym-of stream)))
 291     (if (ansi-stream-p stream)
 292         (ansi-stream-unread-char character stream)
 293         ;; must be Gray streams FUNDAMENTAL-STREAM
 294         (stream-unread-char stream character)))
 295   nil)
 296
 297 #!-sb-fluid (declaim (inline ansi-stream-listen))
 298 (defun ansi-stream-listen (stream)
 299   (or (/= (the fixnum (ansi-stream-in-index stream))
 300           +ansi-stream-in-buffer-length+)
 301       ;; Test for T explicitly since misc methods return :EOF sometimes.
 302       (eq (funcall (ansi-stream-misc stream) stream :listen) t)))
 303
 304 (defun listen (&optional (stream *standard-input*))
 305   (let ((stream (in-synonym-of stream)))
 306     (if (ansi-stream-p stream)
 307         (ansi-stream-listen stream)
 308         ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
 309         (stream-listen stream))))
 310
 311 #!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang))
 312 (defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p)
 313   (if (funcall (ansi-stream-misc stream) stream :listen)
 314       ;; On T or :EOF get READ-CHAR to do the work.
 315       (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
 316       nil))
 317
 318 (defun read-char-no-hang (&optional (stream *standard-input*)
 319                                     (eof-error-p t)
 320                                     eof-value
 321                                     recursive-p)
 322   (let ((stream (in-synonym-of stream)))
 323     (if (ansi-stream-p stream)
 324         (ansi-stream-read-char-no-hang stream eof-error-p eof-value
 325                                        recursive-p)
 326         ;; must be Gray streams FUNDAMENTAL-STREAM
 327         (let ((char (stream-read-char-no-hang stream)))
 328           (if (eq char :eof)
 329               (eof-or-lose stream eof-error-p eof-value)
 330               char)))))
 331
 332 #!-sb-fluid (declaim (inline ansi-stream-clear-input))
 333 (defun ansi-stream-clear-input (stream)
 334   (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 335   (funcall (ansi-stream-misc stream) stream :clear-input))
 336
 337 (defun clear-input (&optional (stream *standard-input*))
 338   (let ((stream (in-synonym-of stream)))
 339     (if (ansi-stream-p stream)
 340         (ansi-stream-clear-input stream)
 341         ;; must be Gray streams FUNDAMENTAL-STREAM
 342         (stream-clear-input stream)))
 343   nil)
 344 \f
 345 #!-sb-fluid (declaim (inline ansi-stream-read-byte))
 346 (defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p)
 347   ;; Why the "recursive-p" parameter?  a-s-r-b is funcall'ed from
 348   ;; a-s-read-sequence and needs a lambda list that's congruent with
 349   ;; that of a-s-read-char
 350   (declare (ignore recursive-p))
 351   (prepare-for-fast-read-byte stream
 352     (prog1
 353         (fast-read-byte eof-error-p eof-value t)
 354       (done-with-fast-read-byte))))
 355
 356 (defun read-byte (stream &optional (eof-error-p t) eof-value)
 357   (let ((stream (in-synonym-of stream)))
 358     (if (ansi-stream-p stream)
 359         (ansi-stream-read-byte stream eof-error-p eof-value nil)
 360         ;; must be Gray streams FUNDAMENTAL-STREAM
 361         (let ((char (stream-read-byte stream)))
 362           (if (eq char :eof)
 363               (eof-or-lose stream eof-error-p eof-value)
 364               char)))))
 365
 366 ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
 367 ;;; number of bytes read.
 368 ;;;
 369 ;;; Note: CMU CL's version of this had a special interpretation of
 370 ;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL
 371 ;;; case, CMU CL's version would return as soon as any data became
 372 ;;; available.) This could be useful behavior for things like pipes in
 373 ;;; some cases, but it wasn't being used in SBCL, so it was dropped.
 374 ;;; If we ever need it, it could be added later as a new variant N-BIN
 375 ;;; method (perhaps N-BIN-ASAP?) or something.
 376 (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
 377   (declare (type ansi-stream stream)
 378            (type index numbytes start)
 379            (type (or (simple-array * (*)) system-area-pointer) buffer))
 380   (let* ((stream (in-synonym-of stream ansi-stream))
 381          (in-buffer (ansi-stream-in-buffer stream))
 382          (index (ansi-stream-in-index stream))
 383          (num-buffered (- +ansi-stream-in-buffer-length+ index)))
 384     (declare (fixnum index num-buffered))
 385     (cond
 386      ((not in-buffer)
 387       (funcall (ansi-stream-n-bin stream)
 388                stream
 389                buffer
 390                start
 391                numbytes
 392                eof-error-p))
 393      ((<= numbytes num-buffered)
 394       (%byte-blt in-buffer index
 395                  buffer start (+ start numbytes))
 396       (setf (ansi-stream-in-index stream) (+ index numbytes))
 397       numbytes)
 398      (t
 399       (let ((end (+ start num-buffered)))
 400         (%byte-blt in-buffer index buffer start end)
 401         (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 402         (+ (funcall (ansi-stream-n-bin stream)
 403                     stream
 404                     buffer
 405                     end
 406                     (- numbytes num-buffered)
 407                     eof-error-p)
 408            num-buffered))))))
 409
 410 ;;; the amount of space we leave at the start of the in-buffer for
 411 ;;; unreading
 412 ;;;
 413 ;;; (It's 4 instead of 1 to allow word-aligned copies.)
 414 (defconstant +ansi-stream-in-buffer-extra+
 415   4) ; FIXME: should be symbolic constant
 416
 417 ;;; This function is called by the FAST-READ-CHAR expansion to refill
 418 ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
 419 ;;; and hence must be an N-BIN method.
 420 (defun fast-read-char-refill (stream eof-error-p eof-value)
 421   (let* ((ibuf (ansi-stream-cin-buffer stream))
 422          (count (funcall (ansi-stream-n-bin stream)
 423                          stream
 424                          ibuf
 425                          +ansi-stream-in-buffer-extra+
 426                          (- +ansi-stream-in-buffer-length+
 427                             +ansi-stream-in-buffer-extra+)
 428                          nil))
 429          (start (- +ansi-stream-in-buffer-length+ count)))
 430     (declare (type index start count))
 431     (cond ((zerop count)
 432            (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 433            (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
 434           (t
 435            (when (/= start +ansi-stream-in-buffer-extra+)
 436              (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
 437                                        sb!vm:n-byte-bits)
 438                                     (* sb!vm:vector-data-offset
 439                                        sb!vm:n-word-bits))
 440                             ibuf (+ (the index (* start sb!vm:n-byte-bits))
 441                                     (* sb!vm:vector-data-offset
 442                                        sb!vm:n-word-bits))
 443                             (* count sb!vm:n-byte-bits)))
 444            (setf (ansi-stream-in-index stream) (1+ start))
 445            (aref ibuf start)))))
 446
 447 ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
 448 ;;; leave room for unreading.
 449 (defun fast-read-byte-refill (stream eof-error-p eof-value)
 450   (let* ((ibuf (ansi-stream-in-buffer stream))
 451          (count (funcall (ansi-stream-n-bin stream) stream
 452                          ibuf 0 +ansi-stream-in-buffer-length+
 453                          nil))
 454          (start (- +ansi-stream-in-buffer-length+ count)))
 455     (declare (type index start count))
 456     (cond ((zerop count)
 457            (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 458            (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
 459           (t
 460            (unless (zerop start)
 461              (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
 462                             ibuf (+ (the index (* start sb!vm:n-byte-bits))
 463                                     (* sb!vm:vector-data-offset
 464                                        sb!vm:n-word-bits))
 465                             (* count sb!vm:n-byte-bits)))
 466            (setf (ansi-stream-in-index stream) (1+ start))
 467            (aref ibuf start)))))
 468 \f
 469 ;;; output functions
 470
 471 (defun write-char (character &optional (stream *standard-output*))
 472   (with-out-stream stream (ansi-stream-out character)
 473                    (stream-write-char character))
 474   character)
 475
 476 (defun terpri (&optional (stream *standard-output*))
 477   (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
 478   nil)
 479
 480 #!-sb-fluid (declaim (inline ansi-stream-fresh-line))
 481 (defun ansi-stream-fresh-line (stream)
 482   (when (/= (or (charpos stream) 1) 0)
 483     (funcall (ansi-stream-out stream) stream #\newline)
 484     t))
 485
 486 (defun fresh-line (&optional (stream *standard-output*))
 487   (let ((stream (out-synonym-of stream)))
 488     (if (ansi-stream-p stream)
 489         (ansi-stream-fresh-line stream)
 490         ;; must be Gray streams FUNDAMENTAL-STREAM
 491         (stream-fresh-line stream))))
 492
 493 (defun write-string (string &optional (stream *standard-output*)
 494                             &key (start 0) end)
 495   (declare (type string string))
 496   ;; Note that even though you might expect, based on the behavior of
 497   ;; things like AREF, that the correct upper bound here is
 498   ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
 499   ;; "bounding index" and "length" indicate that in this case (i.e.
 500   ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
 501   ;; (LENGTH STRING) is the required upper bound. A foolish
 502   ;; consistency is the hobgoblin of lesser languages..
 503   (%write-string string stream start (%check-vector-sequence-bounds
 504                                       string start end))
 505   string)
 506
 507 #!-sb-fluid (declaim (inline ansi-stream-write-string))
 508 (defun ansi-stream-write-string (string stream start end)
 509   (declare (type string string))
 510   (declare (type ansi-stream stream))
 511   (declare (type index start end))
 512   (if (array-header-p string)
 513       (with-array-data ((data string) (offset-start start)
 514                         (offset-end end))
 515         (funcall (ansi-stream-sout stream)
 516                  stream data offset-start offset-end))
 517       (funcall (ansi-stream-sout stream) stream string start end))
 518   string)
 519
 520 (defun %write-string (string stream start end)
 521   (declare (type string string))
 522   (declare (type stream-designator stream))
 523   (declare (type index start end))
 524   (let ((stream (out-synonym-of stream)))
 525     (if(ansi-stream-p stream)
 526        (ansi-stream-write-string string stream start end)
 527        ;; must be Gray streams FUNDAMENTAL-STREAM
 528        (stream-write-string stream string start end))))
 529
 530 ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
 531 ;;; which cannot deal with keyword arguments.
 532 (declaim (inline write-string-no-key))
 533 (defun write-string-no-key (string stream start end)
 534   (write-string string stream :start start :end end))
 535
 536 (defun write-line (string &optional (stream *standard-output*)
 537                           &key (start 0) end)
 538   (declare (type string string))
 539   ;; FIXME: Why is there this difference between the treatments of the
 540   ;; STREAM argument in WRITE-STRING and WRITE-LINE?
 541   (let ((defaulted-stream (out-synonym-of stream)))
 542     (%write-string string defaulted-stream start (%check-vector-sequence-bounds
 543                                                   string start end))
 544     (write-char #\newline defaulted-stream))
 545   string)
 546
 547 (defun charpos (&optional (stream *standard-output*))
 548   (with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column)))
 549
 550 (defun line-length (&optional (stream *standard-output*))
 551   (with-out-stream stream (ansi-stream-misc :line-length)
 552                    (stream-line-length)))
 553
 554 (defun finish-output (&optional (stream *standard-output*))
 555   (with-out-stream stream (ansi-stream-misc :finish-output)
 556                    (stream-finish-output))
 557   nil)
 558
 559 (defun force-output (&optional (stream *standard-output*))
 560   (with-out-stream stream (ansi-stream-misc :force-output)
 561                    (stream-force-output))
 562   nil)
 563
 564 (defun clear-output (&optional (stream *standard-output*))
 565   (with-out-stream stream (ansi-stream-misc :clear-output)
 566                    (stream-force-output))
 567   nil)
 568
 569 (defun write-byte (integer stream)
 570   (with-out-stream stream (ansi-stream-bout integer)
 571                    (stream-write-byte integer))
 572   integer)
 573 \f
 574
 575 ;;; (These were inline throughout this file, but that's not appropriate
 576 ;;; globally.  And we must not inline them in the rest of this file if
 577 ;;; dispatch to gray or simple streams is to work, since both redefine
 578 ;;; these functions later.)
 579 (declaim (notinline read-char unread-char read-byte listen))
 580
 581 ;;; This is called from ANSI-STREAM routines that encapsulate CLOS
 582 ;;; streams to handle the misc routines and dispatch to the
 583 ;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions.
 584 (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
 585   (declare (type stream stream) (ignore arg2))
 586   (ecase operation
 587     (:listen
 588      ;; Return T if input available, :EOF for end-of-file, otherwise NIL.
 589      (let ((char (read-char-no-hang stream nil :eof)))
 590        (when (characterp char)
 591          (unread-char char stream))
 592        char))
 593     (:unread
 594      (unread-char arg1 stream))
 595     (:close
 596      (close stream))
 597     (:clear-input
 598      (clear-input stream))
 599     (:force-output
 600      (force-output stream))
 601     (:finish-output
 602      (finish-output stream))
 603     (:element-type
 604      (stream-element-type stream))
 605     (:interactive-p
 606      (interactive-stream-p stream))
 607     (:line-length
 608      (line-length stream))
 609     (:charpos
 610      (charpos stream))
 611     (:file-length
 612      (file-length stream))
 613     (:file-position
 614      (file-position stream arg1))))
 615 \f
 616 ;;;; broadcast streams
 617
 618 (defstruct (broadcast-stream (:include ansi-stream
 619                                        (out #'broadcast-out)
 620                                        (bout #'broadcast-bout)
 621                                        (sout #'broadcast-sout)
 622                                        (misc #'broadcast-misc))
 623                              (:constructor %make-broadcast-stream
 624                                            (&rest streams))
 625                              (:copier nil))
 626   ;; a list of all the streams we broadcast to
 627   (streams () :type list :read-only t))
 628
 629 (defun make-broadcast-stream (&rest streams)
 630   (dolist (stream streams)
 631     (unless (output-stream-p stream)
 632       (error 'type-error
 633              :datum stream
 634              :expected-type '(satisfies output-stream-p))))
 635   (apply #'%make-broadcast-stream streams))
 636
 637 (macrolet ((out-fun (name fun &rest args)
 638              `(defun ,name (stream ,@args)
 639                 (dolist (stream (broadcast-stream-streams stream))
 640                   (,fun ,(car args) stream ,@(cdr args))))))
 641   (out-fun broadcast-out write-char char)
 642   (out-fun broadcast-bout write-byte byte)
 643   (out-fun broadcast-sout write-string-no-key string start end))
 644
 645 (defun broadcast-misc (stream operation &optional arg1 arg2)
 646   (let ((streams (broadcast-stream-streams stream)))
 647     (case operation
 648       ;; FIXME: This may not be the best place to note this, but I
 649       ;; think the :CHARPOS protocol needs revision.  Firstly, I think
 650       ;; this is the last place where a NULL return value was possible
 651       ;; (before adjusting it to be 0), so a bunch of conditionals IF
 652       ;; CHARPOS can be removed; secondly, it is my belief that
 653       ;; FD-STREAMS, when running FILE-POSITION, do not update the
 654       ;; CHARPOS, and consequently there will be much wrongness.
 655       ;;
 656       ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why
 657       ;; is it testing the :charpos of an input stream?
 658       ;;
 659       ;; -- CSR, 2004-02-04
 660       (:charpos
 661        (dolist (stream streams 0)
 662          (let ((charpos (charpos stream)))
 663            (if charpos (return charpos)))))
 664       (:line-length
 665        (let ((min nil))
 666          (dolist (stream streams min)
 667            (let ((res (line-length stream)))
 668              (when res (setq min (if min (min res min) res)))))))
 669       (:element-type
 670        #+nil ; old, arguably more logical, version
 671        (let (res)
 672          (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
 673            (pushnew (stream-element-type stream) res :test #'equal)))
 674        ;; ANSI-specified version (under System Class BROADCAST-STREAM)
 675        (let ((res t))
 676          (do ((streams streams (cdr streams)))
 677              ((null streams) res)
 678            (when (null (cdr streams))
 679              (setq res (stream-element-type (car streams)))))))
 680       (:file-position
 681        (if arg1
 682            (let ((res (or (eql arg1 :start) (eql arg1 0))))
 683              (dolist (stream streams res)
 684                (setq res (file-position stream arg1))))
 685            (let ((res 0))
 686              (dolist (stream streams res)
 687                (setq res (file-position stream))))))
 688       (:close
 689        (set-closed-flame stream))
 690       (t
 691        (let ((res nil))
 692          (dolist (stream streams res)
 693            (setq res
 694                  (if (ansi-stream-p stream)
 695                      (funcall (ansi-stream-misc stream) stream operation
 696                               arg1 arg2)
 697                      (stream-misc-dispatch stream operation arg1 arg2)))))))))
 698 \f
 699 ;;;; synonym streams
 700
 701 (defstruct (synonym-stream (:include ansi-stream
 702                                      (in #'synonym-in)
 703                                      (bin #'synonym-bin)
 704                                      (n-bin #'synonym-n-bin)
 705                                      (out #'synonym-out)
 706                                      (bout #'synonym-bout)
 707                                      (sout #'synonym-sout)
 708                                      (misc #'synonym-misc))
 709                            (:constructor make-synonym-stream (symbol))
 710                            (:copier nil))
 711   ;; This is the symbol, the value of which is the stream we are synonym to.
 712   (symbol nil :type symbol :read-only t))
 713 (def!method print-object ((x synonym-stream) stream)
 714   (print-unreadable-object (x stream :type t :identity t)
 715     (format stream ":SYMBOL ~S" (synonym-stream-symbol x))))
 716
 717 ;;; The output simple output methods just call the corresponding
 718 ;;; function on the synonymed stream.
 719 (macrolet ((out-fun (name fun &rest args)
 720              `(defun ,name (stream ,@args)
 721                 (declare (optimize (safety 1)))
 722                 (let ((syn (symbol-value (synonym-stream-symbol stream))))
 723                   (,fun ,(car args) syn ,@(cdr args))))))
 724   (out-fun synonym-out write-char ch)
 725   (out-fun synonym-bout write-byte n)
 726   (out-fun synonym-sout write-string-no-key string start end))
 727
 728 ;;; For the input methods, we just call the corresponding function on the
 729 ;;; synonymed stream. These functions deal with getting input out of
 730 ;;; the In-Buffer if there is any.
 731 (macrolet ((in-fun (name fun &rest args)
 732              `(defun ,name (stream ,@args)
 733                 (declare (optimize (safety 1)))
 734                 (,fun (symbol-value (synonym-stream-symbol stream))
 735                       ,@args))))
 736   (in-fun synonym-in read-char eof-error-p eof-value)
 737   (in-fun synonym-bin read-byte eof-error-p eof-value)
 738   (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
 739
 740 (defun synonym-misc (stream operation &optional arg1 arg2)
 741   (declare (optimize (safety 1)))
 742   (let ((syn (symbol-value (synonym-stream-symbol stream))))
 743     (if (ansi-stream-p syn)
 744         ;; We have to special-case some operations which interact with
 745         ;; the in-buffer of the wrapped stream, since just calling
 746         ;; ANSI-STREAM-MISC on them
 747         (case operation
 748           (:listen (or (/= (the fixnum (ansi-stream-in-index syn))
 749                            +ansi-stream-in-buffer-length+)
 750                        (funcall (ansi-stream-misc syn) syn :listen)))
 751           (:clear-input (clear-input syn))
 752           (:unread (unread-char arg1 syn))
 753           (t
 754            (funcall (ansi-stream-misc syn) syn operation arg1 arg2)))
 755         (stream-misc-dispatch syn operation arg1 arg2))))
 756 \f
 757 ;;;; two-way streams
 758
 759 (defstruct (two-way-stream
 760             (:include ansi-stream
 761                       (in #'two-way-in)
 762                       (bin #'two-way-bin)
 763                       (n-bin #'two-way-n-bin)
 764                       (out #'two-way-out)
 765                       (bout #'two-way-bout)
 766                       (sout #'two-way-sout)
 767                       (misc #'two-way-misc))
 768             (:constructor %make-two-way-stream (input-stream output-stream))
 769             (:copier nil))
 770   (input-stream (missing-arg) :type stream :read-only t)
 771   (output-stream (missing-arg) :type stream :read-only t))
 772 (defprinter (two-way-stream) input-stream output-stream)
 773
 774 (defun make-two-way-stream (input-stream output-stream)
 775   #!+sb-doc
 776   "Return a bidirectional stream which gets its input from INPUT-STREAM and
 777    sends its output to OUTPUT-STREAM."
 778   ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
 779   ;; should be encapsulated in a function, and used here and most of
 780   ;; the other places that SYNONYM-STREAM-P appears.
 781   (unless (output-stream-p output-stream)
 782     (error 'type-error
 783            :datum output-stream
 784            :expected-type '(satisfies output-stream-p)))
 785   (unless (input-stream-p input-stream)
 786     (error 'type-error
 787            :datum input-stream
 788            :expected-type '(satisfies input-stream-p)))
 789   (funcall #'%make-two-way-stream input-stream output-stream))
 790
 791 (macrolet ((out-fun (name fun &rest args)
 792              `(defun ,name (stream ,@args)
 793                 (let ((syn (two-way-stream-output-stream stream)))
 794                   (,fun ,(car args) syn ,@(cdr args))))))
 795   (out-fun two-way-out write-char ch)
 796   (out-fun two-way-bout write-byte n)
 797   (out-fun two-way-sout write-string-no-key string start end))
 798
 799 (macrolet ((in-fun (name fun &rest args)
 800              `(defun ,name (stream ,@args)
 801                 (force-output (two-way-stream-output-stream stream))
 802                 (,fun (two-way-stream-input-stream stream) ,@args))))
 803   (in-fun two-way-in read-char eof-error-p eof-value)
 804   (in-fun two-way-bin read-byte eof-error-p eof-value)
 805   (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p))
 806
 807 (defun two-way-misc (stream operation &optional arg1 arg2)
 808   (let* ((in (two-way-stream-input-stream stream))
 809          (out (two-way-stream-output-stream stream))
 810          (in-ansi-stream-p (ansi-stream-p in))
 811          (out-ansi-stream-p (ansi-stream-p out)))
 812     (case operation
 813       (:listen
 814        (if in-ansi-stream-p
 815            (or (/= (the fixnum (ansi-stream-in-index in))
 816                    +ansi-stream-in-buffer-length+)
 817                (funcall (ansi-stream-misc in) in :listen))
 818            (stream-listen in)))
 819       ((:finish-output :force-output :clear-output)
 820        (if out-ansi-stream-p
 821            (funcall (ansi-stream-misc out) out operation arg1 arg2)
 822            (stream-misc-dispatch out operation arg1 arg2)))
 823       (:clear-input (clear-input in))
 824       (:unread (unread-char arg1 in))
 825       (:element-type
 826        (let ((in-type (stream-element-type in))
 827              (out-type (stream-element-type out)))
 828          (if (equal in-type out-type)
 829              in-type `(and ,in-type ,out-type))))
 830       (:close
 831        (set-closed-flame stream))
 832       (t
 833        (or (if in-ansi-stream-p
 834                (funcall (ansi-stream-misc in) in operation arg1 arg2)
 835                (stream-misc-dispatch in operation arg1 arg2))
 836            (if out-ansi-stream-p
 837                (funcall (ansi-stream-misc out) out operation arg1 arg2)
 838                (stream-misc-dispatch out operation arg1 arg2)))))))
 839 \f
 840 ;;;; concatenated streams
 841
 842 (defstruct (concatenated-stream
 843             (:include ansi-stream
 844                       (in #'concatenated-in)
 845                       (bin #'concatenated-bin)
 846                       (n-bin #'concatenated-n-bin)
 847                       (misc #'concatenated-misc))
 848             (:constructor %make-concatenated-stream (&rest streams))
 849             (:copier nil))
 850   ;; The car of this is the substream we are reading from now.
 851   (streams nil :type list))
 852 (def!method print-object ((x concatenated-stream) stream)
 853   (print-unreadable-object (x stream :type t :identity t)
 854     (format stream
 855             ":STREAMS ~S"
 856             (concatenated-stream-streams x))))
 857
 858 (defun make-concatenated-stream (&rest streams)
 859   #!+sb-doc
 860   "Return a stream which takes its input from each of the streams in turn,
 861    going on to the next at EOF."
 862   (dolist (stream streams)
 863     (unless (input-stream-p stream)
 864       (error 'type-error
 865              :datum stream
 866              :expected-type '(satisfies input-stream-p))))
 867   (apply #'%make-concatenated-stream streams))
 868
 869 (macrolet ((in-fun (name fun)
 870              `(defun ,name (stream eof-error-p eof-value)
 871                 (do ((streams (concatenated-stream-streams stream)
 872                               (cdr streams)))
 873                     ((null streams)
 874                      (eof-or-lose stream eof-error-p eof-value))
 875                   (let* ((stream (car streams))
 876                          (result (,fun stream nil nil)))
 877                     (when result (return result)))
 878                   (pop (concatenated-stream-streams stream))))))
 879   (in-fun concatenated-in read-char)
 880   (in-fun concatenated-bin read-byte))
 881
 882 (defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
 883   (do ((streams (concatenated-stream-streams stream) (cdr streams))
 884        (current-start start)
 885        (remaining-bytes numbytes))
 886       ((null streams)
 887        (if eof-errorp
 888            (error 'end-of-file :stream stream)
 889            (- numbytes remaining-bytes)))
 890     (let* ((stream (car streams))
 891            (bytes-read (read-n-bytes stream buffer current-start
 892                                      remaining-bytes nil)))
 893       (incf current-start bytes-read)
 894       (decf remaining-bytes bytes-read)
 895       (when (zerop remaining-bytes) (return numbytes)))
 896     (setf (concatenated-stream-streams stream) (cdr streams))))
 897
 898 (defun concatenated-misc (stream operation &optional arg1 arg2)
 899   (let* ((left (concatenated-stream-streams stream))
 900          (current (car left)))
 901     (case operation
 902       (:listen
 903        (unless left
 904          (return-from concatenated-misc :eof))
 905        (loop
 906         (let ((stuff (if (ansi-stream-p current)
 907                          (funcall (ansi-stream-misc current) current
 908                                   :listen)
 909                          (stream-misc-dispatch current :listen))))
 910           (cond ((eq stuff :eof)
 911                  ;; Advance STREAMS, and try again.
 912                  (pop (concatenated-stream-streams stream))
 913                  (setf current
 914                        (car (concatenated-stream-streams stream)))
 915                  (unless current
 916                    ;; No further streams. EOF.
 917                    (return :eof)))
 918                 (stuff
 919                  ;; Stuff's available.
 920                  (return t))
 921                 (t
 922                  ;; Nothing is available yet.
 923                  (return nil))))))
 924       (:clear-input (when left (clear-input current)))
 925       (:unread (when left (unread-char arg1 current)))
 926       (:close
 927        (set-closed-flame stream))
 928       (t
 929        (when left
 930          (if (ansi-stream-p current)
 931              (funcall (ansi-stream-misc current) current operation arg1 arg2)
 932              (stream-misc-dispatch current operation arg1 arg2)))))))
 933 \f
 934 ;;;; echo streams
 935
 936 (defstruct (echo-stream
 937             (:include two-way-stream
 938                       (in #'echo-in)
 939                       (bin #'echo-bin)
 940                       (misc #'echo-misc)
 941                       (n-bin #'echo-n-bin))
 942             (:constructor %make-echo-stream (input-stream output-stream))
 943             (:copier nil))
 944   unread-stuff)
 945 (def!method print-object ((x echo-stream) stream)
 946   (print-unreadable-object (x stream :type t :identity t)
 947     (format stream
 948             ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
 949             (two-way-stream-input-stream x)
 950             (two-way-stream-output-stream x))))
 951
 952 (defun make-echo-stream (input-stream output-stream)
 953   #!+sb-doc
 954   "Return a bidirectional stream which gets its input from INPUT-STREAM and
 955    sends its output to OUTPUT-STREAM. In addition, all input is echoed to
 956    the output stream."
 957   (unless (output-stream-p output-stream)
 958     (error 'type-error
 959            :datum output-stream
 960            :expected-type '(satisfies output-stream-p)))
 961   (unless (input-stream-p input-stream)
 962     (error 'type-error
 963            :datum input-stream
 964            :expected-type '(satisfies input-stream-p)))
 965   (funcall #'%make-echo-stream input-stream output-stream))
 966
 967 (macrolet ((in-fun (name in-fun out-fun &rest args)
 968              `(defun ,name (stream ,@args)
 969                 (or (pop (echo-stream-unread-stuff stream))
 970                     (let* ((in (echo-stream-input-stream stream))
 971                            (out (echo-stream-output-stream stream))
 972                            (result (if eof-error-p
 973                                        (,in-fun in ,@args)
 974                                        (,in-fun in nil in))))
 975                       (cond
 976                         ((eql result in) eof-value)
 977                         (t (,out-fun result out) result)))))))
 978   (in-fun echo-in read-char write-char eof-error-p eof-value)
 979   (in-fun echo-bin read-byte write-byte eof-error-p eof-value))
 980
 981 (defun echo-n-bin (stream buffer start numbytes eof-error-p)
 982   (let ((new-start start)
 983         (read 0))
 984     (loop
 985      (let ((thing (pop (echo-stream-unread-stuff stream))))
 986        (cond
 987          (thing
 988           (setf (aref buffer new-start) thing)
 989           (incf new-start)
 990           (incf read)
 991           (when (= read numbytes)
 992             (return-from echo-n-bin numbytes)))
 993          (t (return nil)))))
 994     (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
 995                                     new-start (- numbytes read) nil)))
 996       (cond
 997         ((not eof-error-p)
 998          (write-sequence buffer (echo-stream-output-stream stream)
 999                          :start new-start :end (+ new-start bytes-read))
1000          (+ bytes-read read))
1001         ((> numbytes (+ read bytes-read))
1002          (write-sequence buffer (echo-stream-output-stream stream)
1003                          :start new-start :end (+ new-start bytes-read))
1004          (error 'end-of-file :stream stream))
1005         (t
1006          (write-sequence buffer (echo-stream-output-stream stream)
1007                          :start new-start :end (+ new-start bytes-read))
1008          (aver (= numbytes (+ new-start bytes-read)))
1009          numbytes)))))
1010 \f
1011 ;;;; base STRING-STREAM stuff
1012
1013 (defstruct (string-stream
1014              (:include ansi-stream)
1015              (:constructor nil)
1016              (:copier nil))
1017   ;; FIXME: This type declaration is true, and will probably continue
1018   ;; to be true.  However, note well the comments in DEFTRANSFORM
1019   ;; REPLACE, implying that performance of REPLACE is somewhat
1020   ;; critical to performance of string streams.  If (VECTOR CHARACTER)
1021   ;; ever becomes different from (VECTOR BASE-CHAR), the transform
1022   ;; probably needs to be extended.
1023   (string (missing-arg) :type (vector character)))
1024 \f
1025 ;;;; STRING-INPUT-STREAM stuff
1026
1027 (defstruct (string-input-stream
1028              (:include string-stream
1029                        (in #'string-inch)
1030                        (bin #'ill-bin)
1031                        (n-bin #'string-stream-read-n-bytes)
1032                        (misc #'string-in-misc)
1033                        (string (missing-arg) :type simple-string))
1034              (:constructor internal-make-string-input-stream
1035                            (string current end))
1036              (:copier nil))
1037   (current (missing-arg) :type index)
1038   (end (missing-arg) :type index))
1039
1040 (defun string-inch (stream eof-error-p eof-value)
1041   (declare (type string-input-stream stream))
1042   (let ((string (string-input-stream-string stream))
1043         (index (string-input-stream-current stream)))
1044     (cond ((>= index (the index (string-input-stream-end stream)))
1045            (eof-or-lose stream eof-error-p eof-value))
1046           (t
1047            (setf (string-input-stream-current stream) (1+ index))
1048            (char string index)))))
1049
1050 (defun string-binch (stream eof-error-p eof-value)
1051   (declare (type string-input-stream stream))
1052   (let ((string (string-input-stream-string stream))
1053         (index (string-input-stream-current stream)))
1054     (cond ((>= index (the index (string-input-stream-end stream)))
1055            (eof-or-lose stream eof-error-p eof-value))
1056           (t
1057            (setf (string-input-stream-current stream) (1+ index))
1058            (char-code (char string index))))))
1059
1060 (defun string-stream-read-n-bytes (stream buffer start requested eof-error-p)
1061   (declare (type string-input-stream stream)
1062            (type index start requested))
1063   (let* ((string (string-input-stream-string stream))
1064          (index (string-input-stream-current stream))
1065          (available (- (string-input-stream-end stream) index))
1066          (copy (min available requested)))
1067     (declare (type simple-string string))
1068     (when (plusp copy)
1069       (setf (string-input-stream-current stream)
1070             (truly-the index (+ index copy)))
1071       (sb!sys:without-gcing
1072        (system-area-copy (vector-sap string)
1073                          (* index sb!vm:n-byte-bits)
1074                          (if (typep buffer 'system-area-pointer)
1075                              buffer
1076                              (vector-sap buffer))
1077                          (* start sb!vm:n-byte-bits)
1078                          (* copy sb!vm:n-byte-bits))))
1079     (if (and (> requested copy) eof-error-p)
1080         (error 'end-of-file :stream stream)
1081         copy)))
1082
1083 (defun string-in-misc (stream operation &optional arg1 arg2)
1084   (declare (type string-input-stream stream)
1085            (ignore arg2))
1086   (case operation
1087     (:file-position
1088      (if arg1
1089          (setf (string-input-stream-current stream)
1090                (case arg1
1091                  (:start 0)
1092                  (:end (string-input-stream-end stream))
1093                  ;; We allow moving position beyond EOF. Errors happen
1094                  ;; on read, not move -- or the user may extend the
1095                  ;; input string.
1096                  (t arg1)))
1097          (string-input-stream-current stream)))
1098     ;; According to ANSI: "Should signal an error of type type-error
1099     ;; if stream is not a stream associated with a file."
1100     ;; This is checked by FILE-LENGTH, so no need to do it here either.
1101     ;; (:file-length (length (string-input-stream-string stream)))
1102     (:unread (decf (string-input-stream-current stream)))
1103     (:close (set-closed-flame stream))
1104     (:listen (or (/= (the index (string-input-stream-current stream))
1105                      (the index (string-input-stream-end stream)))
1106                  :eof))
1107     (:element-type (array-element-type (string-input-stream-string stream)))))
1108
1109 (defun make-string-input-stream (string &optional (start 0) end)
1110   #!+sb-doc
1111   "Return an input stream which will supply the characters of STRING between
1112   START and END in order."
1113   (declare (type string string)
1114            (type index start)
1115            (type (or index null) end))
1116   (let* ((string (coerce string '(simple-array character (*))))
1117          (end (%check-vector-sequence-bounds string start end)))
1118     (with-array-data ((string string) (start start) (end end))
1119       (internal-make-string-input-stream
1120        string ;; now simple
1121        start
1122        end))))
1123 \f
1124 ;;;; STRING-OUTPUT-STREAM stuff
1125
1126 (defstruct (string-output-stream
1127             (:include string-stream
1128                       (out #'string-ouch)
1129                       (sout #'string-sout)
1130                       (misc #'string-out-misc)
1131                       ;; The string we throw stuff in.
1132                       (string (missing-arg)
1133                               :type (simple-array character (*))))
1134             (:constructor make-string-output-stream
1135                           (&key (element-type 'character)
1136                            &aux (string (make-string 40))))
1137             (:copier nil))
1138   ;; Index of the next location to use.
1139   (index 0 :type fixnum)
1140   ;; Index cache for string-output-stream-last-index
1141   (index-cache 0 :type fixnum)
1142   ;; Requested element type
1143   (element-type 'character))
1144
1145 #!+sb-doc
1146 (setf (fdocumentation 'make-string-output-stream 'function)
1147   "Return an output stream which will accumulate all output given it for
1148    the benefit of the function GET-OUTPUT-STREAM-STRING.")
1149
1150 (defun string-output-stream-last-index (stream)
1151   (max (string-output-stream-index stream)
1152        (string-output-stream-index-cache stream)))
1153
1154 (defun string-ouch (stream character)
1155   (let ((current (string-output-stream-index stream))
1156         (workspace (string-output-stream-string stream)))
1157     (declare (type (simple-array character (*)) workspace)
1158              (type fixnum current))
1159     (if (= current (the fixnum (length workspace)))
1160         (let ((new-workspace (make-string (* current 2))))
1161           (replace new-workspace workspace)
1162           (setf (aref new-workspace current) character
1163                 (string-output-stream-string stream) new-workspace))
1164         (setf (aref workspace current) character))
1165     (setf (string-output-stream-index stream) (1+ current))))
1166
1167 (defun string-sout (stream string start end)
1168   (declare (type simple-string string)
1169            (type fixnum start end))
1170   (let* ((string (if (typep string '(simple-array character (*)))
1171                      string
1172                      (coerce string '(simple-array character (*)))))
1173          (current (string-output-stream-index stream))
1174          (length (- end start))
1175          (dst-end (+ length current))
1176          (workspace (string-output-stream-string stream)))
1177     (declare (type (simple-array character (*)) workspace string)
1178              (type fixnum current length dst-end))
1179     (if (> dst-end (the fixnum (length workspace)))
1180         (let ((new-workspace (make-string (+ (* current 2) length))))
1181           (replace new-workspace workspace :end2 current)
1182           (replace new-workspace string
1183                    :start1 current :end1 dst-end
1184                    :start2 start :end2 end)
1185           (setf (string-output-stream-string stream) new-workspace))
1186         (replace workspace string
1187                  :start1 current :end1 dst-end
1188                  :start2 start :end2 end))
1189     (setf (string-output-stream-index stream) dst-end)))
1190
1191 (defun string-out-misc (stream operation &optional arg1 arg2)
1192   (declare (ignore arg2))
1193   (case operation
1194     (:file-position
1195      (if arg1
1196          (let ((end (string-output-stream-last-index stream)))
1197            (setf (string-output-stream-index-cache stream) end
1198                  (string-output-stream-index stream)
1199                  (case arg1
1200                    (:start 0)
1201                    (:end end)
1202                    (t
1203                     ;; We allow moving beyond the end of stream,
1204                     ;; implicitly extending the output stream.
1205                     (let ((buffer (string-output-stream-string stream)))
1206                       (when (> arg1 (length buffer))
1207                         (setf (string-output-stream-string stream)
1208                               (make-string
1209                                arg1 :element-type (array-element-type buffer))
1210                               (subseq (string-output-stream-string stream)
1211                                       0 end)
1212                               (subseq buffer 0 end))))
1213                       arg1))))
1214          (string-output-stream-index stream)))
1215     (:close (set-closed-flame stream))
1216     (:charpos
1217      (do ((index (1- (the fixnum (string-output-stream-index stream)))
1218                  (1- index))
1219           (count 0 (1+ count))
1220           (string (string-output-stream-string stream)))
1221          ((< index 0) count)
1222        (declare (type (simple-array character (*)) string)
1223                 (type fixnum index count))
1224        (if (char= (schar string index) #\newline)
1225            (return count))))
1226     (:element-type (array-element-type (string-output-stream-string stream)))))
1227
1228 ;;; Return a string of all the characters sent to a stream made by
1229 ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function.
1230 (defun get-output-stream-string (stream)
1231   (declare (type string-output-stream stream))
1232   (let* ((length (string-output-stream-last-index stream))
1233          (element-type (string-output-stream-element-type stream))
1234          (result
1235           (case element-type
1236             ;; Overwhelmingly common case; can be inlined.
1237             ((character) (make-string length))
1238             (t (make-string length :element-type element-type)))))
1239     ;; For the benefit of the REPLACE transform, let's do this, so
1240     ;; that the common case isn't ludicrously expensive.
1241     (etypecase result
1242       ((simple-array character (*))
1243        (replace result (string-output-stream-string stream)))
1244       ((simple-array nil (*))
1245        (replace result (string-output-stream-string stream))))
1246     (setf (string-output-stream-index stream) 0
1247           (string-output-stream-index-cache stream) 0)
1248     result))
1249
1250 ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
1251 ;;; GET-OUTPUT-STREAM-STRING would return them.
1252 (defun dump-output-stream-string (in-stream out-stream)
1253   (%write-string (string-output-stream-string in-stream)
1254                  out-stream
1255                  0
1256                  (string-output-stream-last-index in-stream))
1257   (setf (string-output-stream-index in-stream) 0
1258         (string-output-stream-index-cache in-stream) 0))
1259 \f
1260 ;;;; fill-pointer streams
1261
1262 ;;; Fill pointer STRING-OUTPUT-STREAMs are not explicitly mentioned in
1263 ;;; the CLM, but they are required for the implementation of
1264 ;;; WITH-OUTPUT-TO-STRING.
1265
1266 (deftype string-with-fill-pointer ()
1267   '(and (vector character)
1268         (satisfies array-has-fill-pointer-p)))
1269
1270 (defstruct (fill-pointer-output-stream
1271             (:include string-stream
1272                       (out #'fill-pointer-ouch)
1273                       (sout #'fill-pointer-sout)
1274                       (misc #'fill-pointer-misc)
1275                       ;; a string with a fill pointer where we stuff
1276                       ;; the stuff we write
1277                       (string (missing-arg)
1278                               :type string-with-fill-pointer
1279                               :read-only t))
1280             (:constructor make-fill-pointer-output-stream (string))
1281             (:copier nil)))
1282
1283 (defun fill-pointer-ouch (stream character)
1284   (let* ((buffer (fill-pointer-output-stream-string stream))
1285          (current (fill-pointer buffer))
1286          (current+1 (1+ current)))
1287     (declare (fixnum current))
1288     (with-array-data ((workspace buffer) (start) (end))
1289       (declare (type (simple-array character (*)) workspace))
1290       (let ((offset-current (+ start current)))
1291         (declare (fixnum offset-current))
1292         (if (= offset-current end)
1293             (let* ((new-length (1+ (* current 2)))
1294                    (new-workspace (make-string new-length)))
1295               (declare (simple-string new-workspace))
1296               (%byte-blt workspace start
1297                          new-workspace 0 current)
1298               (setf workspace new-workspace
1299                     offset-current current)
1300               (set-array-header buffer workspace new-length
1301                                 current+1 0 new-length nil))
1302             (setf (fill-pointer buffer) current+1))
1303         (setf (schar workspace offset-current) character)))
1304     current+1))
1305
1306 (defun fill-pointer-sout (stream string start end)
1307   (declare (simple-string string) (fixnum start end))
1308   (let* ((string (if (typep string '(simple-array character (*)))
1309                      string
1310                      (coerce string '(simple-array character (*)))))
1311          (buffer (fill-pointer-output-stream-string stream))
1312          (current (fill-pointer buffer))
1313          (string-len (- end start))
1314          (dst-end (+ string-len current)))
1315     (declare (fixnum current dst-end string-len))
1316     (with-array-data ((workspace buffer) (dst-start) (dst-length))
1317       (declare (type (simple-array character (*)) workspace))
1318       (let ((offset-dst-end (+ dst-start dst-end))
1319             (offset-current (+ dst-start current)))
1320         (declare (fixnum offset-dst-end offset-current))
1321         (if (> offset-dst-end dst-length)
1322             (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1323                    (new-workspace (make-string new-length)))
1324               (declare (type (simple-array character (*)) new-workspace))
1325               (%byte-blt workspace dst-start
1326                          new-workspace 0 current)
1327               (setf workspace new-workspace)
1328               (setf offset-current current)
1329               (setf offset-dst-end dst-end)
1330               (set-array-header buffer
1331                                 workspace
1332                                 new-length
1333                                 dst-end
1334                                 0
1335                                 new-length
1336                                 nil))
1337             (setf (fill-pointer buffer) dst-end))
1338         (%byte-blt string start
1339                    workspace offset-current offset-dst-end)))
1340     dst-end))
1341
1342 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1343   (declare (ignore arg2))
1344   (case operation
1345     (:file-position
1346      (let ((buffer (fill-pointer-output-stream-string stream)))
1347        (if arg1
1348            (setf (fill-pointer buffer)
1349                  (case arg1
1350                    (:start 0)
1351                    ;; Fill-pointer is always at fill-pointer we will
1352                    ;; make :END move to the end of the actual string.
1353                    (:end (array-total-size buffer))
1354                    ;; We allow moving beyond the end of string if the
1355                    ;; string is adjustable.
1356                    (t (when (>= arg1 (array-total-size buffer))
1357                         (if (adjustable-array-p buffer)
1358                             (adjust-array buffer arg1)
1359                             (error "Cannot move FILE-POSITION beyond the end ~
1360                                     of WITH-OUTPUT-TO-STRING stream ~
1361                                     constructed with non-adjustable string.")))
1362                       arg1)))
1363            (fill-pointer buffer))))
1364     (:charpos
1365      (let* ((buffer (fill-pointer-output-stream-string stream))
1366             (current (fill-pointer buffer)))
1367        (with-array-data ((string buffer) (start) (end current))
1368          (declare (simple-string string) (ignore start))
1369          (let ((found (position #\newline string :test #'char=
1370                                 :end end :from-end t)))
1371            (if found
1372                (- end (the fixnum found))
1373                current)))))
1374      (:element-type (array-element-type
1375                      (fill-pointer-output-stream-string stream)))))
1376 \f
1377 ;;;; indenting streams
1378
1379 (defstruct (indenting-stream (:include ansi-stream
1380                                        (out #'indenting-out)
1381                                        (sout #'indenting-sout)
1382                                        (misc #'indenting-misc))
1383                              (:constructor make-indenting-stream (stream))
1384                              (:copier nil))
1385   ;; the stream we're based on
1386   stream
1387   ;; how much we indent on each line
1388   (indentation 0))
1389
1390 #!+sb-doc
1391 (setf (fdocumentation 'make-indenting-stream 'function)
1392  "Return an output stream which indents its output by some amount.")
1393
1394 ;;; INDENTING-INDENT writes the correct number of spaces needed to indent
1395 ;;; output on the given STREAM based on the specified SUB-STREAM.
1396 (defmacro indenting-indent (stream sub-stream)
1397   ;; KLUDGE: bare magic number 60
1398   `(do ((i 0 (+ i 60))
1399         (indentation (indenting-stream-indentation ,stream)))
1400        ((>= i indentation))
1401      (%write-string
1402       #.(make-string 60 :initial-element #\Space)
1403       ,sub-stream
1404       0
1405       (min 60 (- indentation i)))))
1406
1407 ;;; INDENTING-OUT writes a character to an indenting stream.
1408 (defun indenting-out (stream char)
1409   (let ((sub-stream (indenting-stream-stream stream)))
1410     (write-char char sub-stream)
1411     (if (char= char #\newline)
1412         (indenting-indent stream sub-stream))))
1413
1414 ;;; INDENTING-SOUT writes a string to an indenting stream.
1415 (defun indenting-sout (stream string start end)
1416   (declare (simple-string string) (fixnum start end))
1417   (do ((i start)
1418        (sub-stream (indenting-stream-stream stream)))
1419       ((= i end))
1420     (let ((newline (position #\newline string :start i :end end)))
1421       (cond (newline
1422              (%write-string string sub-stream i (1+ newline))
1423              (indenting-indent stream sub-stream)
1424              (setq i (+ newline 1)))
1425             (t
1426              (%write-string string sub-stream i end)
1427              (setq i end))))))
1428
1429 ;;; INDENTING-MISC just treats just the :LINE-LENGTH message
1430 ;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
1431 ;;; the base stream minus the stream's indentation.
1432 (defun indenting-misc (stream operation &optional arg1 arg2)
1433   (let ((sub-stream (indenting-stream-stream stream)))
1434     (if (ansi-stream-p sub-stream)
1435         (let ((method (ansi-stream-misc sub-stream)))
1436           (case operation
1437             (:line-length
1438              (let ((line-length (funcall method sub-stream operation)))
1439                (if line-length
1440                    (- line-length (indenting-stream-indentation stream)))))
1441             (:charpos
1442              (let ((charpos (funcall method sub-stream operation)))
1443                (if charpos
1444                    (- charpos (indenting-stream-indentation stream)))))
1445             (t
1446              (funcall method sub-stream operation arg1 arg2))))
1447         ;; must be Gray streams FUNDAMENTAL-STREAM
1448         (case operation
1449           (:line-length
1450            (let ((line-length (stream-line-length sub-stream)))
1451              (if line-length
1452                  (- line-length (indenting-stream-indentation stream)))))
1453           (:charpos
1454            (let ((charpos (stream-line-column sub-stream)))
1455              (if charpos
1456                  (- charpos (indenting-stream-indentation stream)))))
1457           (t
1458            (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1459
1460 (declaim (maybe-inline read-char unread-char read-byte listen))
1461 \f
1462 ;;;; case frobbing streams, used by FORMAT ~(...~)
1463
1464 (defstruct (case-frob-stream
1465             (:include ansi-stream
1466                       (misc #'case-frob-misc))
1467             (:constructor %make-case-frob-stream (target out sout))
1468             (:copier nil))
1469   (target (missing-arg) :type stream))
1470
1471 (defun make-case-frob-stream (target kind)
1472   #!+sb-doc
1473   "Return a stream that sends all output to the stream TARGET, but modifies
1474    the case of letters, depending on KIND, which should be one of:
1475      :UPCASE - convert to upper case.
1476      :DOWNCASE - convert to lower case.
1477      :CAPITALIZE - convert the first letter of words to upper case and the
1478         rest of the word to lower case.
1479      :CAPITALIZE-FIRST - convert the first letter of the first word to upper
1480         case and everything else to lower case."
1481   (declare (type stream target)
1482            (type (member :upcase :downcase :capitalize :capitalize-first)
1483                  kind)
1484            (values stream))
1485   (if (case-frob-stream-p target)
1486       ;; If we are going to be writing to a stream that already does
1487       ;; case frobbing, why bother frobbing the case just so it can
1488       ;; frob it again?
1489       target
1490       (multiple-value-bind (out sout)
1491           (ecase kind
1492             (:upcase
1493              (values #'case-frob-upcase-out
1494                      #'case-frob-upcase-sout))
1495             (:downcase
1496              (values #'case-frob-downcase-out
1497                      #'case-frob-downcase-sout))
1498             (:capitalize
1499              (values #'case-frob-capitalize-out
1500                      #'case-frob-capitalize-sout))
1501             (:capitalize-first
1502              (values #'case-frob-capitalize-first-out
1503                      #'case-frob-capitalize-first-sout)))
1504         (%make-case-frob-stream target out sout))))
1505
1506 (defun case-frob-misc (stream op &optional arg1 arg2)
1507   (declare (type case-frob-stream stream))
1508   (case op
1509     (:close
1510      (set-closed-flame stream))
1511     (t
1512      (let ((target (case-frob-stream-target stream)))
1513        (if (ansi-stream-p target)
1514            (funcall (ansi-stream-misc target) target op arg1 arg2)
1515            (stream-misc-dispatch target op arg1 arg2))))))
1516
1517 (defun case-frob-upcase-out (stream char)
1518   (declare (type case-frob-stream stream)
1519            (type base-char char))
1520   (let ((target (case-frob-stream-target stream))
1521         (char (char-upcase char)))
1522     (if (ansi-stream-p target)
1523         (funcall (ansi-stream-out target) target char)
1524         (stream-write-char target char))))
1525
1526 (defun case-frob-upcase-sout (stream str start end)
1527   (declare (type case-frob-stream stream)
1528            (type simple-base-string str)
1529            (type index start)
1530            (type (or index null) end))
1531   (let* ((target (case-frob-stream-target stream))
1532          (len (length str))
1533          (end (or end len))
1534          (string (if (and (zerop start) (= len end))
1535                      (string-upcase str)
1536                      (nstring-upcase (subseq str start end))))
1537          (string-len (- end start)))
1538     (if (ansi-stream-p target)
1539         (funcall (ansi-stream-sout target) target string 0 string-len)
1540         (stream-write-string target string 0 string-len))))
1541
1542 (defun case-frob-downcase-out (stream char)
1543   (declare (type case-frob-stream stream)
1544            (type base-char char))
1545   (let ((target (case-frob-stream-target stream))
1546         (char (char-downcase char)))
1547     (if (ansi-stream-p target)
1548         (funcall (ansi-stream-out target) target char)
1549         (stream-write-char target char))))
1550
1551 (defun case-frob-downcase-sout (stream str start end)
1552   (declare (type case-frob-stream stream)
1553            (type simple-base-string str)
1554            (type index start)
1555            (type (or index null) end))
1556   (let* ((target (case-frob-stream-target stream))
1557          (len (length str))
1558          (end (or end len))
1559          (string (if (and (zerop start) (= len end))
1560                      (string-downcase str)
1561                      (nstring-downcase (subseq str start end))))
1562          (string-len (- end start)))
1563     (if (ansi-stream-p target)
1564         (funcall (ansi-stream-sout target) target string 0 string-len)
1565         (stream-write-string target string 0 string-len))))
1566
1567 (defun case-frob-capitalize-out (stream char)
1568   (declare (type case-frob-stream stream)
1569            (type base-char char))
1570   (let ((target (case-frob-stream-target stream)))
1571     (cond ((alphanumericp char)
1572            (let ((char (char-upcase char)))
1573              (if (ansi-stream-p target)
1574                  (funcall (ansi-stream-out target) target char)
1575                  (stream-write-char target char)))
1576            (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
1577            (setf (case-frob-stream-sout stream)
1578                  #'case-frob-capitalize-aux-sout))
1579           (t
1580            (if (ansi-stream-p target)
1581                (funcall (ansi-stream-out target) target char)
1582                (stream-write-char target char))))))
1583
1584 (defun case-frob-capitalize-sout (stream str start end)
1585   (declare (type case-frob-stream stream)
1586            (type simple-base-string str)
1587            (type index start)
1588            (type (or index null) end))
1589   (let* ((target (case-frob-stream-target stream))
1590          (str (subseq str start end))
1591          (len (length str))
1592          (inside-word nil))
1593     (dotimes (i len)
1594       (let ((char (schar str i)))
1595         (cond ((not (alphanumericp char))
1596                (setf inside-word nil))
1597               (inside-word
1598                (setf (schar str i) (char-downcase char)))
1599               (t
1600                (setf inside-word t)
1601                (setf (schar str i) (char-upcase char))))))
1602     (when inside-word
1603       (setf (case-frob-stream-out stream)
1604             #'case-frob-capitalize-aux-out)
1605       (setf (case-frob-stream-sout stream)
1606             #'case-frob-capitalize-aux-sout))
1607     (if (ansi-stream-p target)
1608         (funcall (ansi-stream-sout target) target str 0 len)
1609         (stream-write-string target str 0 len))))
1610
1611 (defun case-frob-capitalize-aux-out (stream char)
1612   (declare (type case-frob-stream stream)
1613            (type base-char char))
1614   (let ((target (case-frob-stream-target stream)))
1615     (cond ((alphanumericp char)
1616            (let ((char (char-downcase char)))
1617              (if (ansi-stream-p target)
1618                  (funcall (ansi-stream-out target) target char)
1619                  (stream-write-char target char))))
1620           (t
1621            (if (ansi-stream-p target)
1622                (funcall (ansi-stream-out target) target char)
1623                (stream-write-char target char))
1624            (setf (case-frob-stream-out stream)
1625                  #'case-frob-capitalize-out)
1626            (setf (case-frob-stream-sout stream)
1627                  #'case-frob-capitalize-sout)))))
1628
1629 (defun case-frob-capitalize-aux-sout (stream str start end)
1630   (declare (type case-frob-stream stream)
1631            (type simple-base-string str)
1632            (type index start)
1633            (type (or index null) end))
1634   (let* ((target (case-frob-stream-target stream))
1635          (str (subseq str start end))
1636          (len (length str))
1637          (inside-word t))
1638     (dotimes (i len)
1639       (let ((char (schar str i)))
1640         (cond ((not (alphanumericp char))
1641                (setf inside-word nil))
1642               (inside-word
1643                (setf (schar str i) (char-downcase char)))
1644               (t
1645                (setf inside-word t)
1646                (setf (schar str i) (char-upcase char))))))
1647     (unless inside-word
1648       (setf (case-frob-stream-out stream)
1649             #'case-frob-capitalize-out)
1650       (setf (case-frob-stream-sout stream)
1651             #'case-frob-capitalize-sout))
1652     (if (ansi-stream-p target)
1653         (funcall (ansi-stream-sout target) target str 0 len)
1654         (stream-write-string target str 0 len))))
1655
1656 (defun case-frob-capitalize-first-out (stream char)
1657   (declare (type case-frob-stream stream)
1658            (type base-char char))
1659   (let ((target (case-frob-stream-target stream)))
1660     (cond ((alphanumericp char)
1661            (let ((char (char-upcase char)))
1662              (if (ansi-stream-p target)
1663                  (funcall (ansi-stream-out target) target char)
1664                  (stream-write-char target char)))
1665            (setf (case-frob-stream-out stream)
1666                  #'case-frob-downcase-out)
1667            (setf (case-frob-stream-sout stream)
1668                  #'case-frob-downcase-sout))
1669           (t
1670            (if (ansi-stream-p target)
1671                (funcall (ansi-stream-out target) target char)
1672                (stream-write-char target char))))))
1673
1674 (defun case-frob-capitalize-first-sout (stream str start end)
1675   (declare (type case-frob-stream stream)
1676            (type simple-base-string str)
1677            (type index start)
1678            (type (or index null) end))
1679   (let* ((target (case-frob-stream-target stream))
1680          (str (subseq str start end))
1681          (len (length str)))
1682     (dotimes (i len)
1683       (let ((char (schar str i)))
1684         (when (alphanumericp char)
1685           (setf (schar str i) (char-upcase char))
1686           (do ((i (1+ i) (1+ i)))
1687               ((= i len))
1688             (setf (schar str i) (char-downcase (schar str i))))
1689           (setf (case-frob-stream-out stream)
1690                 #'case-frob-downcase-out)
1691           (setf (case-frob-stream-sout stream)
1692                 #'case-frob-downcase-sout)
1693           (return))))
1694     (if (ansi-stream-p target)
1695         (funcall (ansi-stream-sout target) target str 0 len)
1696         (stream-write-string target str 0 len))))
1697 \f
1698 ;;;; READ-SEQUENCE
1699
1700 (defun read-sequence (seq stream &key (start 0) end)
1701   #!+sb-doc
1702   "Destructively modify SEQ by reading elements from STREAM.
1703   That part of SEQ bounded by START and END is destructively modified by
1704   copying successive elements into it from STREAM. If the end of file
1705   for STREAM is reached before copying all elements of the subsequence,
1706   then the extra elements near the end of sequence are not updated, and
1707   the index of the next element is returned."
1708   (declare (type sequence seq)
1709            (type stream stream)
1710            (type index start)
1711            (type sequence-end end)
1712            (values index))
1713   (if (ansi-stream-p stream)
1714       (ansi-stream-read-sequence seq stream start end)
1715       ;; must be Gray streams FUNDAMENTAL-STREAM
1716       (stream-read-sequence stream seq start end)))
1717
1718 (defun ansi-stream-read-sequence (seq stream start %end)
1719   (declare (type sequence seq)
1720            (type ansi-stream stream)
1721            (type index start)
1722            (type sequence-end %end)
1723            (values index))
1724   (let ((end (or %end (length seq))))
1725     (declare (type index end))
1726     (etypecase seq
1727       (list
1728        (let ((read-function
1729               (if (subtypep (stream-element-type stream) 'character)
1730                   #'ansi-stream-read-char
1731                   #'ansi-stream-read-byte)))
1732          (do ((rem (nthcdr start seq) (rest rem))
1733               (i start (1+ i)))
1734              ((or (endp rem) (>= i end)) i)
1735            (declare (type list rem)
1736                     (type index i))
1737            (let ((el (funcall read-function stream nil :eof nil)))
1738              (when (eq el :eof)
1739                (return i))
1740              (setf (first rem) el)))))
1741       (vector
1742        (with-array-data ((data seq) (offset-start start) (offset-end end))
1743          (typecase data
1744            ((or (simple-array (unsigned-byte 8) (*))
1745                 (simple-array (signed-byte 8) (*)))
1746             (let* ((numbytes (- end start))
1747                    (bytes-read (read-n-bytes stream data offset-start
1748                                              numbytes nil)))
1749               (if (< bytes-read numbytes)
1750                   (+ start bytes-read)
1751                   end)))
1752            (t
1753             (let ((read-function
1754                    (if (subtypep (stream-element-type stream) 'character)
1755                        #'ansi-stream-read-char
1756                        #'ansi-stream-read-byte)))
1757               (do ((i offset-start (1+ i)))
1758                   ((>= i offset-end) end)
1759                 (declare (type index i))
1760                 (let ((el (funcall read-function stream nil :eof nil)))
1761                   (when (eq el :eof)
1762                     (return (+ start (- i offset-start))))
1763                   (setf (aref data i) el)))))))))))
1764 \f
1765 ;;;; WRITE-SEQUENCE
1766
1767 (defun write-sequence (seq stream &key (start 0) (end nil))
1768   #!+sb-doc
1769   "Write the elements of SEQ bounded by START and END to STREAM."
1770   (declare (type sequence seq)
1771            (type stream stream)
1772            (type index start)
1773            (type sequence-end end)
1774            (values sequence))
1775   (if (ansi-stream-p stream)
1776       (ansi-stream-write-sequence seq stream start end)
1777       ;; must be Gray-streams FUNDAMENTAL-STREAM
1778       (stream-write-sequence stream seq start end)))
1779
1780 (defun ansi-stream-write-sequence (seq stream start %end)
1781   (declare (type sequence seq)
1782            (type ansi-stream stream)
1783            (type index start)
1784            (type sequence-end %end)
1785            (values sequence))
1786   (let ((end (or %end (length seq))))
1787     (declare (type index end))
1788     (etypecase seq
1789       (list
1790        (let ((write-function
1791               (if (subtypep (stream-element-type stream) 'character)
1792                   ;; FIXME (rudi 2004-08-09): since we know we're an
1793                   ;; ansi stream here, we could replace these
1794                   ;; functions with ansi-stream-specific constructs
1795                   #'write-char
1796                   #'write-byte)))
1797          (do ((rem (nthcdr start seq) (rest rem))
1798               (i start (1+ i)))
1799              ((or (endp rem) (>= i end)) seq)
1800            (declare (type list rem)
1801                     (type index i))
1802            (funcall write-function (first rem) stream))))
1803       (string
1804        (%write-string seq stream start end))
1805       (vector
1806        (let ((write-function
1807               (if (subtypep (stream-element-type stream) 'character)
1808                   ;; FIXME (rudi 2004-08-09): since we know we're an
1809                   ;; ansi stream here, we could replace these
1810                   ;; functions with ansi-specific constructs
1811                   #'write-char
1812                   #'write-byte)))
1813          (do ((i start (1+ i)))
1814              ((>= i end) seq)
1815            (declare (type index i))
1816            (funcall write-function (aref seq i) stream)))))))
1817 \f
1818 ;;;; etc.