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