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 stream-element-type-stream-element-mode (element-type) 27 (cond ((or (not element-type) 28 (eq element-type t) 29 (eq element-type :default)) :bivalent) 30 ((or (eq element-type 'character) 31 (eq element-type 'base-char)) 32 'character) 33 ((memq element-type '(signed-byte unsigned-byte)) 34 element-type) 35 ((and (proper-list-of-length-p element-type 2) 36 (memq (car element-type) 37 '(signed-byte unsigned-byte))) 38 (car element-type)) 39 ((not (ignore-errors 40 (setf element-type 41 (type-or-nil-if-unknown element-type t)))) 42 :bivalent) 43 ((eq element-type *empty-type*) 44 :bivalent) 45 ((csubtypep element-type (specifier-type 'character)) 46 'character) 47 ((csubtypep element-type (specifier-type 'unsigned-byte)) 48 'unsigned-byte) 49 ((csubtypep element-type (specifier-type 'signed-byte)) 50 'signed-byte) 51 (t 52 :bivalent))) 53 54(defun ill-in (stream &rest ignore) 55 (declare (ignore ignore)) 56 (error 'simple-type-error 57 :datum stream 58 :expected-type '(satisfies input-stream-p) 59 :format-control "~S is not a character input stream." 60 :format-arguments (list stream))) 61(defun ill-out (stream &rest ignore) 62 (declare (ignore ignore)) 63 (error 'simple-type-error 64 :datum stream 65 :expected-type '(satisfies output-stream-p) 66 :format-control "~S is not a character output stream." 67 :format-arguments (list stream))) 68(defun ill-bin (stream &rest ignore) 69 (declare (ignore ignore)) 70 (error 'simple-type-error 71 :datum stream 72 :expected-type '(satisfies input-stream-p) 73 :format-control "~S is not a binary input stream." 74 :format-arguments (list stream))) 75(defun ill-bout (stream &rest ignore) 76 (declare (ignore ignore)) 77 (error 'simple-type-error 78 :datum stream 79 :expected-type '(satisfies output-stream-p) 80 :format-control "~S is not a binary output stream." 81 :format-arguments (list stream))) 82(defun closed-flame (stream &rest ignore) 83 (declare (ignore ignore)) 84 (error 'closed-stream-error :stream stream)) 85(defun no-op-placeholder (&rest ignore) 86 (declare (ignore ignore))) 87 88;;; stream manipulation functions 89 90;;; SYNONYM-STREAM type is needed by ANSI-STREAM-{INPUT,OUTPUT}-STREAM-P 91(defstruct (synonym-stream (:include ansi-stream 92 (in #'synonym-in) 93 (bin #'synonym-bin) 94 (n-bin #'synonym-n-bin) 95 (out #'synonym-out) 96 (bout #'synonym-bout) 97 (sout #'synonym-sout) 98 (misc #'synonym-misc)) 99 (:constructor make-synonym-stream (symbol)) 100 (:copier nil)) 101 ;; This is the symbol, the value of which is the stream we are synonym to. 102 (symbol nil :type symbol :read-only t)) 103(declaim (freeze-type synonym-stream)) 104 105(defun ansi-stream-input-stream-p (stream) 106 (declare (type ansi-stream stream)) 107 (if (synonym-stream-p stream) 108 (input-stream-p (symbol-value (synonym-stream-symbol stream))) 109 (and (not (eq (ansi-stream-in stream) #'closed-flame)) 110 ;;; KLUDGE: It's probably not good to have EQ tests on function 111 ;;; values like this. What if someone's redefined the function? 112 ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and 113 ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902 114 (or (not (eq (ansi-stream-in stream) #'ill-in)) 115 (not (eq (ansi-stream-bin stream) #'ill-bin)))))) 116 117;;; Temporary definition that gets overwritten by pcl/gray-streams 118(defun input-stream-p (stream) 119 (declare (type stream stream)) 120 (and (ansi-stream-p stream) 121 (ansi-stream-input-stream-p stream))) 122 123(defun ansi-stream-output-stream-p (stream) 124 (declare (type ansi-stream stream)) 125 (if (synonym-stream-p stream) 126 (output-stream-p (symbol-value (synonym-stream-symbol stream))) 127 (and (not (eq (ansi-stream-in stream) #'closed-flame)) 128 (or (not (eq (ansi-stream-out stream) #'ill-out)) 129 (not (eq (ansi-stream-bout stream) #'ill-bout)))))) 130 131;;; Temporary definition that gets overwritten by pcl/gray-streams 132(defun output-stream-p (stream) 133 (declare (type stream stream)) 134 (and (ansi-stream-p stream) 135 (ansi-stream-output-stream-p stream))) 136 137(declaim (inline ansi-stream-open-stream-p)) 138(defun ansi-stream-open-stream-p (stream) 139 (declare (type ansi-stream stream)) 140 ;; CLHS 22.1.4 lets us not worry about synonym streams here. 141 (not (eq (ansi-stream-in stream) #'closed-flame))) 142 143(defun open-stream-p (stream) 144 (ansi-stream-open-stream-p stream)) 145 146(declaim (inline ansi-stream-element-type)) 147(defun ansi-stream-element-type (stream) 148 (declare (type ansi-stream stream)) 149 (funcall (ansi-stream-misc stream) stream :element-type)) 150 151(defun stream-element-type (stream) 152 (ansi-stream-element-type stream)) 153 154(defun stream-external-format (stream) 155 (funcall (ansi-stream-misc stream) stream :external-format)) 156 157(defun interactive-stream-p (stream) 158 (declare (type stream stream)) 159 (funcall (ansi-stream-misc stream) stream :interactive-p)) 160 161(declaim (inline ansi-stream-close)) 162(defun ansi-stream-close (stream abort) 163 (declare (type ansi-stream stream)) 164 (when (open-stream-p stream) 165 (funcall (ansi-stream-misc stream) stream :close abort)) 166 t) 167 168(defun close (stream &key abort) 169 (ansi-stream-close stream abort)) 170 171(defun set-closed-flame (stream) 172 (setf (ansi-stream-in stream) #'closed-flame) 173 (setf (ansi-stream-bin stream) #'closed-flame) 174 (setf (ansi-stream-n-bin stream) #'closed-flame) 175 (setf (ansi-stream-out stream) #'closed-flame) 176 (setf (ansi-stream-bout stream) #'closed-flame) 177 (setf (ansi-stream-sout stream) #'closed-flame) 178 (setf (ansi-stream-misc stream) #'closed-flame)) 179 180;;;; for file position and file length 181(defun external-format-char-size (external-format) 182 (ef-char-size (get-external-format external-format))) 183 184;;; Call the MISC method with the :FILE-POSITION operation. 185#!-sb-fluid (declaim (inline ansi-stream-file-position)) 186(defun ansi-stream-file-position (stream position) 187 (declare (type stream stream)) 188 (declare (type (or index (alien sb!unix:unix-offset) (member nil :start :end)) 189 position)) 190 ;; FIXME: It would be good to comment on the stuff that is done here... 191 ;; FIXME: This doesn't look interrupt safe. 192 (cond 193 (position 194 (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) 195 (funcall (ansi-stream-misc stream) stream :file-position position)) 196 (t 197 (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil))) 198 (when res 199 #!-sb-unicode 200 (- res 201 (- +ansi-stream-in-buffer-length+ 202 (ansi-stream-in-index stream))) 203 #!+sb-unicode 204 (let ((char-size (if (fd-stream-p stream) 205 (fd-stream-char-size stream) 206 (external-format-char-size (stream-external-format stream))))) 207 (- res 208 (etypecase char-size 209 (function 210 (loop with buffer = (ansi-stream-cin-buffer stream) 211 with start = (ansi-stream-in-index stream) 212 for i from start below +ansi-stream-in-buffer-length+ 213 sum (funcall char-size (aref buffer i)))) 214 (fixnum 215 (* char-size 216 (- +ansi-stream-in-buffer-length+ 217 (ansi-stream-in-index stream)))))))))))) 218 219(defun file-position (stream &optional position) 220 (if (ansi-stream-p stream) 221 (ansi-stream-file-position stream position) 222 (stream-file-position stream position))) 223 224;;; This is a literal translation of the ANSI glossary entry "stream 225;;; associated with a file". 226;;; 227;;; KLUDGE: Note that since Unix famously thinks "everything is a 228;;; file", and in particular stdin, stdout, and stderr are files, we 229;;; end up with this test being satisfied for weird things like 230;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the 231;;; ANSI spec really had in mind, especially since this is used as a 232;;; qualification for operations like FILE-LENGTH (so that ANSI was 233;;; probably thinking of something like what Unix calls block devices) 234;;; but I can't see any better way to do it. -- WHN 2001-04-14 235(defun stream-associated-with-file-p (x) 236 #!+sb-doc 237 "Test for the ANSI concept \"stream associated with a file\"." 238 (or (typep x 'file-stream) 239 (and (synonym-stream-p x) 240 (stream-associated-with-file-p (symbol-value 241 (synonym-stream-symbol x)))))) 242 243(defun stream-must-be-associated-with-file (stream) 244 (declare (type stream stream)) 245 (unless (stream-associated-with-file-p stream) 246 (error 'simple-type-error 247 ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says 248 ;; this should be TYPE-ERROR. But what then can we use for 249 ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard 250 ;; private predicate function..) is ugly and confusing, but 251 ;; I can't see any other way. -- WHN 2001-04-14 252 :datum stream 253 :expected-type '(satisfies stream-associated-with-file-p) 254 :format-control 255 "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>" 256 :format-arguments (list stream)))) 257 258(defun file-string-length (stream object) 259 (funcall (ansi-stream-misc stream) stream :file-string-length object)) 260 261;;;; input functions 262 263(defun ansi-stream-read-line-from-frc-buffer (stream eof-error-p eof-value) 264 (prepare-for-fast-read-char stream 265 (declare (ignore %frc-method%)) 266 (declare (type ansi-stream-cin-buffer %frc-buffer%)) 267 (let ((chunks-total-length 0) 268 (chunks nil)) 269 (declare (type index chunks-total-length) 270 (list chunks)) 271 (labels ((refill-buffer () 272 (prog1 (fast-read-char-refill stream nil) 273 (setf %frc-index% (ansi-stream-in-index %frc-stream%)))) 274 (build-result (pos n-more-chars) 275 (let ((res (make-string (+ chunks-total-length n-more-chars))) 276 (start1 chunks-total-length)) 277 (declare (type index start1)) 278 (when (>= pos 0) 279 (replace res %frc-buffer% 280 :start1 start1 :start2 %frc-index% :end2 pos) 281 (setf %frc-index% (1+ pos))) 282 (done-with-fast-read-char) 283 (dolist (chunk chunks res) 284 (declare (type (simple-array character (*)) chunk)) 285 (decf start1 (length chunk)) 286 (replace res chunk :start1 start1))))) 287 (declare (inline refill-buffer)) 288 (if (or (< %frc-index% +ansi-stream-in-buffer-length+) (refill-buffer)) 289 (loop 290 (let ((pos (position #\Newline %frc-buffer% 291 :test #'char= :start %frc-index%))) 292 (when pos 293 (return (values (build-result pos (- pos %frc-index%)) nil))) 294 (let ((chunk (subseq %frc-buffer% %frc-index%))) 295 (incf chunks-total-length (length chunk)) 296 (push chunk chunks)) 297 (unless (refill-buffer) 298 (return (values (build-result -1 0) t))))) 299 ;; EOF had been reached before we read anything 300 ;; at all. Return the EOF value or signal the error. 301 (progn (done-with-fast-read-char) 302 (eof-or-lose stream eof-error-p (values eof-value t)))))))) 303 304#!-sb-fluid (declaim (inline ansi-stream-read-line)) 305(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p) 306 (declare (ignore recursive-p)) 307 (if (ansi-stream-cin-buffer stream) 308 ;; Stream has a fast-read-char buffer. Copy large chunks directly 309 ;; out of the buffer. 310 (ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value) 311 ;; Slow path, character by character. 312 (prepare-for-fast-read-char stream 313 (let ((res (make-string 80)) 314 (len 80) 315 (index 0)) 316 (loop 317 (let ((ch (fast-read-char nil nil))) 318 (cond (ch 319 (when (char= ch #\newline) 320 (done-with-fast-read-char) 321 (return (values (%shrink-vector res index) nil))) 322 (when (= index len) 323 (setq len (* len 2)) 324 (let ((new (make-string len))) 325 (replace new res) 326 (setq res new))) 327 (setf (schar res index) ch) 328 (incf index)) 329 ((zerop index) 330 (done-with-fast-read-char) 331 (return (values (eof-or-lose stream 332 eof-error-p 333 eof-value) 334 t))) 335 ;; Since FAST-READ-CHAR already hit the eof char, we 336 ;; shouldn't do another READ-CHAR. 337 (t 338 (done-with-fast-read-char) 339 (return (values (%shrink-vector res index) t)))))))))) 340 341(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value 342 recursive-p) 343 (declare (explicit-check)) 344 (let ((stream (in-synonym-of stream))) 345 (if (ansi-stream-p stream) 346 (ansi-stream-read-line stream eof-error-p eof-value recursive-p) 347 ;; must be Gray streams FUNDAMENTAL-STREAM 348 (multiple-value-bind (string eof) (stream-read-line stream) 349 (if (and eof (zerop (length string))) 350 (values (eof-or-lose stream eof-error-p eof-value) t) 351 (values string eof)))))) 352 353;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on, 354;;; so, except in this file, they are not inline by default, but they can be. 355#!-sb-fluid (declaim (inline read-char unread-char read-byte listen)) 356 357#!-sb-fluid (declaim (inline ansi-stream-read-char)) 358(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p) 359 (declare (ignore recursive-p)) 360 (prepare-for-fast-read-char stream 361 (prog1 362 (fast-read-char eof-error-p eof-value) 363 (done-with-fast-read-char)))) 364 365(defun read-char (&optional (stream *standard-input*) 366 (eof-error-p t) 367 eof-value 368 recursive-p) 369 (declare (explicit-check)) 370 (let ((stream (in-synonym-of stream))) 371 (if (ansi-stream-p stream) 372 (ansi-stream-read-char stream eof-error-p eof-value recursive-p) 373 ;; must be Gray streams FUNDAMENTAL-STREAM 374 (let ((char (stream-read-char stream))) 375 (if (eq char :eof) 376 (eof-or-lose stream eof-error-p eof-value) 377 (the character char)))))) 378 379#!-sb-fluid (declaim (inline ansi-stream-unread-char)) 380(defun ansi-stream-unread-char (character stream) 381 (let ((index (1- (ansi-stream-in-index stream))) 382 (buffer (ansi-stream-cin-buffer stream))) 383 (declare (fixnum index)) 384 (when (minusp index) (error "nothing to unread")) 385 (cond (buffer 386 (setf (aref buffer index) character) 387 (setf (ansi-stream-in-index stream) index) 388 ;; Ugh. an ANSI-STREAM with a char buffer never gives a chance to 389 ;; the stream's misc routine to handle the UNREAD operation. 390 (when (ansi-stream-input-char-pos stream) 391 (decf (ansi-stream-input-char-pos stream)))) 392 (t 393 (funcall (ansi-stream-misc stream) stream 394 :unread character))))) 395 396(defun unread-char (character &optional (stream *standard-input*)) 397 (declare (explicit-check)) 398 (let ((stream (in-synonym-of stream))) 399 (if (ansi-stream-p stream) 400 (ansi-stream-unread-char character stream) 401 ;; must be Gray streams FUNDAMENTAL-STREAM 402 (stream-unread-char stream character))) 403 nil) 404 405#!-sb-fluid (declaim (inline ansi-stream-listen)) 406(defun ansi-stream-listen (stream) 407 (or (/= (the fixnum (ansi-stream-in-index stream)) 408 +ansi-stream-in-buffer-length+) 409 ;; Handle :EOF return from misc methods specially 410 (let ((result (funcall (ansi-stream-misc stream) stream :listen))) 411 (if (eq result :eof) 412 nil 413 result)))) 414 415(defun listen (&optional (stream *standard-input*)) 416 (declare (explicit-check)) 417 (let ((stream (in-synonym-of stream))) 418 (if (ansi-stream-p stream) 419 (ansi-stream-listen stream) 420 ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. 421 (stream-listen stream)))) 422 423#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang)) 424(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p) 425 (if (funcall (ansi-stream-misc stream) stream :listen) 426 ;; On T or :EOF get READ-CHAR to do the work. 427 (ansi-stream-read-char stream eof-error-p eof-value recursive-p) 428 nil)) 429 430(defun read-char-no-hang (&optional (stream *standard-input*) 431 (eof-error-p t) 432 eof-value 433 recursive-p) 434 (declare (explicit-check)) 435 (let ((stream (in-synonym-of stream))) 436 (if (ansi-stream-p stream) 437 (ansi-stream-read-char-no-hang stream eof-error-p eof-value 438 recursive-p) 439 ;; must be Gray streams FUNDAMENTAL-STREAM 440 (let ((char (stream-read-char-no-hang stream))) 441 (if (eq char :eof) 442 (eof-or-lose stream eof-error-p eof-value) 443 (the (or character null) char)))))) 444 445#!-sb-fluid (declaim (inline ansi-stream-clear-input)) 446(defun ansi-stream-clear-input (stream) 447 (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) 448 (funcall (ansi-stream-misc stream) stream :clear-input)) 449 450(defun clear-input (&optional (stream *standard-input*)) 451 (declare (explicit-check)) 452 (let ((stream (in-synonym-of stream))) 453 (if (ansi-stream-p stream) 454 (ansi-stream-clear-input stream) 455 ;; must be Gray streams FUNDAMENTAL-STREAM 456 (stream-clear-input stream))) 457 nil) 458 459#!-sb-fluid (declaim (inline ansi-stream-read-byte)) 460(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p) 461 ;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from 462 ;; a-s-read-sequence and needs a lambda list that's congruent with 463 ;; that of a-s-read-char 464 (declare (ignore recursive-p)) 465 (with-fast-read-byte (t stream eof-error-p eof-value) 466 ;; FIXME: the overhead of the UNWIND-PROTECT inserted by 467 ;; WITH-FAST-READ-BYTE significantly impacts the time taken 468 ;; by single byte reads. For this use-case we could 469 ;; probably just change it to a PROG1. 470 (fast-read-byte))) 471 472(defun read-byte (stream &optional (eof-error-p t) eof-value) 473 (declare (explicit-check)) 474 (if (ansi-stream-p stream) 475 (ansi-stream-read-byte stream eof-error-p eof-value nil) 476 ;; must be Gray streams FUNDAMENTAL-STREAM 477 (let ((byte (stream-read-byte stream))) 478 (if (eq byte :eof) 479 (eof-or-lose stream eof-error-p eof-value) 480 (the integer byte))))) 481 482;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the 483;;; number of bytes read. 484;;; 485;;; Note: CMU CL's version of this had a special interpretation of 486;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL 487;;; case, CMU CL's version would return as soon as any data became 488;;; available.) This could be useful behavior for things like pipes in 489;;; some cases, but it wasn't being used in SBCL, so it was dropped. 490;;; If we ever need it, it could be added later as a new variant N-BIN 491;;; method (perhaps N-BIN-ASAP?) or something. 492#!-sb-fluid (declaim (inline read-n-bytes)) 493(defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t)) 494 (if (ansi-stream-p stream) 495 (ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p) 496 ;; We don't need to worry about element-type size here is that 497 ;; callers are supposed to have checked everything is kosher. 498 (let* ((end (+ start numbytes)) 499 (read-end (stream-read-sequence stream buffer start end))) 500 (eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start))))) 501 502(defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p) 503 (declare (type ansi-stream stream) 504 (type index numbytes start) 505 (type (or (simple-array * (*)) system-area-pointer) buffer)) 506 (let* ((in-buffer (ansi-stream-in-buffer stream)) 507 (index (ansi-stream-in-index stream)) 508 (num-buffered (- +ansi-stream-in-buffer-length+ index))) 509 (declare (fixnum index num-buffered)) 510 (cond 511 ((not in-buffer) 512 (funcall (ansi-stream-n-bin stream) 513 stream 514 buffer 515 start 516 numbytes 517 eof-error-p)) 518 ((<= numbytes num-buffered) 519 #+nil 520 (let ((copy-function (typecase buffer 521 ((simple-array * (*)) #'ub8-bash-copy) 522 (system-area-pointer #'copy-ub8-to-system-area)))) 523 (funcall copy-function in-buffer index buffer start numbytes)) 524 (%byte-blt in-buffer index 525 buffer start (+ start numbytes)) 526 (setf (ansi-stream-in-index stream) (+ index numbytes)) 527 numbytes) 528 (t 529 (let ((end (+ start num-buffered))) 530 #+nil 531 (let ((copy-function (typecase buffer 532 ((simple-array * (*)) #'ub8-bash-copy) 533 (system-area-pointer #'copy-ub8-to-system-area)))) 534 (funcall copy-function in-buffer index buffer start num-buffered)) 535 (%byte-blt in-buffer index buffer start end) 536 (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) 537 (+ (funcall (ansi-stream-n-bin stream) 538 stream 539 buffer 540 end 541 (- numbytes num-buffered) 542 eof-error-p) 543 num-buffered)))))) 544 545;;; the amount of space we leave at the start of the in-buffer for 546;;; unreading 547;;; 548;;; (It's 4 instead of 1 to allow word-aligned copies.) 549(defconstant +ansi-stream-in-buffer-extra+ 550 4) ; FIXME: should be symbolic constant 551 552;;; This function is called by the FAST-READ-CHAR expansion to refill 553;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER, 554;;; and hence must be an N-BIN method. It's also called by other stream 555;;; functions which directly peek into the frc buffer. 556;;; If EOF is hit and EOF-ERROR-P is false, then return NIL, 557;;; otherwise return the new index into CIN-BUFFER. 558(defun fast-read-char-refill (stream eof-error-p) 559 (when (ansi-stream-input-char-pos stream) 560 ;; Characters between (ANSI-STREAM-IN-INDEX %FRC-STREAM%) 561 ;; and +ANSI-STREAM-IN-BUFFER-LENGTH+ have to be re-scanned. 562 (update-input-char-pos stream)) 563 (let* ((ibuf (ansi-stream-cin-buffer stream)) 564 (count (funcall (ansi-stream-n-bin stream) 565 stream 566 ibuf 567 +ansi-stream-in-buffer-extra+ 568 (- +ansi-stream-in-buffer-length+ 569 +ansi-stream-in-buffer-extra+) 570 nil)) 571 (start (- +ansi-stream-in-buffer-length+ count))) 572 (declare (type index start count)) 573 (cond ((zerop count) 574 ;; An empty count does not necessarily mean that we reached 575 ;; the EOF, it's also possible that it's e.g. due to a 576 ;; invalid octet sequence in a multibyte stream. To handle 577 ;; the resyncing case correctly we need to call the reading 578 ;; function and check whether an EOF was really reached. If 579 ;; not, we can just fill the buffer by one character, and 580 ;; hope that the next refill will not need to resync. 581 ;; 582 ;; KLUDGE: we can't use FD-STREAM functions (which are the 583 ;; only ones which will give us decoding errors) here, 584 ;; because this code is generic. We can't call the N-BIN 585 ;; function, because near the end of a real file that can 586 ;; legitimately bounce us to the IN function. So we have 587 ;; to call ANSI-STREAM-IN. 588 (let* ((index (1- +ansi-stream-in-buffer-length+)) 589 (value (funcall (ansi-stream-in stream) stream nil :eof))) 590 (cond 591 ;; When not signaling an error, it is important that IN-INDEX 592 ;; be set to +ANSI-STREAM-IN-BUFFER-LENGTH+ here, even though 593 ;; DONE-WITH-FAST-READ-CHAR will do the same, thereby writing 594 ;; the caller's %FRC-INDEX% (= +ANSI-STREAM-IN-BUFFER-LENGTH+) 595 ;; into the slot. But because we've already bumped INPUT-CHAR-POS 596 ;; and scanned characters between the original %FRC-INDEX% 597 ;; and the buffer end (above), we must *not* do that again. 598 ((eql value :eof) 599 ;; definitely EOF now 600 (setf (ansi-stream-in-index stream) 601 +ansi-stream-in-buffer-length+) 602 (eof-or-lose stream eof-error-p nil)) 603 ;; we resynced or were given something instead 604 (t 605 (setf (aref ibuf index) value) 606 (setf (ansi-stream-in-index stream) index))))) 607 (t 608 (when (/= start +ansi-stream-in-buffer-extra+) 609 (#.(let* ((n-character-array-bits 610 (sb!vm:saetp-n-bits 611 (find 'character 612 sb!vm:*specialized-array-element-type-properties* 613 :key #'sb!vm:saetp-specifier))) 614 (bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits) 615 (find-package "SB!KERNEL")))) 616 bash-function) 617 ibuf +ansi-stream-in-buffer-extra+ 618 ibuf start 619 count)) 620 (setf (ansi-stream-in-index stream) start))))) 621 622;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to 623;;; leave room for unreading. 624(defun fast-read-byte-refill (stream eof-error-p eof-value) 625 (let* ((ibuf (ansi-stream-in-buffer stream)) 626 (count (funcall (ansi-stream-n-bin stream) stream 627 ibuf 0 +ansi-stream-in-buffer-length+ 628 nil)) 629 (start (- +ansi-stream-in-buffer-length+ count))) 630 (declare (type index start count)) 631 (cond ((zerop count) 632 (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) 633 (funcall (ansi-stream-bin stream) stream eof-error-p eof-value)) 634 (t 635 (unless (zerop start) 636 (ub8-bash-copy ibuf 0 637 ibuf start 638 count)) 639 (setf (ansi-stream-in-index stream) (1+ start)) 640 (aref ibuf start))))) 641 642;;; output functions 643 644(defun write-char (character &optional (stream *standard-output*)) 645 (declare (explicit-check)) 646 (with-out-stream stream (ansi-stream-out character) 647 (stream-write-char character)) 648 character) 649 650(defun terpri (&optional (stream *standard-output*)) 651 (declare (explicit-check)) 652 (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri)) 653 nil) 654 655#!-sb-fluid (declaim (inline ansi-stream-fresh-line)) 656(defun ansi-stream-fresh-line (stream) 657 (when (/= (or (charpos stream) 1) 0) 658 (funcall (ansi-stream-out stream) stream #\newline) 659 t)) 660 661(defun fresh-line (&optional (stream *standard-output*)) 662 (declare (explicit-check)) 663 (let ((stream (out-synonym-of stream))) 664 (if (ansi-stream-p stream) 665 (ansi-stream-fresh-line stream) 666 ;; must be Gray streams FUNDAMENTAL-STREAM 667 (stream-fresh-line stream)))) 668 669#!-sb-fluid (declaim (inline ansi-stream-write-string)) 670(defun ansi-stream-write-string (string stream start end) 671 (with-array-data ((data string) (offset-start start) 672 (offset-end end) 673 :check-fill-pointer t) 674 (funcall (ansi-stream-sout stream) 675 stream data offset-start offset-end))) 676 677(defun %write-string (string stream start end) 678 (let ((stream (out-synonym-of stream))) 679 (if (ansi-stream-p stream) 680 (ansi-stream-write-string string stream start end) 681 ;; must be Gray streams FUNDAMENTAL-STREAM 682 (stream-write-string stream string start end))) 683 string) 684 685(defun write-string (string &optional (stream *standard-output*) 686 &key (start 0) end) 687 (declare (type string string)) 688 (declare (type stream-designator stream)) 689 (declare (explicit-check)) 690 (%write-string string stream start end)) 691 692(defun write-line (string &optional (stream *standard-output*) 693 &key (start 0) end) 694 (declare (type string string)) 695 (declare (type stream-designator stream)) 696 (declare (explicit-check)) 697 (let ((stream (out-synonym-of stream))) 698 (cond ((ansi-stream-p stream) 699 (ansi-stream-write-string string stream start end) 700 (funcall (ansi-stream-out stream) stream #\newline)) 701 (t 702 (stream-write-string stream string start end) 703 (stream-write-char stream #\newline)))) 704 string) 705 706(defun charpos (&optional (stream *standard-output*)) 707 (with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column))) 708 709(defun line-length (&optional (stream *standard-output*)) 710 (with-out-stream stream (ansi-stream-misc :line-length) 711 (stream-line-length))) 712 713(defun finish-output (&optional (stream *standard-output*)) 714 (declare (explicit-check)) 715 (with-out-stream stream (ansi-stream-misc :finish-output) 716 (stream-finish-output)) 717 nil) 718 719(defun force-output (&optional (stream *standard-output*)) 720 (declare (explicit-check)) 721 (with-out-stream stream (ansi-stream-misc :force-output) 722 (stream-force-output)) 723 nil) 724 725(defun clear-output (&optional (stream *standard-output*)) 726 (declare (explicit-check)) 727 (with-out-stream stream (ansi-stream-misc :clear-output) 728 (stream-clear-output)) 729 nil) 730 731(defun write-byte (integer stream) 732 (declare (explicit-check)) 733 (with-out-stream/no-synonym stream (ansi-stream-bout integer) 734 (stream-write-byte integer)) 735 integer) 736 737 738;;; Meta: the following comment is mostly true, but gray stream support 739;;; is already incorporated into the definitions within this file. 740;;; But these need to redefinable, otherwise the relative order of 741;;; loading sb-simple-streams and any user-defined code which executes 742;;; (F #'read-char ...) is sensitive to the order in which those 743;;; are loaded, though insensitive at compile-time. 744;;; (These were inline throughout this file, but that's not appropriate 745;;; globally. And we must not inline them in the rest of this file if 746;;; dispatch to gray or simple streams is to work, since both redefine 747;;; these functions later.) 748(declaim (notinline read-char unread-char read-byte listen)) 749 750;;; This is called from ANSI-STREAM routines that encapsulate CLOS 751;;; streams to handle the misc routines and dispatch to the 752;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions. 753(defun stream-misc-dispatch (stream operation &optional arg1 arg2) 754 (declare (type stream stream) (ignore arg2)) 755 (ecase operation 756 (:listen 757 ;; Return T if input available, :EOF for end-of-file, otherwise NIL. 758 (let ((char (read-char-no-hang stream nil :eof))) 759 (when (characterp char) 760 (unread-char char stream)) 761 char)) 762 (:unread 763 (unread-char arg1 stream)) 764 (:close 765 (close stream)) 766 (:clear-input 767 (clear-input stream)) 768 (:force-output 769 (force-output stream)) 770 (:finish-output 771 (finish-output stream)) 772 (:element-type 773 (stream-element-type stream)) 774 (:element-mode 775 (stream-element-type-stream-element-mode 776 (stream-element-type stream))) 777 (:stream-external-format 778 (stream-external-format stream)) 779 (:interactive-p 780 (interactive-stream-p stream)) 781 (:line-length 782 (line-length stream)) 783 (:charpos 784 (charpos stream)) 785 (:file-length 786 (file-length stream)) 787 (:file-string-length 788 (file-string-length stream arg1)) 789 (:file-position 790 (file-position stream arg1)))) 791 792(declaim (inline stream-element-mode)) 793(defun stream-element-mode (stream) 794 (declare (type stream stream)) 795 (cond 796 ((fd-stream-p stream) 797 (fd-stream-element-mode stream)) 798 ((and (ansi-stream-p stream) 799 (funcall (ansi-stream-misc stream) stream :element-mode))) 800 (t 801 (stream-element-type-stream-element-mode 802 (stream-element-type stream))))) 803 804;;;; broadcast streams 805 806(defstruct (broadcast-stream (:include ansi-stream 807 (out #'broadcast-out) 808 (bout #'broadcast-bout) 809 (sout #'broadcast-sout) 810 (misc #'broadcast-misc)) 811 (:constructor %make-broadcast-stream 812 (streams)) 813 (:copier nil) 814 (:predicate nil)) 815 ;; a list of all the streams we broadcast to 816 (streams () :type list :read-only t)) 817 818(declaim (freeze-type broadcast-stream)) 819 820(defun make-broadcast-stream (&rest streams) 821 (dolist (stream streams) 822 (unless (output-stream-p stream) 823 (error 'type-error 824 :datum stream 825 :expected-type '(satisfies output-stream-p)))) 826 (%make-broadcast-stream streams)) 827 828(macrolet ((out-fun (name fun &rest args) 829 `(defun ,name (stream ,@args) 830 (dolist (stream (broadcast-stream-streams stream)) 831 (,fun ,(car args) stream ,@(cdr args)))))) 832 (out-fun broadcast-out write-char char) 833 (out-fun broadcast-bout write-byte byte) 834 (out-fun broadcast-sout %write-string string start end)) 835 836(defun broadcast-misc (stream operation &optional arg1 arg2) 837 (let ((streams (broadcast-stream-streams stream))) 838 (case operation 839 ;; FIXME: This may not be the best place to note this, but I 840 ;; think the :CHARPOS protocol needs revision. Firstly, I think 841 ;; this is the last place where a NULL return value was possible 842 ;; (before adjusting it to be 0), so a bunch of conditionals IF 843 ;; CHARPOS can be removed; secondly, it is my belief that 844 ;; FD-STREAMS, when running FILE-POSITION, do not update the 845 ;; CHARPOS, and consequently there will be much wrongness. 846 ;; 847 ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why 848 ;; is it testing the :charpos of an input stream? 849 ;; 850 ;; -- CSR, 2004-02-04 851 (:charpos 852 (dolist (stream streams 0) 853 (let ((charpos (charpos stream))) 854 (when charpos 855 (return charpos))))) 856 (:line-length 857 (let ((min nil)) 858 (dolist (stream streams min) 859 (let ((res (line-length stream))) 860 (when res (setq min (if min (min res min) res))))))) 861 (:element-type 862 (let ((last (last streams))) 863 (if last 864 (stream-element-type (car last)) 865 t))) 866 (:element-mode 867 (awhen (last streams) 868 (stream-element-mode (car it)))) 869 (:external-format 870 (let ((last (last streams))) 871 (if last 872 (stream-external-format (car last)) 873 :default))) 874 (:file-length 875 (let ((last (last streams))) 876 (if last 877 (file-length (car last)) 878 0))) 879 (:file-position 880 (if arg1 881 (let ((res (or (eql arg1 :start) (eql arg1 0)))) 882 (dolist (stream streams res) 883 (setq res (file-position stream arg1)))) 884 (let ((last (last streams))) 885 (if last 886 (file-position (car last)) 887 0)))) 888 (:file-string-length 889 (let ((last (last streams))) 890 (if last 891 (file-string-length (car last) arg1) 892 1))) 893 (:close 894 (set-closed-flame stream)) 895 (t 896 (let ((res nil)) 897 (dolist (stream streams res) 898 (setq res 899 (if (ansi-stream-p stream) 900 (funcall (ansi-stream-misc stream) stream operation 901 arg1 arg2) 902 (stream-misc-dispatch stream operation arg1 arg2))))))))) 903 904;;;; synonym streams 905 906(defmethod print-object ((x synonym-stream) stream) 907 (print-unreadable-object (x stream :type t :identity t) 908 (format stream ":SYMBOL ~S" (synonym-stream-symbol x)))) 909 910;;; The output simple output methods just call the corresponding 911;;; function on the synonymed stream. 912(macrolet ((out-fun (name fun &rest args) 913 `(defun ,name (stream ,@args) 914 (declare (optimize (safety 1))) 915 (let ((syn (symbol-value (synonym-stream-symbol stream)))) 916 (,fun ,(car args) syn ,@(cdr args)))))) 917 (out-fun synonym-out write-char ch) 918 (out-fun synonym-bout write-byte n) 919 (out-fun synonym-sout %write-string string start end)) 920 921;;; For the input methods, we just call the corresponding function on the 922;;; synonymed stream. These functions deal with getting input out of 923;;; the In-Buffer if there is any. 924(macrolet ((in-fun (name fun &rest args) 925 `(defun ,name (stream ,@args) 926 (declare (optimize (safety 1))) 927 (,fun (symbol-value (synonym-stream-symbol stream)) 928 ,@args)))) 929 (in-fun synonym-in read-char eof-error-p eof-value) 930 (in-fun synonym-bin read-byte eof-error-p eof-value) 931 (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p)) 932 933(defun synonym-misc (stream operation &optional arg1 arg2) 934 (declare (optimize (safety 1))) 935 (let ((syn (symbol-value (synonym-stream-symbol stream)))) 936 (if (ansi-stream-p syn) 937 ;; We have to special-case some operations which interact with 938 ;; the in-buffer of the wrapped stream, since just calling 939 ;; ANSI-STREAM-MISC on them 940 (case operation 941 (:listen (or (/= (the fixnum (ansi-stream-in-index syn)) 942 +ansi-stream-in-buffer-length+) 943 (funcall (ansi-stream-misc syn) syn :listen))) 944 (:clear-input (clear-input syn)) 945 (:unread (unread-char arg1 syn)) 946 (t 947 (funcall (ansi-stream-misc syn) syn operation arg1 arg2))) 948 (stream-misc-dispatch syn operation arg1 arg2)))) 949 950;;;; two-way streams 951 952(defstruct (two-way-stream 953 (:include ansi-stream 954 (in #'two-way-in) 955 (bin #'two-way-bin) 956 (n-bin #'two-way-n-bin) 957 (out #'two-way-out) 958 (bout #'two-way-bout) 959 (sout #'two-way-sout) 960 (misc #'two-way-misc)) 961 (:constructor %make-two-way-stream (input-stream output-stream)) 962 (:copier nil) 963 (:predicate nil)) 964 (input-stream (missing-arg) :type stream :read-only t) 965 (output-stream (missing-arg) :type stream :read-only t)) 966 967(defprinter (two-way-stream) input-stream output-stream) 968 969(defun make-two-way-stream (input-stream output-stream) 970 #!+sb-doc 971 "Return a bidirectional stream which gets its input from INPUT-STREAM and 972 sends its output to OUTPUT-STREAM." 973 ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream 974 ;; should be encapsulated in a function, and used here and most of 975 ;; the other places that SYNONYM-STREAM-P appears. 976 (unless (output-stream-p output-stream) 977 (error 'type-error 978 :datum output-stream 979 :expected-type '(satisfies output-stream-p))) 980 (unless (input-stream-p input-stream) 981 (error 'type-error 982 :datum input-stream 983 :expected-type '(satisfies input-stream-p))) 984 (%make-two-way-stream input-stream output-stream)) 985 986(macrolet ((out-fun (name fun &rest args) 987 `(defun ,name (stream ,@args) 988 (let ((syn (two-way-stream-output-stream stream))) 989 (,fun ,(car args) syn ,@(cdr args)))))) 990 (out-fun two-way-out write-char ch) 991 (out-fun two-way-bout write-byte n) 992 (out-fun two-way-sout %write-string string start end)) 993 994(macrolet ((in-fun (name fun &rest args) 995 `(defun ,name (stream ,@args) 996 (,fun (two-way-stream-input-stream stream) ,@args)))) 997 (in-fun two-way-in read-char eof-error-p eof-value) 998 (in-fun two-way-bin read-byte eof-error-p eof-value) 999 (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p)) 1000 1001(defun two-way-misc (stream operation &optional arg1 arg2) 1002 (let* ((in (two-way-stream-input-stream stream)) 1003 (out (two-way-stream-output-stream stream)) 1004 (in-ansi-stream-p (ansi-stream-p in)) 1005 (out-ansi-stream-p (ansi-stream-p out))) 1006 (case operation 1007 (:listen 1008 (if in-ansi-stream-p 1009 (or (/= (the fixnum (ansi-stream-in-index in)) 1010 +ansi-stream-in-buffer-length+) 1011 (funcall (ansi-stream-misc in) in :listen)) 1012 (listen in))) 1013 ((:finish-output :force-output :clear-output) 1014 (if out-ansi-stream-p 1015 (funcall (ansi-stream-misc out) out operation arg1 arg2) 1016 (stream-misc-dispatch out operation arg1 arg2))) 1017 (:clear-input (clear-input in)) 1018 (:unread (unread-char arg1 in)) 1019 (:element-type 1020 (let ((in-type (stream-element-type in)) 1021 (out-type (stream-element-type out))) 1022 (if (equal in-type out-type) 1023 in-type 1024 `(and ,in-type ,out-type)))) 1025 (:element-mode 1026 (let ((in-mode (stream-element-mode in)) 1027 (out-mode (stream-element-mode out))) 1028 (when (equal in-mode out-mode) 1029 in-mode))) 1030 (:close 1031 (set-closed-flame stream)) 1032 (t 1033 (or (if in-ansi-stream-p 1034 (funcall (ansi-stream-misc in) in operation arg1 arg2) 1035 (stream-misc-dispatch in operation arg1 arg2)) 1036 (if out-ansi-stream-p 1037 (funcall (ansi-stream-misc out) out operation arg1 arg2) 1038 (stream-misc-dispatch out operation arg1 arg2))))))) 1039 1040;;;; concatenated streams 1041 1042(defstruct (concatenated-stream 1043 (:include ansi-stream 1044 (in #'concatenated-in) 1045 (bin #'concatenated-bin) 1046 (n-bin #'concatenated-n-bin) 1047 (misc #'concatenated-misc)) 1048 (:constructor %make-concatenated-stream (streams)) 1049 (:copier nil) 1050 (:predicate nil)) 1051 ;; The car of this is the substream we are reading from now. 1052 (streams nil :type list)) 1053 1054(declaim (freeze-type concatenated-stream)) 1055 1056(defmethod print-object ((x concatenated-stream) stream) 1057 (print-unreadable-object (x stream :type t :identity t) 1058 (format stream 1059 ":STREAMS ~S" 1060 (concatenated-stream-streams x)))) 1061 1062(defun make-concatenated-stream (&rest streams) 1063 #!+sb-doc 1064 "Return a stream which takes its input from each of the streams in turn, 1065 going on to the next at EOF." 1066 (dolist (stream streams) 1067 (unless (input-stream-p stream) 1068 (error 'type-error 1069 :datum stream 1070 :expected-type '(satisfies input-stream-p)))) 1071 (%make-concatenated-stream streams)) 1072 1073(macrolet ((in-fun (name fun) 1074 `(defun ,name (stream eof-error-p eof-value) 1075 (do ((streams (concatenated-stream-streams stream) 1076 (cdr streams))) 1077 ((null streams) 1078 (eof-or-lose stream eof-error-p eof-value)) 1079 (let* ((stream (car streams)) 1080 (result (,fun stream nil nil))) 1081 (when result (return result))) 1082 (pop (concatenated-stream-streams stream)))))) 1083 (in-fun concatenated-in read-char) 1084 (in-fun concatenated-bin read-byte)) 1085 1086(defun concatenated-n-bin (stream buffer start numbytes eof-errorp) 1087 (do ((streams (concatenated-stream-streams stream) (cdr streams)) 1088 (current-start start) 1089 (remaining-bytes numbytes)) 1090 ((null streams) 1091 (if eof-errorp 1092 (error 'end-of-file :stream stream) 1093 (- numbytes remaining-bytes))) 1094 (let* ((stream (car streams)) 1095 (bytes-read (read-n-bytes stream buffer current-start 1096 remaining-bytes nil))) 1097 (incf current-start bytes-read) 1098 (decf remaining-bytes bytes-read) 1099 (when (zerop remaining-bytes) (return numbytes))) 1100 (setf (concatenated-stream-streams stream) (cdr streams)))) 1101 1102(defun concatenated-misc (stream operation &optional arg1 arg2) 1103 (let* ((left (concatenated-stream-streams stream)) 1104 (current (car left))) 1105 (case operation 1106 (:listen 1107 (unless left 1108 (return-from concatenated-misc :eof)) 1109 (loop 1110 (let ((stuff (if (ansi-stream-p current) 1111 (funcall (ansi-stream-misc current) current 1112 :listen) 1113 (stream-misc-dispatch current :listen)))) 1114 (cond ((eq stuff :eof) 1115 ;; Advance STREAMS, and try again. 1116 (pop (concatenated-stream-streams stream)) 1117 (setf current 1118 (car (concatenated-stream-streams stream))) 1119 (unless current 1120 ;; No further streams. EOF. 1121 (return :eof))) 1122 (stuff 1123 ;; Stuff's available. 1124 (return t)) 1125 (t 1126 ;; Nothing is available yet. 1127 (return nil)))))) 1128 (:clear-input (when left (clear-input current))) 1129 (:unread (when left (unread-char arg1 current))) 1130 (:close 1131 (set-closed-flame stream)) 1132 (t 1133 (when left 1134 (if (ansi-stream-p current) 1135 (funcall (ansi-stream-misc current) current operation arg1 arg2) 1136 (stream-misc-dispatch current operation arg1 arg2))))))) 1137 1138;;;; echo streams 1139 1140(defstruct (echo-stream 1141 (:include two-way-stream 1142 (in #'echo-in) 1143 (bin #'echo-bin) 1144 (misc #'echo-misc) 1145 (n-bin #'echo-n-bin)) 1146 (:constructor %make-echo-stream (input-stream output-stream)) 1147 (:copier nil) 1148 (:predicate nil)) 1149 (unread-stuff nil :type boolean)) 1150 1151(declaim (freeze-type echo-stream)) 1152 1153(defmethod print-object ((x echo-stream) stream) 1154 (print-unreadable-object (x stream :type t :identity t) 1155 (format stream 1156 ":INPUT-STREAM ~S :OUTPUT-STREAM ~S" 1157 (two-way-stream-input-stream x) 1158 (two-way-stream-output-stream x)))) 1159 1160(defun make-echo-stream (input-stream output-stream) 1161 #!+sb-doc 1162 "Return a bidirectional stream which gets its input from INPUT-STREAM and 1163 sends its output to OUTPUT-STREAM. In addition, all input is echoed to 1164 the output stream." 1165 (unless (output-stream-p output-stream) 1166 (error 'type-error 1167 :datum output-stream 1168 :expected-type '(satisfies output-stream-p))) 1169 (unless (input-stream-p input-stream) 1170 (error 'type-error 1171 :datum input-stream 1172 :expected-type '(satisfies input-stream-p))) 1173 (%make-echo-stream input-stream output-stream)) 1174 1175(macrolet ((in-fun (name in-fun out-fun &rest args) 1176 `(defun ,name (stream ,@args) 1177 (let* ((unread-stuff-p (echo-stream-unread-stuff stream)) 1178 (in (echo-stream-input-stream stream)) 1179 (out (echo-stream-output-stream stream)) 1180 (result (if eof-error-p 1181 (,in-fun in ,@args) 1182 (,in-fun in nil in)))) 1183 (setf (echo-stream-unread-stuff stream) nil) 1184 (cond 1185 ((eql result in) eof-value) 1186 ;; If unread-stuff was true, the character read 1187 ;; from the input stream was previously echoed. 1188 (t (unless unread-stuff-p (,out-fun result out)) result)))))) 1189 (in-fun echo-in read-char write-char eof-error-p eof-value) 1190 (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) 1191 1192(defun echo-n-bin (stream buffer start numbytes eof-error-p) 1193 (let ((bytes-read 0)) 1194 ;; Note: before ca 1.0.27.18, the logic for handling unread 1195 ;; characters never could have worked, so probably nobody has ever 1196 ;; tried doing bivalent block I/O through an echo stream; this may 1197 ;; not work either. 1198 (when (echo-stream-unread-stuff stream) 1199 (let* ((char (read-char stream)) 1200 (octets (string-to-octets 1201 (string char) 1202 :external-format 1203 (stream-external-format 1204 (echo-stream-input-stream stream)))) 1205 (octet-count (length octets)) 1206 (blt-count (min octet-count numbytes))) 1207 (replace buffer octets :start1 start :end1 (+ start blt-count)) 1208 (incf start blt-count) 1209 (decf numbytes blt-count))) 1210 (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer 1211 start numbytes nil)) 1212 (cond 1213 ((not eof-error-p) 1214 (write-sequence buffer (echo-stream-output-stream stream) 1215 :start start :end (+ start bytes-read)) 1216 bytes-read) 1217 ((> numbytes bytes-read) 1218 (write-sequence buffer (echo-stream-output-stream stream) 1219 :start start :end (+ start bytes-read)) 1220 (error 'end-of-file :stream stream)) 1221 (t 1222 (write-sequence buffer (echo-stream-output-stream stream) 1223 :start start :end (+ start bytes-read)) 1224 (aver (= numbytes (+ start bytes-read))) 1225 numbytes)))) 1226 1227;;;; STRING-INPUT-STREAM stuff 1228 1229(defstruct (string-input-stream 1230 (:include ansi-stream 1231 (in #'string-inch) 1232 (misc #'string-in-misc)) 1233 (:constructor %make-string-input-stream 1234 (string current end)) 1235 (:copier nil) 1236 (:predicate nil)) 1237 (string (missing-arg) :type simple-string :read-only t) 1238 (current (missing-arg) :type index) 1239 (end (missing-arg) :type index)) 1240 1241(declaim (freeze-type string-input-stream)) 1242 1243(defun string-inch (stream eof-error-p eof-value) 1244 (declare (type string-input-stream stream)) 1245 (let ((string (string-input-stream-string stream)) 1246 (index (string-input-stream-current stream))) 1247 (cond ((>= index (the index (string-input-stream-end stream))) 1248 (eof-or-lose stream eof-error-p eof-value)) 1249 (t 1250 (setf (string-input-stream-current stream) (1+ index)) 1251 (char string index))))) 1252 1253(defun string-binch (stream eof-error-p eof-value) 1254 (declare (type string-input-stream stream)) 1255 (let ((string (string-input-stream-string stream)) 1256 (index (string-input-stream-current stream))) 1257 (cond ((>= index (the index (string-input-stream-end stream))) 1258 (eof-or-lose stream eof-error-p eof-value)) 1259 (t 1260 (setf (string-input-stream-current stream) (1+ index)) 1261 (char-code (char string index)))))) 1262 1263(defun string-stream-read-n-bytes (stream buffer start requested eof-error-p) 1264 (declare (type string-input-stream stream) 1265 (type index start requested)) 1266 (let* ((string (string-input-stream-string stream)) 1267 (index (string-input-stream-current stream)) 1268 (available (- (string-input-stream-end stream) index)) 1269 (copy (min available requested))) 1270 (declare (type simple-string string)) 1271 (when (plusp copy) 1272 (setf (string-input-stream-current stream) 1273 (truly-the index (+ index copy))) 1274 ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point? 1275 ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24 1276 (with-pinned-objects (string buffer) 1277 (system-area-ub8-copy (vector-sap string) 1278 index 1279 (if (typep buffer 'system-area-pointer) 1280 buffer 1281 (vector-sap buffer)) 1282 start 1283 copy))) 1284 (if (and (> requested copy) eof-error-p) 1285 (error 'end-of-file :stream stream) 1286 copy))) 1287 1288(defun string-in-misc (stream operation &optional arg1 arg2) 1289 (declare (type string-input-stream stream) 1290 (ignore arg2)) 1291 (case operation 1292 (:file-position 1293 (if arg1 1294 (setf (string-input-stream-current stream) 1295 (case arg1 1296 (:start 0) 1297 (:end (string-input-stream-end stream)) 1298 ;; We allow moving position beyond EOF. Errors happen 1299 ;; on read, not move. 1300 (t arg1))) 1301 (string-input-stream-current stream))) 1302 ;; According to ANSI: "Should signal an error of type type-error 1303 ;; if stream is not a stream associated with a file." 1304 ;; This is checked by FILE-LENGTH, so no need to do it here either. 1305 ;; (:file-length (length (string-input-stream-string stream))) 1306 (:unread (decf (string-input-stream-current stream))) 1307 (:close (set-closed-flame stream)) 1308 (:listen (or (/= (the index (string-input-stream-current stream)) 1309 (the index (string-input-stream-end stream))) 1310 :eof)) 1311 (:element-type (array-element-type (string-input-stream-string stream))) 1312 (:element-mode 'character))) 1313 1314(defun make-string-input-stream (string &optional (start 0) end) 1315 #!+sb-doc 1316 "Return an input stream which will supply the characters of STRING between 1317 START and END in order." 1318 (declare (type string string) 1319 (type index start) 1320 (type (or index null) end)) 1321 ;; FIXME: very inefficient if the input string is, say a 100000-character 1322 ;; adjustable string but (- END START) is 100 characters. We should use 1323 ;; SUBSEQ instead of coercing the whole string. And if STRING is non-simple 1324 ;; but has element type CHARACTER, wouldn't it work to just use the 1325 ;; underlying simple-string since %MAKE-STRING-INPUT-STREAM accepts bounding 1326 ;; indices that can be fudged to deal with any offset? 1327 ;; And (for unicode builds) if the input is BASE-STRING, we should use 1328 ;; MAKE-ARRAY and REPLACE to coerce just the specified piece. 1329 (let* ((string (coerce string '(simple-array character (*))))) 1330 ;; Why WITH-ARRAY-DATA, since the array is already simple? 1331 ;; because it's a nice abstract way to check the START and END. 1332 (with-array-data ((string string) (start start) (end end)) 1333 (%make-string-input-stream 1334 string ;; now simple 1335 start end)))) 1336 1337;;;; STRING-OUTPUT-STREAM stuff 1338;;;; 1339;;;; FIXME: This, like almost none of the stream code is particularly 1340;;;; interrupt or thread-safe. While it should not be possible to 1341;;;; corrupt the heap here, it certainly is possible to end up with 1342;;;; a string-output-stream whose internal state is messed up. 1343;;;; 1344;;;; FIXME: It would be nice to support space-efficient 1345;;;; string-output-streams with element-type base-char. This would 1346;;;; mean either a separate subclass, or typecases in functions. 1347 1348(defconstant +string-output-stream-buffer-initial-size+ 64) 1349 1350(defstruct (string-output-stream 1351 (:include ansi-stream 1352 (out #'string-ouch) 1353 (sout #'string-sout) 1354 (misc #'string-out-misc)) 1355 (:constructor %make-string-output-stream (element-type)) 1356 (:copier nil) 1357 (:predicate nil)) 1358 ;; The string we throw stuff in. 1359 (buffer (make-string 1360 +string-output-stream-buffer-initial-size+) 1361 :type (simple-array character (*))) 1362 ;; Chains of buffers to use 1363 (prev nil :type list) 1364 (next nil :type list) 1365 ;; Index of the next location to use in the current string. 1366 (pointer 0 :type index) 1367 ;; Global location in the stream 1368 (index 0 :type index) 1369 ;; Index cache: when we move backwards we save the greater of this 1370 ;; and index here, so the greater of index and this is always the 1371 ;; end of the stream. 1372 (index-cache 0 :type index) 1373 ;; Requested element type 1374 ;; FIXME: there seems to be no way to skip the type-check in the ctor, 1375 ;; which is redundant with the check in MAKE-STRING-OUTPUT-STREAM. 1376 (element-type 'character :type type-specifier 1377 :read-only t)) 1378 1379(declaim (freeze-type string-output-stream)) 1380(defun make-string-output-stream (&key (element-type 'character)) 1381 #!+sb-doc 1382 "Return an output stream which will accumulate all output given it for the 1383benefit of the function GET-OUTPUT-STREAM-STRING." 1384 (declare (explicit-check)) 1385 (if (csubtypep (specifier-type element-type) (specifier-type 'character)) 1386 (%make-string-output-stream element-type) 1387 (error "~S is not a subtype of CHARACTER" element-type))) 1388 1389;;; Pushes the current segment onto the prev-list, and either pops 1390;;; or allocates a new one. 1391(defun string-output-stream-new-buffer (stream size) 1392 (declare (index size)) 1393 (/noshow0 "/string-output-stream-new-buffer") 1394 (push (string-output-stream-buffer stream) 1395 (string-output-stream-prev stream)) 1396 (setf (string-output-stream-buffer stream) 1397 (or (pop (string-output-stream-next stream)) 1398 ;; FIXME: This would be the correct place to detect that 1399 ;; more than FIXNUM characters are being written to the 1400 ;; stream, and do something about it. 1401 (make-string size)))) 1402 1403;;; Moves to the end of the next segment or the current one if there are 1404;;; no more segments. Returns true as long as there are next segments. 1405(defun string-output-stream-next-buffer (stream) 1406 (/noshow0 "/string-output-stream-next-buffer") 1407 (let* ((old (string-output-stream-buffer stream)) 1408 (new (pop (string-output-stream-next stream))) 1409 (old-size (length old)) 1410 (skipped (- old-size (string-output-stream-pointer stream)))) 1411 (cond (new 1412 (let ((new-size (length new))) 1413 (push old (string-output-stream-prev stream)) 1414 (setf (string-output-stream-buffer stream) new 1415 (string-output-stream-pointer stream) new-size) 1416 (incf (string-output-stream-index stream) (+ skipped new-size))) 1417 t) 1418 (t 1419 (setf (string-output-stream-pointer stream) old-size) 1420 (incf (string-output-stream-index stream) skipped) 1421 nil)))) 1422 1423;;; Moves to the start of the previous segment or the current one if there 1424;;; are no more segments. Returns true as long as there are prev segments. 1425(defun string-output-stream-prev-buffer (stream) 1426 (/noshow0 "/string-output-stream-prev-buffer") 1427 (let ((old (string-output-stream-buffer stream)) 1428 (new (pop (string-output-stream-prev stream))) 1429 (skipped (string-output-stream-pointer stream))) 1430 (cond (new 1431 (push old (string-output-stream-next stream)) 1432 (setf (string-output-stream-buffer stream) new 1433 (string-output-stream-pointer stream) 0) 1434 (decf (string-output-stream-index stream) (+ skipped (length new))) 1435 t) 1436 (t 1437 (setf (string-output-stream-pointer stream) 0) 1438 (decf (string-output-stream-index stream) skipped) 1439 nil)))) 1440 1441(defun string-ouch (stream character) 1442 (/noshow0 "/string-ouch") 1443 (let ((pointer (string-output-stream-pointer stream)) 1444 (buffer (string-output-stream-buffer stream)) 1445 (index (string-output-stream-index stream))) 1446 (cond ((= pointer (length buffer)) 1447 (setf buffer (string-output-stream-new-buffer stream index) 1448 (aref buffer 0) character 1449 (string-output-stream-pointer stream) 1)) 1450 (t 1451 (setf (aref buffer pointer) character 1452 (string-output-stream-pointer stream) (1+ pointer)))) 1453 (setf (string-output-stream-index stream) (1+ index)))) 1454 1455(defun string-sout (stream string start end) 1456 (declare (type simple-string string) 1457 (type index start end)) 1458 (let* ((full-length (- end start)) 1459 (length full-length) 1460 (buffer (string-output-stream-buffer stream)) 1461 (pointer (string-output-stream-pointer stream)) 1462 (space (- (length buffer) pointer)) 1463 (here (min space length)) 1464 (stop (+ start here)) 1465 (overflow (- length space))) 1466 (declare (index length space here stop full-length) 1467 (fixnum overflow) 1468 (type (simple-array character (*)) buffer)) 1469 (tagbody 1470 :more 1471 (when (plusp here) 1472 (etypecase string 1473 ((simple-array character (*)) 1474 (replace buffer string :start1 pointer :start2 start :end2 stop)) 1475 (simple-base-string 1476 (replace buffer string :start1 pointer :start2 start :end2 stop)) 1477 ((simple-array nil (*)) 1478 (replace buffer string :start1 pointer :start2 start :end2 stop))) 1479 (setf (string-output-stream-pointer stream) (+ here pointer))) 1480 (when (plusp overflow) 1481 (setf start stop 1482 length (- end start) 1483 buffer (string-output-stream-new-buffer 1484 stream (max overflow (string-output-stream-index stream))) 1485 pointer 0 1486 space (length buffer) 1487 here (min space length) 1488 stop (+ start here) 1489 ;; there may be more overflow if we used a buffer 1490 ;; already allocated to the stream 1491 overflow (- length space)) 1492 (go :more))) 1493 (incf (string-output-stream-index stream) full-length))) 1494 1495;;; Factored out of the -misc method due to size. 1496(defun set-string-output-stream-file-position (stream pos) 1497 (let* ((index (string-output-stream-index stream)) 1498 (end (max index (string-output-stream-index-cache stream)))) 1499 (declare (index index end)) 1500 (setf (string-output-stream-index-cache stream) end) 1501 (cond ((eq :start pos) 1502 (loop while (string-output-stream-prev-buffer stream))) 1503 ((eq :end pos) 1504 (loop while (string-output-stream-next-buffer stream)) 1505 (let ((over (- (string-output-stream-index stream) end))) 1506 (decf (string-output-stream-pointer stream) over)) 1507 (setf (string-output-stream-index stream) end)) 1508 ((< pos index) 1509 (loop while (< pos index) 1510 do (string-output-stream-prev-buffer stream) 1511 (setf index (string-output-stream-index stream))) 1512 (let ((step (- pos index))) 1513 (incf (string-output-stream-pointer stream) step) 1514 (setf (string-output-stream-index stream) pos))) 1515 ((> pos index) 1516 ;; We allow moving beyond the end of stream, implicitly 1517 ;; extending the output stream. 1518 (let ((next (string-output-stream-next-buffer stream))) 1519 ;; Update after -next-buffer, INDEX is kept pointing at 1520 ;; the end of the current buffer. 1521 (setf index (string-output-stream-index stream)) 1522 (loop while (and next (> pos index)) 1523 do (setf next (string-output-stream-next-buffer stream) 1524 index (string-output-stream-index stream)))) 1525 ;; Allocate new buffer if needed, or step back to 1526 ;; the desired index and set pointer and index 1527 ;; correctly. 1528 (let ((diff (- pos index))) 1529 (if (plusp diff) 1530 (let* ((new (string-output-stream-new-buffer stream diff)) 1531 (size (length new))) 1532 (aver (= pos (+ index size))) 1533 (setf (string-output-stream-pointer stream) size 1534 (string-output-stream-index stream) pos)) 1535 (let ((size (length (string-output-stream-buffer stream)))) 1536 (setf (string-output-stream-pointer stream) (+ size diff) 1537 (string-output-stream-index stream) pos)))))))) 1538 1539(defun string-out-misc (stream operation &optional arg1 arg2) 1540 (declare (ignore arg2)) 1541 (declare (optimize speed)) 1542 (case operation 1543 (:charpos 1544 ;; Keeping this first is a silly micro-optimization: FRESH-LINE 1545 ;; makes this the most common one. 1546 (/noshow0 "/string-out-misc charpos") 1547 (prog ((pointer (string-output-stream-pointer stream)) 1548 (buffer (string-output-stream-buffer stream)) 1549 (prev (string-output-stream-prev stream)) 1550 (base 0)) 1551 (declare (type (or null (simple-array character (*))) buffer)) 1552 :next 1553 (let ((pos (when buffer 1554 (position #\newline buffer :from-end t :end pointer)))) 1555 (when (or pos (not buffer)) 1556 ;; If newline is at index I, and pointer at index I+N, charpos 1557 ;; is N-1. If there is no newline, and pointer is at index N, 1558 ;; charpos is N. 1559 (return (+ base (if pos (- pointer pos 1) pointer)))) 1560 (setf base (+ base pointer) 1561 buffer (pop prev) 1562 pointer (length buffer)) 1563 (/noshow0 "/string-out-misc charpos next") 1564 (go :next)))) 1565 (:file-position 1566 (/noshow0 "/string-out-misc file-position") 1567 (when arg1 1568 (set-string-output-stream-file-position stream arg1)) 1569 (string-output-stream-index stream)) 1570 (:close 1571 (/noshow0 "/string-out-misc close") 1572 (set-closed-flame stream)) 1573 (:element-type (string-output-stream-element-type stream)) 1574 (:element-mode 'character))) 1575 1576;;; Return a string of all the characters sent to a stream made by 1577;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function. 1578(defun get-output-stream-string (stream) 1579 (declare (type string-output-stream stream)) 1580 (let* ((length (max (string-output-stream-index stream) 1581 (string-output-stream-index-cache stream))) 1582 (element-type (string-output-stream-element-type stream)) 1583 (prev (nreverse (string-output-stream-prev stream))) 1584 (this (string-output-stream-buffer stream)) 1585 (next (string-output-stream-next stream)) 1586 (result 1587 (case element-type 1588 ;; overwhelmingly common case: can be inlined 1589 ;; 1590 ;; FIXME: If we were willing to use %SHRINK-VECTOR here, 1591 ;; and allocate new strings the size of 2 * index in 1592 ;; STRING-SOUT, we would not need to allocate one here in 1593 ;; the common case, but could just use the last one 1594 ;; allocated, and chop it down to size.. 1595 ;; 1596 ((character) (make-string length)) 1597 ;; slightly less common cases: inline it anyway 1598 ((base-char standard-char) 1599 (make-string length :element-type 'base-char)) 1600 (t 1601 (make-string length :element-type element-type))))) 1602 1603 (setf (string-output-stream-index stream) 0 1604 (string-output-stream-index-cache stream) 0 1605 (string-output-stream-pointer stream) 0 1606 ;; throw them away for simplicity's sake: this way the rest of the 1607 ;; implementation can assume that the greater of INDEX and INDEX-CACHE 1608 ;; is always within the last buffer. 1609 (string-output-stream-prev stream) nil 1610 (string-output-stream-next stream) nil) 1611 1612 (flet ((replace-all (fun) 1613 (let ((start 0)) 1614 (declare (index start)) 1615 (dolist (buffer prev) 1616 (funcall fun buffer start) 1617 (incf start (length buffer))) 1618 (funcall fun this start) 1619 (incf start (length this)) 1620 (dolist (buffer next) 1621 (funcall fun buffer start) 1622 (incf start (length buffer))) 1623 ;; Hack: erase the pointers to strings, to make it less 1624 ;; likely that the conservative GC will accidentally 1625 ;; retain the buffers. 1626 (fill prev nil) 1627 (fill next nil)))) 1628 (macrolet ((frob (type) 1629 `(replace-all (lambda (buffer from) 1630 (declare (type ,type result) 1631 (type (simple-array character (*)) 1632 buffer)) 1633 (replace result buffer :start1 from))))) 1634 (etypecase result 1635 ((simple-array character (*)) 1636 (frob (simple-array character (*)))) 1637 (simple-base-string 1638 (frob simple-base-string)) 1639 ((simple-array nil (*)) 1640 (frob (simple-array nil (*))))))) 1641 1642 result)) 1643 1644;;;; fill-pointer streams 1645 1646;;; Fill pointer STRING-OUTPUT-STREAMs are not explicitly mentioned in 1647;;; the CLM, but they are required for the implementation of 1648;;; WITH-OUTPUT-TO-STRING. 1649 1650;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope 1651;;; of efficiency. 1652(declaim (inline vector-with-fill-pointer-p)) 1653(defun vector-with-fill-pointer-p (x) 1654 (and (vectorp x) 1655 (array-has-fill-pointer-p x))) 1656 1657(deftype string-with-fill-pointer () 1658 `(and (or (vector character) (vector base-char)) 1659 (satisfies vector-with-fill-pointer-p))) 1660 1661(defstruct (fill-pointer-output-stream 1662 (:include ansi-stream 1663 (out #'fill-pointer-ouch) 1664 (sout #'fill-pointer-sout) 1665 (misc #'fill-pointer-misc)) 1666 (:constructor make-fill-pointer-output-stream (string)) 1667 (:copier nil) 1668 (:predicate nil)) 1669 ;; a string with a fill pointer where we stuff the stuff we write 1670 (string (missing-arg) :type string-with-fill-pointer :read-only t)) 1671 1672(declaim (freeze-type fill-pointer-output-stream)) 1673 1674(defun fill-pointer-ouch (stream character) 1675 (let* ((buffer (fill-pointer-output-stream-string stream)) 1676 (current (fill-pointer buffer)) 1677 (current+1 (1+ current))) 1678 (declare (fixnum current)) 1679 (with-array-data ((workspace buffer) (start) (end)) 1680 (string-dispatch 1681 ((simple-array character (*)) 1682 (simple-array base-char (*))) 1683 workspace 1684 (let ((offset-current (+ start current))) 1685 (declare (fixnum offset-current)) 1686 (if (= offset-current end) 1687 (let* ((new-length (1+ (* current 2))) 1688 (new-workspace 1689 (ecase (array-element-type workspace) 1690 (character (make-string new-length 1691 :element-type 'character)) 1692 (base-char (make-string new-length 1693 :element-type 'base-char))))) 1694 (replace new-workspace workspace :start2 start :end2 offset-current) 1695 (setf workspace new-workspace 1696 offset-current current) 1697 (set-array-header buffer workspace new-length 1698 current+1 0 new-length nil nil)) 1699 (setf (fill-pointer buffer) current+1)) 1700 (setf (char workspace offset-current) character)))) 1701 current+1)) 1702 1703(defun fill-pointer-sout (stream string start end) 1704 (declare (fixnum start end)) 1705 (string-dispatch 1706 ((simple-array character (*)) 1707 (simple-array base-char (*))) 1708 string 1709 (let* ((buffer (fill-pointer-output-stream-string stream)) 1710 (current (fill-pointer buffer)) 1711 (string-len (- end start)) 1712 (dst-end (+ string-len current))) 1713 (declare (fixnum current dst-end string-len)) 1714 (with-array-data ((workspace buffer) (dst-start) (dst-length)) 1715 (let ((offset-dst-end (+ dst-start dst-end)) 1716 (offset-current (+ dst-start current))) 1717 (declare (fixnum offset-dst-end offset-current)) 1718 (if (> offset-dst-end dst-length) 1719 (let* ((new-length (+ (the fixnum (* current 2)) string-len)) 1720 (new-workspace 1721 (ecase (array-element-type workspace) 1722 (character (make-string new-length 1723 :element-type 'character)) 1724 (base-char (make-string new-length 1725 :element-type 'base-char))))) 1726 (replace new-workspace workspace 1727 :start2 dst-start :end2 offset-current) 1728 (setf workspace new-workspace 1729 offset-current current 1730 offset-dst-end dst-end) 1731 (set-array-header buffer workspace new-length 1732 dst-end 0 new-length nil nil)) 1733 (setf (fill-pointer buffer) dst-end)) 1734 (replace workspace string 1735 :start1 offset-current :start2 start :end2 end))) 1736 dst-end))) 1737 1738(defun fill-pointer-misc (stream operation &optional arg1 arg2) 1739 (declare (ignore arg2)) 1740 (case operation 1741 (:file-position 1742 (let ((buffer (fill-pointer-output-stream-string stream))) 1743 (if arg1 1744 (setf (fill-pointer buffer) 1745 (case arg1 1746 (:start 0) 1747 ;; Fill-pointer is always at fill-pointer we will 1748 ;; make :END move to the end of the actual string. 1749 (:end (array-total-size buffer)) 1750 ;; We allow moving beyond the end of string if the 1751 ;; string is adjustable. 1752 (t (when (>= arg1 (array-total-size buffer)) 1753 (if (adjustable-array-p buffer) 1754 (adjust-array buffer arg1) 1755 (error "Cannot move FILE-POSITION beyond the end ~ 1756 of WITH-OUTPUT-TO-STRING stream ~ 1757 constructed with non-adjustable string."))) 1758 arg1))) 1759 (fill-pointer buffer)))) 1760 (:charpos 1761 (let* ((buffer (fill-pointer-output-stream-string stream)) 1762 (current (fill-pointer buffer))) 1763 (with-array-data ((string buffer) (start) (end current)) 1764 (declare (simple-string string)) 1765 (let ((found (position #\newline string :test #'char= 1766 :start start :end end 1767 :from-end t))) 1768 (if found 1769 (1- (- end found)) 1770 current))))) 1771 (:element-type 1772 (array-element-type 1773 (fill-pointer-output-stream-string stream))) 1774 (:element-mode 'character))) 1775 1776;;;; case frobbing streams, used by FORMAT ~(...~) 1777 1778(defstruct (case-frob-stream 1779 (:include ansi-stream 1780 (misc #'case-frob-misc)) 1781 (:constructor %make-case-frob-stream (target out sout)) 1782 (:copier nil)) 1783 (target (missing-arg) :type stream :read-only t)) 1784 1785(declaim (freeze-type case-frob-stream)) 1786 1787(defun make-case-frob-stream (target kind) 1788 #!+sb-doc 1789 "Return a stream that sends all output to the stream TARGET, but modifies 1790 the case of letters, depending on KIND, which should be one of: 1791 :UPCASE - convert to upper case. 1792 :DOWNCASE - convert to lower case. 1793 :CAPITALIZE - convert the first letter of words to upper case and the 1794 rest of the word to lower case. 1795 :CAPITALIZE-FIRST - convert the first letter of the first word to upper 1796 case and everything else to lower case." 1797 (declare (type stream target) 1798 (type (member :upcase :downcase :capitalize :capitalize-first) 1799 kind) 1800 (values stream)) 1801 (if (case-frob-stream-p target) 1802 ;; If we are going to be writing to a stream that already does 1803 ;; case frobbing, why bother frobbing the case just so it can 1804 ;; frob it again? 1805 target 1806 (multiple-value-bind (out sout) 1807 (ecase kind 1808 (:upcase 1809 (values #'case-frob-upcase-out 1810 #'case-frob-upcase-sout)) 1811 (:downcase 1812 (values #'case-frob-downcase-out 1813 #'case-frob-downcase-sout)) 1814 (:capitalize 1815 (values #'case-frob-capitalize-out 1816 #'case-frob-capitalize-sout)) 1817 (:capitalize-first 1818 (values #'case-frob-capitalize-first-out 1819 #'case-frob-capitalize-first-sout))) 1820 (%make-case-frob-stream target out sout)))) 1821 1822(defun case-frob-misc (stream op &optional arg1 arg2) 1823 (declare (type case-frob-stream stream)) 1824 (case op 1825 (:close 1826 (set-closed-flame stream)) 1827 (:element-mode 'character) 1828 (t 1829 (let ((target (case-frob-stream-target stream))) 1830 (if (ansi-stream-p target) 1831 (funcall (ansi-stream-misc target) target op arg1 arg2) 1832 (stream-misc-dispatch target op arg1 arg2)))))) 1833 1834(defun case-frob-upcase-out (stream char) 1835 (declare (type case-frob-stream stream) 1836 (type character char)) 1837 (let ((target (case-frob-stream-target stream)) 1838 (char (char-upcase char))) 1839 (if (ansi-stream-p target) 1840 (funcall (ansi-stream-out target) target char) 1841 (stream-write-char target char)))) 1842 1843(defun case-frob-upcase-sout (stream str start end) 1844 (declare (type case-frob-stream stream) 1845 (type simple-string str) 1846 (type index start) 1847 (type (or index null) end)) 1848 (let* ((target (case-frob-stream-target stream)) 1849 (len (length str)) 1850 (end (or end len)) 1851 (string (if (and (zerop start) (= len end)) 1852 (string-upcase str) 1853 (nstring-upcase (subseq str start end)))) 1854 (string-len (- end start))) 1855 (if (ansi-stream-p target) 1856 (funcall (ansi-stream-sout target) target string 0 string-len) 1857 (stream-write-string target string 0 string-len)))) 1858 1859(defun case-frob-downcase-out (stream char) 1860 (declare (type case-frob-stream stream) 1861 (type character char)) 1862 (let ((target (case-frob-stream-target stream)) 1863 (char (char-downcase char))) 1864 (if (ansi-stream-p target) 1865 (funcall (ansi-stream-out target) target char) 1866 (stream-write-char target char)))) 1867 1868(defun case-frob-downcase-sout (stream str start end) 1869 (declare (type case-frob-stream stream) 1870 (type simple-string str) 1871 (type index start) 1872 (type (or index null) end)) 1873 (let* ((target (case-frob-stream-target stream)) 1874 (len (length str)) 1875 (end (or end len)) 1876 (string (if (and (zerop start) (= len end)) 1877 (string-downcase str) 1878 (nstring-downcase (subseq str start end)))) 1879 (string-len (- end start))) 1880 (if (ansi-stream-p target) 1881 (funcall (ansi-stream-sout target) target string 0 string-len) 1882 (stream-write-string target string 0 string-len)))) 1883 1884(defun case-frob-capitalize-out (stream char) 1885 (declare (type case-frob-stream stream) 1886 (type character char)) 1887 (let ((target (case-frob-stream-target stream))) 1888 (cond ((alphanumericp char) 1889 (let ((char (char-upcase char))) 1890 (if (ansi-stream-p target) 1891 (funcall (ansi-stream-out target) target char) 1892 (stream-write-char target char))) 1893 (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) 1894 (setf (case-frob-stream-sout stream) 1895 #'case-frob-capitalize-aux-sout)) 1896 (t 1897 (if (ansi-stream-p target) 1898 (funcall (ansi-stream-out target) target char) 1899 (stream-write-char target char)))))) 1900 1901(defun case-frob-capitalize-sout (stream str start end) 1902 (declare (type case-frob-stream stream) 1903 (type simple-string str) 1904 (type index start) 1905 (type (or index null) end)) 1906 (let* ((target (case-frob-stream-target stream)) 1907 (str (subseq str start end)) 1908 (len (length str)) 1909 (inside-word nil)) 1910 (dotimes (i len) 1911 (let ((char (schar str i))) 1912 (cond ((not (alphanumericp char)) 1913 (setf inside-word nil)) 1914 (inside-word 1915 (setf (schar str i) (char-downcase char))) 1916 (t 1917 (setf inside-word t) 1918 (setf (schar str i) (char-upcase char)))))) 1919 (when inside-word 1920 (setf (case-frob-stream-out stream) 1921 #'case-frob-capitalize-aux-out) 1922 (setf (case-frob-stream-sout stream) 1923 #'case-frob-capitalize-aux-sout)) 1924 (if (ansi-stream-p target) 1925 (funcall (ansi-stream-sout target) target str 0 len) 1926 (stream-write-string target str 0 len)))) 1927 1928(defun case-frob-capitalize-aux-out (stream char) 1929 (declare (type case-frob-stream stream) 1930 (type character char)) 1931 (let ((target (case-frob-stream-target stream))) 1932 (cond ((alphanumericp char) 1933 (let ((char (char-downcase char))) 1934 (if (ansi-stream-p target) 1935 (funcall (ansi-stream-out target) target char) 1936 (stream-write-char target char)))) 1937 (t 1938 (if (ansi-stream-p target) 1939 (funcall (ansi-stream-out target) target char) 1940 (stream-write-char target char)) 1941 (setf (case-frob-stream-out stream) 1942 #'case-frob-capitalize-out) 1943 (setf (case-frob-stream-sout stream) 1944 #'case-frob-capitalize-sout))))) 1945 1946(defun case-frob-capitalize-aux-sout (stream str start end) 1947 (declare (type case-frob-stream stream) 1948 (type simple-string str) 1949 (type index start) 1950 (type (or index null) end)) 1951 (let* ((target (case-frob-stream-target stream)) 1952 (str (subseq str start end)) 1953 (len (length str)) 1954 (inside-word t)) 1955 (dotimes (i len) 1956 (let ((char (schar str i))) 1957 (cond ((not (alphanumericp char)) 1958 (setf inside-word nil)) 1959 (inside-word 1960 (setf (schar str i) (char-downcase char))) 1961 (t 1962 (setf inside-word t) 1963 (setf (schar str i) (char-upcase char)))))) 1964 (unless inside-word 1965 (setf (case-frob-stream-out stream) 1966 #'case-frob-capitalize-out) 1967 (setf (case-frob-stream-sout stream) 1968 #'case-frob-capitalize-sout)) 1969 (if (ansi-stream-p target) 1970 (funcall (ansi-stream-sout target) target str 0 len) 1971 (stream-write-string target str 0 len)))) 1972 1973(defun case-frob-capitalize-first-out (stream char) 1974 (declare (type case-frob-stream stream) 1975 (type character char)) 1976 (let ((target (case-frob-stream-target stream))) 1977 (cond ((alphanumericp char) 1978 (let ((char (char-upcase char))) 1979 (if (ansi-stream-p target) 1980 (funcall (ansi-stream-out target) target char) 1981 (stream-write-char target char))) 1982 (setf (case-frob-stream-out stream) 1983 #'case-frob-downcase-out) 1984 (setf (case-frob-stream-sout stream) 1985 #'case-frob-downcase-sout)) 1986 (t 1987 (if (ansi-stream-p target) 1988 (funcall (ansi-stream-out target) target char) 1989 (stream-write-char target char)))))) 1990 1991(defun case-frob-capitalize-first-sout (stream str start end) 1992 (declare (type case-frob-stream stream) 1993 (type simple-string str) 1994 (type index start) 1995 (type (or index null) end)) 1996 (let* ((target (case-frob-stream-target stream)) 1997 (str (subseq str start end)) 1998 (len (length str))) 1999 (dotimes (i len) 2000 (let ((char (schar str i))) 2001 (when (alphanumericp char) 2002 (setf (schar str i) (char-upcase char)) 2003 (do ((i (1+ i) (1+ i))) 2004 ((= i len)) 2005 (setf (schar str i) (char-downcase (schar str i)))) 2006 (setf (case-frob-stream-out stream) 2007 #'case-frob-downcase-out) 2008 (setf (case-frob-stream-sout stream) 2009 #'case-frob-downcase-sout) 2010 (return)))) 2011 (if (ansi-stream-p target) 2012 (funcall (ansi-stream-sout target) target str 0 len) 2013 (stream-write-string target str 0 len)))) 2014 2015;;;; Shared {READ,WRITE}-SEQUENCE support functions 2016 2017(declaim (inline stream-compute-io-function 2018 compatible-vector-and-stream-element-types-p)) 2019 2020(defun stream-compute-io-function (stream 2021 stream-element-mode sequence-element-type 2022 character-io binary-io bivalent-io) 2023 (ecase stream-element-mode 2024 (character 2025 character-io) 2026 ((unsigned-byte signed-byte) 2027 binary-io) 2028 (:bivalent 2029 (cond 2030 ((member sequence-element-type '(nil t)) 2031 bivalent-io) 2032 ;; Pick off common subtypes. 2033 ((eq sequence-element-type 'character) 2034 character-io) 2035 ((or (equal sequence-element-type '(unsigned-byte 8)) 2036 (equal sequence-element-type '(signed-byte 8))) 2037 binary-io) 2038 ;; Proper subtype tests. 2039 ((subtypep sequence-element-type 'character) 2040 character-io) 2041 ((subtypep sequence-element-type 'integer) 2042 binary-io) 2043 (t 2044 (error "~@<Cannot select IO functions to use for bivalent ~ 2045 stream ~S and a sequence with element-type ~S.~@:>" 2046 stream sequence-element-type)))))) 2047 2048(defun compatible-vector-and-stream-element-types-p (vector stream) 2049 (declare (type vector vector) 2050 (type ansi-stream stream)) 2051 (or (and (typep vector '(simple-array (unsigned-byte 8) (*))) 2052 (eq (stream-element-mode stream) 'unsigned-byte)) 2053 (and (typep vector '(simple-array (signed-byte 8) (*))) 2054 (eq (stream-element-mode stream) 'signed-byte)))) 2055 2056;;;; READ-SEQUENCE 2057 2058(defun read-sequence (seq stream &key (start 0) end) 2059 #!+sb-doc 2060 "Destructively modify SEQ by reading elements from STREAM. 2061 That part of SEQ bounded by START and END is destructively modified by 2062 copying successive elements into it from STREAM. If the end of file 2063 for STREAM is reached before copying all elements of the subsequence, 2064 then the extra elements near the end of sequence are not updated, and 2065 the index of the next element is returned." 2066 (declare (type sequence seq) 2067 (type stream stream) 2068 (type index start) 2069 (type sequence-end end) 2070 (values index)) 2071 (if (ansi-stream-p stream) 2072 (ansi-stream-read-sequence seq stream start end) 2073 ;; must be Gray streams FUNDAMENTAL-STREAM 2074 (stream-read-sequence stream seq start end))) 2075 2076(declaim (inline read-sequence/read-function)) 2077(defun read-sequence/read-function (seq stream start %end 2078 stream-element-mode 2079 character-read-function binary-read-function) 2080 (declare (type sequence seq) 2081 (type stream stream) 2082 (type index start) 2083 (type sequence-end %end) 2084 (type stream-element-mode stream-element-mode) 2085 (type function character-read-function binary-read-function) 2086 (values index &optional)) 2087 (let ((end (or %end (length seq)))) 2088 (declare (type index end)) 2089 (labels ((compute-read-function (sequence-element-type) 2090 (stream-compute-io-function 2091 stream 2092 stream-element-mode sequence-element-type 2093 character-read-function binary-read-function 2094 character-read-function)) 2095 (read-list (read-function) 2096 (do ((rem (nthcdr start seq) (rest rem)) 2097 (i start (1+ i))) 2098 ((or (endp rem) (>= i end)) i) 2099 (declare (type list rem) 2100 (type index i)) 2101 (let ((el (funcall read-function stream nil :eof nil))) 2102 (when (eq el :eof) 2103 (return i)) 2104 (setf (first rem) el)))) 2105 (read-vector/fast (data offset-start) 2106 (let* ((numbytes (- end start)) 2107 (bytes-read (read-n-bytes 2108 stream data offset-start numbytes nil))) 2109 (if (< bytes-read numbytes) 2110 (+ start bytes-read) 2111 end))) 2112 (read-vector (read-function data offset-start offset-end) 2113 (do ((i offset-start (1+ i))) 2114 ((>= i offset-end) end) 2115 (declare (type index i)) 2116 (let ((el (funcall read-function stream nil :eof nil))) 2117 (when (eq el :eof) 2118 (return (+ start (- i offset-start)))) 2119 (setf (aref data i) el)))) 2120 (read-generic-sequence (read-function) 2121 (declare (ignore read-function)) 2122 (error "~@<~A does not yet support generic sequences.~@:>" 2123 'read-sequence))) 2124 (declare (dynamic-extent #'compute-read-function 2125 #'read-list #'read-vector/fast #'read-vector 2126 #'read-generic-sequence)) 2127 (cond 2128 ((typep seq 'list) 2129 (read-list (compute-read-function nil))) 2130 ((and (ansi-stream-p stream) 2131 (ansi-stream-cin-buffer stream) 2132 (typep seq 'simple-string)) 2133 (ansi-stream-read-string-from-frc-buffer seq stream start %end)) 2134 ((typep seq 'vector) 2135 (with-array-data ((data seq) (offset-start start) (offset-end end) 2136 :check-fill-pointer t) 2137 (if (and (ansi-stream-p stream) 2138 (compatible-vector-and-stream-element-types-p data stream)) 2139 (read-vector/fast data offset-start) 2140 (read-vector (compute-read-function (array-element-type data)) 2141 data offset-start offset-end)))) 2142 (t 2143 (read-generic-sequence (compute-read-function nil))))))) 2144(declaim (notinline read-sequence/read-function)) 2145 2146(defun ansi-stream-read-sequence (seq stream start %end) 2147 (declare (type sequence seq) 2148 (type ansi-stream stream) 2149 (type index start) 2150 (type sequence-end %end) 2151 (values index &optional)) 2152 (locally (declare (inline read-sequence/read-function)) 2153 (read-sequence/read-function 2154 seq stream start %end (stream-element-mode stream) 2155 #'ansi-stream-read-char #'ansi-stream-read-byte))) 2156 2157(defun ansi-stream-read-string-from-frc-buffer (seq stream start %end) 2158 (declare (type simple-string seq) 2159 (type ansi-stream stream) 2160 (type index start) 2161 (type (or null index) %end)) 2162 (let ((needed (- (or %end (length seq)) 2163 start)) 2164 (read 0)) 2165 (prepare-for-fast-read-char stream 2166 (declare (ignore %frc-method%)) 2167 (unless %frc-buffer% 2168 (return-from ansi-stream-read-string-from-frc-buffer nil)) 2169 (labels ((refill-buffer () 2170 (prog1 (fast-read-char-refill stream nil) 2171 (setf %frc-index% (ansi-stream-in-index %frc-stream%)))) 2172 (add-chunk () 2173 (let* ((end (length %frc-buffer%)) 2174 (len (min (- end %frc-index%) 2175 (- needed read)))) 2176 (declare (type index end len read needed)) 2177 (string-dispatch (simple-base-string 2178 (simple-array character (*))) 2179 seq 2180 (replace seq %frc-buffer% 2181 :start1 (+ start read) 2182 :end1 (+ start read len) 2183 :start2 %frc-index% 2184 :end2 (+ %frc-index% len))) 2185 (incf read len) 2186 (incf %frc-index% len) 2187 (when (or (eql needed read) (not (refill-buffer))) 2188 (done-with-fast-read-char) 2189 (return-from ansi-stream-read-string-from-frc-buffer 2190 (+ start read)))))) 2191 (declare (inline refill-buffer)) 2192 (when (and (= %frc-index% +ansi-stream-in-buffer-length+) 2193 (not (refill-buffer))) 2194 ;; EOF had been reached before we read anything 2195 ;; at all. But READ-SEQUENCE never signals an EOF error. 2196 (done-with-fast-read-char) 2197 (return-from ansi-stream-read-string-from-frc-buffer start)) 2198 (loop (add-chunk)))))) 2199 2200 2201;;;; WRITE-SEQUENCE 2202 2203(defun write-sequence (seq stream &key (start 0) (end nil)) 2204 #!+sb-doc 2205 "Write the elements of SEQ bounded by START and END to STREAM." 2206 (declare (type sequence seq) 2207 (type stream stream) 2208 (type index start) 2209 (type sequence-end end) 2210 (values sequence)) 2211 (if (ansi-stream-p stream) 2212 (ansi-stream-write-sequence seq stream start end) 2213 ;; must be Gray-streams FUNDAMENTAL-STREAM 2214 (stream-write-sequence stream seq start end))) 2215 2216;;; This macro allows sharing code between 2217;;; WRITE-SEQUENCE/WRITE-FUNCTION and SB-GRAY:STREAM-WRITE-STRING. 2218(defmacro write-sequence/vector ((seq type) stream start end write-function) 2219 (once-only ((seq seq) (stream stream) (start start) (end end) 2220 (write-function write-function)) 2221 `(locally 2222 (declare (type ,type ,seq) 2223 (type index ,start ,end) 2224 (type function ,write-function)) 2225 (do ((i ,start (1+ i))) 2226 ((>= i ,end)) 2227 (declare (type index i)) 2228 (funcall ,write-function ,stream (aref ,seq i)))))) 2229 2230(declaim (inline write-sequence/write-function)) 2231(defun write-sequence/write-function (seq stream start %end 2232 stream-element-mode 2233 character-write-function 2234 binary-write-function) 2235 (declare (type sequence seq) 2236 (type stream stream) 2237 (type index start) 2238 (type sequence-end %end) 2239 (type stream-element-mode stream-element-mode) 2240 (type function character-write-function binary-write-function)) 2241 (let ((end (or %end (length seq)))) 2242 (declare (type index end)) 2243 (labels ((compute-write-function (sequence-element-type) 2244 (stream-compute-io-function 2245 stream 2246 stream-element-mode sequence-element-type 2247 character-write-function binary-write-function 2248 #'write-element/bivalent)) 2249 (write-element/bivalent (stream object) 2250 (if (characterp object) 2251 (funcall character-write-function stream object) 2252 (funcall binary-write-function stream object))) 2253 (write-list (write-function) 2254 (do ((rem (nthcdr start seq) (rest rem)) 2255 (i start (1+ i))) 2256 ((or (endp rem) (>= i end))) 2257 (declare (type list rem) 2258 (type index i)) 2259 (funcall write-function stream (first rem)))) 2260 (write-vector (data start end write-function) 2261 (write-sequence/vector 2262 (data (simple-array * (*))) stream start end write-function)) 2263 (write-generic-sequence (write-function) 2264 (declare (ignore write-function)) 2265 (error "~@<~A does not yet support generic sequences.~@:>" 2266 'write-sequence))) 2267 (declare (dynamic-extent #'compute-write-function 2268 #'write-element/bivalent #'write-list 2269 #'write-vector #'write-generic-sequence)) 2270 (etypecase seq 2271 (list 2272 (write-list (compute-write-function nil))) 2273 (string 2274 (if (ansi-stream-p stream) 2275 (ansi-stream-write-string seq stream start end) 2276 (stream-write-string stream seq start end))) 2277 (vector 2278 (with-array-data ((data seq) (offset-start start) (offset-end end) 2279 :check-fill-pointer t) 2280 (if (and (fd-stream-p stream) 2281 (compatible-vector-and-stream-element-types-p data stream)) 2282 (buffer-output stream data offset-start offset-end) 2283 (write-vector data offset-start offset-end 2284 (compute-write-function 2285 (array-element-type seq)))))) 2286 (sequence 2287 (write-generic-sequence (compute-write-function nil))))))) 2288(declaim (notinline write-sequence/write-function)) 2289 2290(defun ansi-stream-write-sequence (seq stream start %end) 2291 (declare (type sequence seq) 2292 (type ansi-stream stream) 2293 (type index start) 2294 (type sequence-end %end) 2295 (values sequence)) 2296 (locally (declare (inline write-sequence/write-function)) 2297 (write-sequence/write-function 2298 seq stream start %end (stream-element-mode stream) 2299 (ansi-stream-out stream) (ansi-stream-bout stream))) 2300 seq) 2301 2302;;; like FILE-POSITION, only using :FILE-LENGTH 2303(defun file-length (stream) 2304 ;; FIXME: the FIXME following this one seems wrong on 2 counts: 2305 ;; 1. since when does cross-compiler hangup occur on undefined types? 2306 ;; 2. why is that the correct set of types to check for? 2307 ;; FIXME: The following declaration uses yet undefined types, which 2308 ;; cause cross-compiler hangup. 2309 ;; 2310 ;; (declare (type (or file-stream synonym-stream) stream)) 2311 ;; 2312 ;; The description for FILE-LENGTH says that an error must be raised 2313 ;; for streams not associated with files (which broadcast streams 2314 ;; aren't according to the glossary). However, the behaviour of 2315 ;; FILE-LENGTH for broadcast streams is explicitly described in the 2316 ;; BROADCAST-STREAM entry. 2317 (unless (typep stream 'broadcast-stream) 2318 (stream-must-be-associated-with-file stream)) 2319 (funcall (ansi-stream-misc stream) stream :file-length)) 2320 2321;; Placing this definition (formerly in "toplevel") after the important 2322;; stream types are known produces smaller+faster code than it did before. 2323(defun stream-output-stream (stream) 2324 (typecase stream 2325 (fd-stream 2326 stream) 2327 (synonym-stream 2328 (stream-output-stream 2329 (symbol-value (synonym-stream-symbol stream)))) 2330 (two-way-stream 2331 (stream-output-stream 2332 (two-way-stream-output-stream stream))) 2333 (t 2334 stream))) 2335 2336;;;; etc. 2337