(defun ill-in (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
- :datum stream
- :expected-type '(satisfies input-stream-p)
- :format-control "~S is not a character input stream."
- :format-arguments (list stream)))
+ :datum stream
+ :expected-type '(satisfies input-stream-p)
+ :format-control "~S is not a character input stream."
+ :format-arguments (list stream)))
(defun ill-out (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
- :datum stream
- :expected-type '(satisfies output-stream-p)
- :format-control "~S is not a character output stream."
- :format-arguments (list stream)))
+ :datum stream
+ :expected-type '(satisfies output-stream-p)
+ :format-control "~S is not a character output stream."
+ :format-arguments (list stream)))
(defun ill-bin (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
- :datum stream
- :expected-type '(satisfies input-stream-p)
- :format-control "~S is not a binary input stream."
- :format-arguments (list stream)))
+ :datum stream
+ :expected-type '(satisfies input-stream-p)
+ :format-control "~S is not a binary input stream."
+ :format-arguments (list stream)))
(defun ill-bout (stream &rest ignore)
(declare (ignore ignore))
(error 'simple-type-error
- :datum stream
- :expected-type '(satisfies output-stream-p)
- :format-control "~S is not a binary output stream."
- :format-arguments (list stream)))
+ :datum stream
+ :expected-type '(satisfies output-stream-p)
+ :format-control "~S is not a binary output stream."
+ :format-arguments (list stream)))
(defun closed-flame (stream &rest ignore)
(declare (ignore ignore))
- (error "~S is closed." stream))
+ (error 'closed-stream-error :stream stream))
(defun no-op-placeholder (&rest ignore)
(declare (ignore ignore)))
\f
;;; stream manipulation functions
-(declaim (inline ansi-stream-input-stream-p))
(defun ansi-stream-input-stream-p (stream)
(declare (type ansi-stream stream))
-
- (when (synonym-stream-p stream)
- (setf stream
- (symbol-value (synonym-stream-symbol stream))))
-
- (and (not (eq (ansi-stream-in stream) #'closed-flame))
+ (if (synonym-stream-p stream)
+ (input-stream-p (symbol-value (synonym-stream-symbol stream)))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
;;; KLUDGE: It's probably not good to have EQ tests on function
;;; values like this. What if someone's redefined the function?
;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
- (or (not (eq (ansi-stream-in stream) #'ill-in))
- (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+ (or (not (eq (ansi-stream-in stream) #'ill-in))
+ (not (eq (ansi-stream-bin stream) #'ill-bin))))))
(defun input-stream-p (stream)
(declare (type stream stream))
(and (ansi-stream-p stream)
(ansi-stream-input-stream-p stream)))
-(declaim (inline ansi-stream-output-stream-p))
(defun ansi-stream-output-stream-p (stream)
(declare (type ansi-stream stream))
-
- (when (synonym-stream-p stream)
- (setf stream (symbol-value
- (synonym-stream-symbol stream))))
-
- (and (not (eq (ansi-stream-in stream) #'closed-flame))
- (or (not (eq (ansi-stream-out stream) #'ill-out))
- (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+ (if (synonym-stream-p stream)
+ (output-stream-p (symbol-value (synonym-stream-symbol stream)))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
+ (or (not (eq (ansi-stream-out stream) #'ill-out))
+ (not (eq (ansi-stream-bout stream) #'ill-bout))))))
(defun output-stream-p (stream)
(declare (type stream stream))
(defun stream-element-type (stream)
(ansi-stream-element-type stream))
+(defun stream-external-format (stream)
+ (funcall (ansi-stream-misc stream) stream :external-format))
+
(defun interactive-stream-p (stream)
(declare (type stream stream))
(funcall (ansi-stream-misc stream) stream :interactive-p))
(setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-bin stream) #'closed-flame)
(setf (ansi-stream-n-bin stream) #'closed-flame)
- (setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-out stream) #'closed-flame)
(setf (ansi-stream-bout stream) #'closed-flame)
(setf (ansi-stream-sout stream) #'closed-flame)
(setf (ansi-stream-misc stream) #'closed-flame))
\f
-;;;; file position and file length
+;;;; for file position and file length
+(defun external-format-char-size (external-format)
+ (ef-char-size (get-external-format external-format)))
;;; Call the MISC method with the :FILE-POSITION operation.
-(defun file-position (stream &optional position)
+#!-sb-fluid (declaim (inline ansi-stream-file-position))
+(defun ansi-stream-file-position (stream position)
(declare (type stream stream))
- (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position))
+ (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
+ position))
+ ;; FIXME: It would be good to comment on the stuff that is done here...
+ ;; FIXME: This doesn't look interrupt safe.
(cond
- (position
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc stream) stream :file-position position))
- (t
- (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
- (when res
- (- res
- (- +ansi-stream-in-buffer-length+
- (ansi-stream-in-index stream))))))))
+ (position
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc stream) stream :file-position position))
+ (t
+ (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
+ (when res
+ #!-sb-unicode
+ (- res
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream)))
+ #!+sb-unicode
+ (let ((char-size (if (fd-stream-p stream)
+ (fd-stream-char-size stream)
+ (external-format-char-size (stream-external-format stream)))))
+ (- res
+ (etypecase char-size
+ (function
+ (loop with buffer = (ansi-stream-cin-buffer stream)
+ with start = (ansi-stream-in-index stream)
+ for i from start below +ansi-stream-in-buffer-length+
+ sum (funcall char-size (aref buffer i))))
+ (fixnum
+ (* char-size
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream))))))))))))
+
+(defun file-position (stream &optional position)
+ (if (ansi-stream-p stream)
+ (ansi-stream-file-position stream position)
+ (stream-file-position stream position)))
;;; This is a literal translation of the ANSI glossary entry "stream
;;; associated with a file".
"Test for the ANSI concept \"stream associated with a file\"."
(or (typep x 'file-stream)
(and (synonym-stream-p x)
- (stream-associated-with-file-p (symbol-value
- (synonym-stream-symbol x))))))
+ (stream-associated-with-file-p (symbol-value
+ (synonym-stream-symbol x))))))
(defun stream-must-be-associated-with-file (stream)
(declare (type stream stream))
(unless (stream-associated-with-file-p stream)
(error 'simple-type-error
- ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
- ;; this should be TYPE-ERROR. But what then can we use for
- ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
- ;; private predicate function..) is ugly and confusing, but
- ;; I can't see any other way. -- WHN 2001-04-14
- :expected-type '(satisfies stream-associated-with-file-p)
- :format-control
- "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
- :format-arguments (list stream))))
+ ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
+ ;; this should be TYPE-ERROR. But what then can we use for
+ ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
+ ;; private predicate function..) is ugly and confusing, but
+ ;; I can't see any other way. -- WHN 2001-04-14
+ :datum stream
+ :expected-type '(satisfies stream-associated-with-file-p)
+ :format-control
+ "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
+ :format-arguments (list stream))))
;;; like FILE-POSITION, only using :FILE-LENGTH
(defun file-length (stream)
;; cause cross-compiler hangup.
;;
;; (declare (type (or file-stream synonym-stream) stream))
- (stream-must-be-associated-with-file stream)
+ ;;
+ ;; The description for FILE-LENGTH says that an error must be raised
+ ;; for streams not associated with files (which broadcast streams
+ ;; aren't according to the glossary). However, the behaviour of
+ ;; FILE-LENGTH for broadcast streams is explicitly described in the
+ ;; BROADCAST-STREAM entry.
+ (unless (typep stream 'broadcast-stream)
+ (stream-must-be-associated-with-file stream))
(funcall (ansi-stream-misc stream) stream :file-length))
+
+(defun file-string-length (stream object)
+ (funcall (ansi-stream-misc stream) stream :file-string-length object))
\f
;;;; input functions
-(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
- recursive-p)
+(defun ansi-stream-read-line-from-frc-buffer (stream eof-error-p eof-value)
+ (prepare-for-fast-read-char stream
+ (declare (ignore %frc-method%))
+ (let ((chunks-total-length 0)
+ (chunks nil))
+ (declare (type index chunks-total-length)
+ (list chunks))
+ (labels ((refill-buffer ()
+ (prog1
+ (fast-read-char-refill stream nil nil)
+ (setf %frc-index% (ansi-stream-in-index %frc-stream%))))
+ (newline-position ()
+ (position #\Newline (the (simple-array character (*))
+ %frc-buffer%)
+ :test #'char=
+ :start %frc-index%))
+ (make-and-return-result-string (pos)
+ (let* ((len (+ (- (or pos %frc-index%)
+ %frc-index%)
+ chunks-total-length))
+ (res (make-string len))
+ (start 0))
+ (declare (type index start))
+ (when chunks
+ (dolist (chunk (nreverse chunks))
+ (declare (type (simple-array character) chunk))
+ (replace res chunk :start1 start)
+ (incf start (length chunk))))
+ (unless (null pos)
+ (replace res %frc-buffer%
+ :start1 start
+ :start2 %frc-index% :end2 pos)
+ (setf %frc-index% (1+ pos)))
+ (done-with-fast-read-char)
+ (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))
+ (add-chunk ()
+ (let* ((end (length %frc-buffer%))
+ (len (- end %frc-index%))
+ (chunk (make-string len)))
+ (replace chunk %frc-buffer% :start2 %frc-index% :end2 end)
+ (push chunk chunks)
+ (incf chunks-total-length len)
+ (when (refill-buffer)
+ (make-and-return-result-string nil)))))
+ (declare (inline make-and-return-result-string
+ refill-buffer))
+ (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
+ (refill-buffer))
+ ;; EOF had been reached before we read anything
+ ;; at all. Return the EOF value or signal the error.
+ (done-with-fast-read-char)
+ (return-from ansi-stream-read-line-from-frc-buffer
+ (values (eof-or-lose stream eof-error-p eof-value) t)))
+ (loop
+ (let ((pos (newline-position)))
+ (if pos
+ (make-and-return-result-string pos)
+ (add-chunk))))))))
+
+#!-sb-fluid (declaim (inline ansi-stream-read-line))
+(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
+ (if (ansi-stream-cin-buffer stream)
+ ;; Stream has a fast-read-char buffer. Copy large chunks directly
+ ;; out of the buffer.
+ (ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value)
+ ;; Slow path, character by character.
+ (prepare-for-fast-read-char stream
+ (let ((res (make-string 80))
+ (len 80)
+ (index 0))
+ (loop
+ (let ((ch (fast-read-char nil nil)))
+ (cond (ch
+ (when (char= ch #\newline)
+ (done-with-fast-read-char)
+ (return (values (%shrink-vector res index) nil)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index))
+ ((zerop index)
+ (done-with-fast-read-char)
+ (return (values (eof-or-lose stream
+ eof-error-p
+ eof-value)
+ t)))
+ ;; Since FAST-READ-CHAR already hit the eof char, we
+ ;; shouldn't do another READ-CHAR.
+ (t
+ (done-with-fast-read-char)
+ (return (values (%shrink-vector res index) t))))))))))
+
+(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
+ recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
- (let ((res (make-string 80))
- (len 80)
- (index 0))
- (loop
- (let ((ch (fast-read-char nil nil)))
- (cond (ch
- (when (char= ch #\newline)
- (done-with-fast-read-char)
- (return (values (shrink-vector res index) nil)))
- (when (= index len)
- (setq len (* len 2))
- (let ((new (make-string len)))
- (replace new res)
- (setq res new)))
- (setf (schar res index) ch)
- (incf index))
- ((zerop index)
- (done-with-fast-read-char)
- (return (values (eof-or-lose stream
- eof-error-p
- eof-value)
- t)))
- ;; Since FAST-READ-CHAR already hit the eof char, we
- ;; shouldn't do another READ-CHAR.
- (t
- (done-with-fast-read-char)
- (return (values (shrink-vector res index) t))))))))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (multiple-value-bind (string eof) (stream-read-line stream)
- (if (and eof (zerop (length string)))
- (values (eof-or-lose stream eof-error-p eof-value) t)
- (values string eof))))))
-
-;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF,
+ (ansi-stream-read-line stream eof-error-p eof-value recursive-p)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (multiple-value-bind (string eof) (stream-read-line stream)
+ (if (and eof (zerop (length string)))
+ (values (eof-or-lose stream eof-error-p eof-value) t)
+ (values string eof))))))
+
+;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on,
;;; so, except in this file, they are not inline by default, but they can be.
#!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
-(defun read-char (&optional (stream *standard-input*)
- (eof-error-p t)
- eof-value
- recursive-p)
+#!-sb-fluid (declaim (inline ansi-stream-read-char))
+(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
+ (prepare-for-fast-read-char stream
+ (prog1
+ (fast-read-char eof-error-p eof-value)
+ (done-with-fast-read-char))))
+
+(defun read-char (&optional (stream *standard-input*)
+ (eof-error-p t)
+ eof-value
+ recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (prepare-for-fast-read-char stream
- (prog1
- (fast-read-char eof-error-p eof-value)
- (done-with-fast-read-char)))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (let ((char (stream-read-char stream)))
- (if (eq char :eof)
- (eof-or-lose stream eof-error-p eof-value)
- char)))))
+ (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (let ((char (stream-read-char stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))
+
+#!-sb-fluid (declaim (inline ansi-stream-unread-char))
+(defun ansi-stream-unread-char (character stream)
+ (let ((index (1- (ansi-stream-in-index stream)))
+ (buffer (ansi-stream-cin-buffer stream)))
+ (declare (fixnum index))
+ (when (minusp index) (error "nothing to unread"))
+ (cond (buffer
+ (setf (aref buffer index) character)
+ (setf (ansi-stream-in-index stream) index))
+ (t
+ (funcall (ansi-stream-misc stream) stream
+ :unread character)))))
(defun unread-char (character &optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (let ((index (1- (ansi-stream-in-index stream)))
- (buffer (ansi-stream-in-buffer stream)))
- (declare (fixnum index))
- (when (minusp index) (error "nothing to unread"))
- (cond (buffer
- (setf (aref buffer index) (char-code character))
- (setf (ansi-stream-in-index stream) index))
- (t
- (funcall (ansi-stream-misc stream) stream
- :unread character))))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (stream-unread-char stream character)))
+ (ansi-stream-unread-char character stream)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-unread-char stream character)))
nil)
+#!-sb-fluid (declaim (inline ansi-stream-listen))
+(defun ansi-stream-listen (stream)
+ (or (/= (the fixnum (ansi-stream-in-index stream))
+ +ansi-stream-in-buffer-length+)
+ ;; Handle :EOF return from misc methods specially
+ (let ((result (funcall (ansi-stream-misc stream) stream :listen)))
+ (if (eq result :eof)
+ nil
+ result))))
+
(defun listen (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (or (/= (the fixnum (ansi-stream-in-index stream))
- +ansi-stream-in-buffer-length+)
- ;; Test for T explicitly since misc methods return :EOF sometimes.
- (eq (funcall (ansi-stream-misc stream) stream :listen) t))
- ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
- (stream-listen stream))))
+ (ansi-stream-listen stream)
+ ;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
+ (stream-listen stream))))
+
+#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang))
+(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p)
+ (if (funcall (ansi-stream-misc stream) stream :listen)
+ ;; On T or :EOF get READ-CHAR to do the work.
+ (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
+ nil))
(defun read-char-no-hang (&optional (stream *standard-input*)
- (eof-error-p t)
- eof-value
- recursive-p)
- (declare (ignore recursive-p))
+ (eof-error-p t)
+ eof-value
+ recursive-p)
(let ((stream (in-synonym-of stream)))
(if (ansi-stream-p stream)
- (if (funcall (ansi-stream-misc stream) stream :listen)
- ;; On T or :EOF get READ-CHAR to do the work.
- (read-char stream eof-error-p eof-value)
- nil)
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (let ((char (stream-read-char-no-hang stream)))
- (if (eq char :eof)
- (eof-or-lose stream eof-error-p eof-value)
- char)))))
+ (ansi-stream-read-char-no-hang stream eof-error-p eof-value
+ recursive-p)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (let ((char (stream-read-char-no-hang stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))
+
+#!-sb-fluid (declaim (inline ansi-stream-clear-input))
+(defun ansi-stream-clear-input (stream)
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc stream) stream :clear-input))
(defun clear-input (&optional (stream *standard-input*))
(let ((stream (in-synonym-of stream)))
- (cond ((ansi-stream-p stream)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc stream) stream :clear-input))
- (t
- (stream-clear-input stream))))
+ (if (ansi-stream-p stream)
+ (ansi-stream-clear-input stream)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-clear-input stream)))
nil)
\f
-(declaim (maybe-inline read-byte))
+#!-sb-fluid (declaim (inline ansi-stream-read-byte))
+(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p)
+ ;; Why the "recursive-p" parameter? a-s-r-b is funcall'ed from
+ ;; a-s-read-sequence and needs a lambda list that's congruent with
+ ;; that of a-s-read-char
+ (declare (ignore recursive-p))
+ (with-fast-read-byte (t stream eof-error-p eof-value)
+ (fast-read-byte)))
+
(defun read-byte (stream &optional (eof-error-p t) eof-value)
- (let ((stream (in-synonym-of stream)))
- (if (ansi-stream-p stream)
- (prepare-for-fast-read-byte stream
- (prog1
- (fast-read-byte eof-error-p eof-value t)
- (done-with-fast-read-byte)))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (let ((char (stream-read-byte stream)))
- (if (eq char :eof)
- (eof-or-lose stream eof-error-p eof-value)
- char)))))
+ (if (ansi-stream-p stream)
+ (ansi-stream-read-byte stream eof-error-p eof-value nil)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (let ((char (stream-read-byte stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char))))
;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
;;; number of bytes read.
;;; some cases, but it wasn't being used in SBCL, so it was dropped.
;;; If we ever need it, it could be added later as a new variant N-BIN
;;; method (perhaps N-BIN-ASAP?) or something.
+#!-sb-fluid (declaim (inline read-n-bytes))
(defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
+ (if (ansi-stream-p stream)
+ (ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p)
+ ;; We don't need to worry about element-type size here is that
+ ;; callers are supposed to have checked everything is kosher.
+ (let* ((end (+ start numbytes))
+ (read-end (stream-read-sequence stream buffer start end)))
+ (eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start)))))
+
+(defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p)
(declare (type ansi-stream stream)
- (type index numbytes start)
- (type (or (simple-array * (*)) system-area-pointer) buffer))
+ (type index numbytes start)
+ (type (or (simple-array * (*)) system-area-pointer) buffer))
(let* ((stream (in-synonym-of stream ansi-stream))
- (in-buffer (ansi-stream-in-buffer stream))
- (index (ansi-stream-in-index stream))
- (num-buffered (- +ansi-stream-in-buffer-length+ index)))
+ (in-buffer (ansi-stream-in-buffer stream))
+ (index (ansi-stream-in-index stream))
+ (num-buffered (- +ansi-stream-in-buffer-length+ index)))
(declare (fixnum index num-buffered))
(cond
((not in-buffer)
(funcall (ansi-stream-n-bin stream)
- stream
- buffer
- start
- numbytes
- eof-error-p))
+ stream
+ buffer
+ start
+ numbytes
+ eof-error-p))
((<= numbytes num-buffered)
+ #+nil
+ (let ((copy-function (typecase buffer
+ ((simple-array * (*)) #'ub8-bash-copy)
+ (system-area-pointer #'copy-ub8-to-system-area))))
+ (funcall copy-function in-buffer index buffer start numbytes))
(%byte-blt in-buffer index
- buffer start (+ start numbytes))
+ buffer start (+ start numbytes))
(setf (ansi-stream-in-index stream) (+ index numbytes))
numbytes)
(t
(let ((end (+ start num-buffered)))
- (%byte-blt in-buffer index buffer start end)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (+ (funcall (ansi-stream-n-bin stream)
- stream
- buffer
- end
- (- numbytes num-buffered)
- eof-error-p)
- num-buffered))))))
+ #+nil
+ (let ((copy-function (typecase buffer
+ ((simple-array * (*)) #'ub8-bash-copy)
+ (system-area-pointer #'copy-ub8-to-system-area))))
+ (funcall copy-function in-buffer index buffer start num-buffered))
+ (%byte-blt in-buffer index buffer start end)
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (+ (funcall (ansi-stream-n-bin stream)
+ stream
+ buffer
+ end
+ (- numbytes num-buffered)
+ eof-error-p)
+ num-buffered))))))
;;; the amount of space we leave at the start of the in-buffer for
;;; unreading
;;; This function is called by the FAST-READ-CHAR expansion to refill
;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
-;;; and hence must be an N-BIN method.
+;;; and hence must be an N-BIN method. It's also called by other stream
+;;; functions which directly peek into the frc buffer.
(defun fast-read-char-refill (stream eof-error-p eof-value)
- (let* ((ibuf (ansi-stream-in-buffer stream))
- (count (funcall (ansi-stream-n-bin stream)
- stream
- ibuf
- +ansi-stream-in-buffer-extra+
- (- +ansi-stream-in-buffer-length+
- +ansi-stream-in-buffer-extra+)
- nil))
- (start (- +ansi-stream-in-buffer-length+ count)))
+ (let* ((ibuf (ansi-stream-cin-buffer stream))
+ (count (funcall (ansi-stream-n-bin stream)
+ stream
+ ibuf
+ +ansi-stream-in-buffer-extra+
+ (- +ansi-stream-in-buffer-length+
+ +ansi-stream-in-buffer-extra+)
+ nil))
+ (start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
- (t
- (when (/= start +ansi-stream-in-buffer-extra+)
- (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
- sb!vm:n-byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- ibuf (+ (the index (* start sb!vm:n-byte-bits))
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (* count sb!vm:n-byte-bits)))
- (setf (ansi-stream-in-index stream) (1+ start))
- (code-char (aref ibuf start))))))
+ ;; An empty count does not necessarily mean that we reached
+ ;; the EOF, it's also possible that it's e.g. due to a
+ ;; invalid octet sequence in a multibyte stream. To handle
+ ;; the resyncing case correctly we need to call the reading
+ ;; function and check whether an EOF was really reached. If
+ ;; not, we can just fill the buffer by one character, and
+ ;; hope that the next refill will not need to resync.
+ ;;
+ ;; KLUDGE: we can't use FD-STREAM functions (which are the
+ ;; only ones which will give us decoding errors) here,
+ ;; because this code is generic. We can't call the N-BIN
+ ;; function, because near the end of a real file that can
+ ;; legitimately bounce us to the IN function. So we have
+ ;; to call ANSI-STREAM-IN.
+ (let* ((index (1- +ansi-stream-in-buffer-length+))
+ (value (funcall (ansi-stream-in stream) stream nil :eof)))
+ (cond
+ ((eql value :eof)
+ ;; definitely EOF now
+ (setf (ansi-stream-in-index stream)
+ +ansi-stream-in-buffer-length+)
+ (values t (eof-or-lose stream eof-error-p eof-value)))
+ ;; we resynced or were given something instead
+ (t
+ (setf (aref ibuf index) value)
+ (values nil (setf (ansi-stream-in-index stream) index))))))
+ (t
+ (when (/= start +ansi-stream-in-buffer-extra+)
+ (#.(let* ((n-character-array-bits
+ (sb!vm:saetp-n-bits
+ (find 'character
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-specifier)))
+ (bash-function (intern (format nil "UB~D-BASH-COPY" n-character-array-bits)
+ (find-package "SB!KERNEL"))))
+ bash-function)
+ ibuf +ansi-stream-in-buffer-extra+
+ ibuf start
+ count))
+ (values nil
+ (setf (ansi-stream-in-index stream) start))))))
;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
;;; leave room for unreading.
(defun fast-read-byte-refill (stream eof-error-p eof-value)
(let* ((ibuf (ansi-stream-in-buffer stream))
- (count (funcall (ansi-stream-n-bin stream) stream
- ibuf 0 +ansi-stream-in-buffer-length+
- nil))
- (start (- +ansi-stream-in-buffer-length+ count)))
+ (count (funcall (ansi-stream-n-bin stream) stream
+ ibuf 0 +ansi-stream-in-buffer-length+
+ nil))
+ (start (- +ansi-stream-in-buffer-length+ count)))
(declare (type index start count))
(cond ((zerop count)
- (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
- (t
- (unless (zerop start)
- (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
- ibuf (+ (the index (* start sb!vm:n-byte-bits))
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (* count sb!vm:n-byte-bits)))
- (setf (ansi-stream-in-index stream) (1+ start))
- (aref ibuf start)))))
+ (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
+ (t
+ (unless (zerop start)
+ (ub8-bash-copy ibuf 0
+ ibuf start
+ count))
+ (setf (ansi-stream-in-index stream) (1+ start))
+ (aref ibuf start)))))
\f
;;; output functions
(defun write-char (character &optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-out character)
- (stream-write-char character))
+ (stream-write-char character))
character)
(defun terpri (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
nil)
+#!-sb-fluid (declaim (inline ansi-stream-fresh-line))
+(defun ansi-stream-fresh-line (stream)
+ (when (/= (or (charpos stream) 1) 0)
+ (funcall (ansi-stream-out stream) stream #\newline)
+ t))
+
(defun fresh-line (&optional (stream *standard-output*))
(let ((stream (out-synonym-of stream)))
(if (ansi-stream-p stream)
- (when (/= (or (charpos stream) 1) 0)
- (funcall (ansi-stream-out stream) stream #\newline)
- t)
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (stream-fresh-line stream))))
+ (ansi-stream-fresh-line stream)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-fresh-line stream))))
+
+#!-sb-fluid (declaim (inline ansi-stream-write-string))
+(defun ansi-stream-write-string (string stream start end)
+ (with-array-data ((data string) (offset-start start)
+ (offset-end end)
+ :check-fill-pointer t)
+ (funcall (ansi-stream-sout stream)
+ stream data offset-start offset-end)))
-(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) end)
- (declare (type string string))
- ;; Note that even though you might expect, based on the behavior of
- ;; things like AREF, that the correct upper bound here is
- ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
- ;; "bounding index" and "length" indicate that in this case (i.e.
- ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
- ;; (LENGTH STRING) is the required upper bound. A foolish
- ;; consistency is the hobgoblin of lesser languages..
- (%write-string string stream start (%check-vector-sequence-bounds
- string start end))
+(defun %write-string (string stream start end)
+ (let ((stream (out-synonym-of stream)))
+ (if (ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-write-string stream string start end)))
string)
-(defun %write-string (string stream start end)
+(defun write-string (string &optional (stream *standard-output*)
+ &key (start 0) end)
(declare (type string string))
(declare (type stream-designator stream))
- (declare (type index start end))
- (let ((stream (out-synonym-of stream)))
- (cond ((ansi-stream-p stream)
- (if (array-header-p string)
- (with-array-data ((data string) (offset-start start)
- (offset-end end))
- (funcall (ansi-stream-sout stream)
- stream data offset-start offset-end))
- (funcall (ansi-stream-sout stream) stream string start end))
- string)
- (t ; must be Gray streams FUNDAMENTAL-STREAM
- (stream-write-string stream string start end)))))
+ (%write-string string stream start end))
;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
-;;; which cannot deal with keyword arguments.
+;;; which cannot deal with keyword arguments. %WRITE-STRING cannot
+;;; replace this, as this needs to deal with simple-strings as well.
(declaim (inline write-string-no-key))
(defun write-string-no-key (string stream start end)
(write-string string stream :start start :end end))
(defun write-line (string &optional (stream *standard-output*)
- &key (start 0) end)
+ &key (start 0) end)
(declare (type string string))
- ;; FIXME: Why is there this difference between the treatments of the
- ;; STREAM argument in WRITE-STRING and WRITE-LINE?
- (let ((defaulted-stream (out-synonym-of stream)))
- (%write-string string defaulted-stream start (%check-vector-sequence-bounds
- string start end))
- (write-char #\newline defaulted-stream))
+ (declare (type stream-designator stream))
+ (let ((stream (out-synonym-of stream)))
+ (cond ((ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ (funcall (ansi-stream-out stream) stream #\newline))
+ (t
+ (stream-write-string stream string start end)
+ (stream-write-char stream #\newline))))
string)
(defun charpos (&optional (stream *standard-output*))
(defun line-length (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :line-length)
- (stream-line-length)))
+ (stream-line-length)))
(defun finish-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :finish-output)
- (stream-finish-output))
+ (stream-finish-output))
nil)
(defun force-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :force-output)
- (stream-force-output))
+ (stream-force-output))
nil)
(defun clear-output (&optional (stream *standard-output*))
(with-out-stream stream (ansi-stream-misc :clear-output)
- (stream-force-output))
+ (stream-clear-output))
nil)
(defun write-byte (integer stream)
- (with-out-stream stream (ansi-stream-bout integer)
- (stream-write-byte integer))
+ (with-out-stream/no-synonym stream (ansi-stream-bout integer)
+ (stream-write-byte integer))
integer)
\f
;;; globally. And we must not inline them in the rest of this file if
;;; dispatch to gray or simple streams is to work, since both redefine
;;; these functions later.)
-(declaim (maybe-inline read-char unread-char read-byte listen))
+(declaim (notinline read-char unread-char read-byte listen))
;;; This is called from ANSI-STREAM routines that encapsulate CLOS
;;; streams to handle the misc routines and dispatch to the
;; Return T if input available, :EOF for end-of-file, otherwise NIL.
(let ((char (read-char-no-hang stream nil :eof)))
(when (characterp char)
- (unread-char char stream))
+ (unread-char char stream))
char))
(:unread
(unread-char arg1 stream))
(finish-output stream))
(:element-type
(stream-element-type stream))
+ (:stream-external-format
+ (stream-external-format stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
(charpos stream))
(:file-length
(file-length stream))
+ (:file-string-length
+ (file-string-length stream arg1))
(:file-position
(file-position stream arg1))))
\f
;;;; broadcast streams
(defstruct (broadcast-stream (:include ansi-stream
- (out #'broadcast-out)
- (bout #'broadcast-bout)
- (sout #'broadcast-sout)
- (misc #'broadcast-misc))
- (:constructor %make-broadcast-stream
- (&rest streams))
- (:copier nil))
+ (out #'broadcast-out)
+ (bout #'broadcast-bout)
+ (sout #'broadcast-sout)
+ (misc #'broadcast-misc))
+ (:constructor %make-broadcast-stream
+ (&rest streams))
+ (:copier nil))
;; a list of all the streams we broadcast to
(streams () :type list :read-only t))
(dolist (stream streams)
(unless (output-stream-p stream)
(error 'type-error
- :datum stream
- :expected-type '(satisfies output-stream-p))))
+ :datum stream
+ :expected-type '(satisfies output-stream-p))))
(apply #'%make-broadcast-stream streams))
(macrolet ((out-fun (name fun &rest args)
- `(defun ,name (stream ,@args)
- (dolist (stream (broadcast-stream-streams stream))
- (,fun ,(car args) stream ,@(cdr args))))))
+ `(defun ,name (stream ,@args)
+ (dolist (stream (broadcast-stream-streams stream))
+ (,fun ,(car args) stream ,@(cdr args))))))
(out-fun broadcast-out write-char char)
(out-fun broadcast-bout write-byte byte)
(out-fun broadcast-sout write-string-no-key string start end))
;; -- CSR, 2004-02-04
(:charpos
(dolist (stream streams 0)
- (let ((charpos (charpos stream)))
- (if charpos (return charpos)))))
+ (let ((charpos (charpos stream)))
+ (if charpos (return charpos)))))
(:line-length
(let ((min nil))
- (dolist (stream streams min)
- (let ((res (line-length stream)))
- (when res (setq min (if min (min res min) res)))))))
+ (dolist (stream streams min)
+ (let ((res (line-length stream)))
+ (when res (setq min (if min (min res min) res)))))))
(:element-type
#+nil ; old, arguably more logical, version
(let (res)
- (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
- (pushnew (stream-element-type stream) res :test #'equal)))
+ (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
+ (pushnew (stream-element-type stream) res :test #'equal)))
;; ANSI-specified version (under System Class BROADCAST-STREAM)
(let ((res t))
- (do ((streams streams (cdr streams)))
- ((null streams) res)
- (when (null (cdr streams))
- (setq res (stream-element-type (car streams)))))))
+ (do ((streams streams (cdr streams)))
+ ((null streams) res)
+ (when (null (cdr streams))
+ (setq res (stream-element-type (car streams)))))))
+ (:external-format
+ (let ((res :default))
+ (dolist (stream streams res)
+ (setq res (stream-external-format stream)))))
+ (:file-length
+ (let ((last (last streams)))
+ (if last
+ (file-length (car last))
+ 0)))
+ (:file-position
+ (if arg1
+ (let ((res (or (eql arg1 :start) (eql arg1 0))))
+ (dolist (stream streams res)
+ (setq res (file-position stream arg1))))
+ (let ((res 0))
+ (dolist (stream streams res)
+ (setq res (file-position stream))))))
+ (:file-string-length
+ (let ((res 1))
+ (dolist (stream streams res)
+ (setq res (file-string-length stream arg1)))))
(:close
(set-closed-flame stream))
(t
(let ((res nil))
- (dolist (stream streams res)
- (setq res
- (if (ansi-stream-p stream)
- (funcall (ansi-stream-misc stream) stream operation
- arg1 arg2)
- (stream-misc-dispatch stream operation arg1 arg2)))))))))
+ (dolist (stream streams res)
+ (setq res
+ (if (ansi-stream-p stream)
+ (funcall (ansi-stream-misc stream) stream operation
+ arg1 arg2)
+ (stream-misc-dispatch stream operation arg1 arg2)))))))))
\f
;;;; synonym streams
(defstruct (synonym-stream (:include ansi-stream
- (in #'synonym-in)
- (bin #'synonym-bin)
- (n-bin #'synonym-n-bin)
- (out #'synonym-out)
- (bout #'synonym-bout)
- (sout #'synonym-sout)
- (misc #'synonym-misc))
- (:constructor make-synonym-stream (symbol))
- (:copier nil))
+ (in #'synonym-in)
+ (bin #'synonym-bin)
+ (n-bin #'synonym-n-bin)
+ (out #'synonym-out)
+ (bout #'synonym-bout)
+ (sout #'synonym-sout)
+ (misc #'synonym-misc))
+ (:constructor make-synonym-stream (symbol))
+ (:copier nil))
;; This is the symbol, the value of which is the stream we are synonym to.
(symbol nil :type symbol :read-only t))
(def!method print-object ((x synonym-stream) stream)
;;; The output simple output methods just call the corresponding
;;; function on the synonymed stream.
(macrolet ((out-fun (name fun &rest args)
- `(defun ,name (stream ,@args)
- (declare (optimize (safety 1)))
- (let ((syn (symbol-value (synonym-stream-symbol stream))))
- (,fun ,(car args) syn ,@(cdr args))))))
+ `(defun ,name (stream ,@args)
+ (declare (optimize (safety 1)))
+ (let ((syn (symbol-value (synonym-stream-symbol stream))))
+ (,fun ,(car args) syn ,@(cdr args))))))
(out-fun synonym-out write-char ch)
(out-fun synonym-bout write-byte n)
(out-fun synonym-sout write-string-no-key string start end))
;;; synonymed stream. These functions deal with getting input out of
;;; the In-Buffer if there is any.
(macrolet ((in-fun (name fun &rest args)
- `(defun ,name (stream ,@args)
- (declare (optimize (safety 1)))
- (,fun (symbol-value (synonym-stream-symbol stream))
- ,@args))))
+ `(defun ,name (stream ,@args)
+ (declare (optimize (safety 1)))
+ (,fun (symbol-value (synonym-stream-symbol stream))
+ ,@args))))
(in-fun synonym-in read-char eof-error-p eof-value)
(in-fun synonym-bin read-byte eof-error-p eof-value)
(in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream))))
(if (ansi-stream-p syn)
- ;; We have to special-case some operations which interact with
- ;; the in-buffer of the wrapped stream, since just calling
- ;; ANSI-STREAM-MISC on them
- (case operation
- (:listen (or (/= (the fixnum (ansi-stream-in-index syn))
- +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc syn) syn :listen)))
+ ;; We have to special-case some operations which interact with
+ ;; the in-buffer of the wrapped stream, since just calling
+ ;; ANSI-STREAM-MISC on them
+ (case operation
+ (:listen (or (/= (the fixnum (ansi-stream-in-index syn))
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc syn) syn :listen)))
(:clear-input (clear-input syn))
(:unread (unread-char arg1 syn))
- (t
- (funcall (ansi-stream-misc syn) syn operation arg1 arg2)))
- (stream-misc-dispatch syn operation arg1 arg2))))
+ (t
+ (funcall (ansi-stream-misc syn) syn operation arg1 arg2)))
+ (stream-misc-dispatch syn operation arg1 arg2))))
\f
;;;; two-way streams
(defstruct (two-way-stream
- (:include ansi-stream
- (in #'two-way-in)
- (bin #'two-way-bin)
- (n-bin #'two-way-n-bin)
- (out #'two-way-out)
- (bout #'two-way-bout)
- (sout #'two-way-sout)
- (misc #'two-way-misc))
- (:constructor %make-two-way-stream (input-stream output-stream))
- (:copier nil))
+ (:include ansi-stream
+ (in #'two-way-in)
+ (bin #'two-way-bin)
+ (n-bin #'two-way-n-bin)
+ (out #'two-way-out)
+ (bout #'two-way-bout)
+ (sout #'two-way-sout)
+ (misc #'two-way-misc))
+ (:constructor %make-two-way-stream (input-stream output-stream))
+ (:copier nil))
(input-stream (missing-arg) :type stream :read-only t)
(output-stream (missing-arg) :type stream :read-only t))
(defprinter (two-way-stream) input-stream output-stream)
;; the other places that SYNONYM-STREAM-P appears.
(unless (output-stream-p output-stream)
(error 'type-error
- :datum output-stream
- :expected-type '(satisfies output-stream-p)))
+ :datum output-stream
+ :expected-type '(satisfies output-stream-p)))
(unless (input-stream-p input-stream)
(error 'type-error
- :datum input-stream
- :expected-type '(satisfies input-stream-p)))
+ :datum input-stream
+ :expected-type '(satisfies input-stream-p)))
(funcall #'%make-two-way-stream input-stream output-stream))
(macrolet ((out-fun (name fun &rest args)
- `(defun ,name (stream ,@args)
- (let ((syn (two-way-stream-output-stream stream)))
- (,fun ,(car args) syn ,@(cdr args))))))
+ `(defun ,name (stream ,@args)
+ (let ((syn (two-way-stream-output-stream stream)))
+ (,fun ,(car args) syn ,@(cdr args))))))
(out-fun two-way-out write-char ch)
(out-fun two-way-bout write-byte n)
(out-fun two-way-sout write-string-no-key string start end))
(macrolet ((in-fun (name fun &rest args)
- `(defun ,name (stream ,@args)
- (force-output (two-way-stream-output-stream stream))
- (,fun (two-way-stream-input-stream stream) ,@args))))
+ `(defun ,name (stream ,@args)
+ (,fun (two-way-stream-input-stream stream) ,@args))))
(in-fun two-way-in read-char eof-error-p eof-value)
(in-fun two-way-bin read-byte eof-error-p eof-value)
(in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p))
(defun two-way-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
- (out (two-way-stream-output-stream stream))
- (in-ansi-stream-p (ansi-stream-p in))
- (out-ansi-stream-p (ansi-stream-p out)))
+ (out (two-way-stream-output-stream stream))
+ (in-ansi-stream-p (ansi-stream-p in))
+ (out-ansi-stream-p (ansi-stream-p out)))
(case operation
(:listen
(if in-ansi-stream-p
- (or (/= (the fixnum (ansi-stream-in-index in))
- +ansi-stream-in-buffer-length+)
- (funcall (ansi-stream-misc in) in :listen))
- (stream-listen in)))
+ (or (/= (the fixnum (ansi-stream-in-index in))
+ +ansi-stream-in-buffer-length+)
+ (funcall (ansi-stream-misc in) in :listen))
+ (listen in)))
((:finish-output :force-output :clear-output)
(if out-ansi-stream-p
- (funcall (ansi-stream-misc out) out operation arg1 arg2)
- (stream-misc-dispatch out operation arg1 arg2)))
+ (funcall (ansi-stream-misc out) out operation arg1 arg2)
+ (stream-misc-dispatch out operation arg1 arg2)))
(:clear-input (clear-input in))
(:unread (unread-char arg1 in))
(:element-type
(let ((in-type (stream-element-type in))
- (out-type (stream-element-type out)))
- (if (equal in-type out-type)
- in-type `(and ,in-type ,out-type))))
+ (out-type (stream-element-type out)))
+ (if (equal in-type out-type)
+ in-type `(and ,in-type ,out-type))))
(:close
(set-closed-flame stream))
(t
(or (if in-ansi-stream-p
- (funcall (ansi-stream-misc in) in operation arg1 arg2)
- (stream-misc-dispatch in operation arg1 arg2))
- (if out-ansi-stream-p
- (funcall (ansi-stream-misc out) out operation arg1 arg2)
- (stream-misc-dispatch out operation arg1 arg2)))))))
+ (funcall (ansi-stream-misc in) in operation arg1 arg2)
+ (stream-misc-dispatch in operation arg1 arg2))
+ (if out-ansi-stream-p
+ (funcall (ansi-stream-misc out) out operation arg1 arg2)
+ (stream-misc-dispatch out operation arg1 arg2)))))))
\f
;;;; concatenated streams
(defstruct (concatenated-stream
- (:include ansi-stream
- (in #'concatenated-in)
- (bin #'concatenated-bin)
- (n-bin #'concatenated-n-bin)
- (misc #'concatenated-misc))
- (:constructor %make-concatenated-stream
- (&rest streams &aux (current streams)))
- (:copier nil))
+ (:include ansi-stream
+ (in #'concatenated-in)
+ (bin #'concatenated-bin)
+ (n-bin #'concatenated-n-bin)
+ (misc #'concatenated-misc))
+ (:constructor %make-concatenated-stream (&rest streams))
+ (:copier nil))
;; The car of this is the substream we are reading from now.
(streams nil :type list))
(def!method print-object ((x concatenated-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream
- ":STREAMS ~S"
- (concatenated-stream-streams x))))
+ ":STREAMS ~S"
+ (concatenated-stream-streams x))))
(defun make-concatenated-stream (&rest streams)
#!+sb-doc
(dolist (stream streams)
(unless (input-stream-p stream)
(error 'type-error
- :datum stream
- :expected-type '(satisfies input-stream-p))))
+ :datum stream
+ :expected-type '(satisfies input-stream-p))))
(apply #'%make-concatenated-stream streams))
(macrolet ((in-fun (name fun)
- `(defun ,name (stream eof-error-p eof-value)
- (do ((streams (concatenated-stream-streams stream)
- (cdr streams)))
- ((null streams)
- (eof-or-lose stream eof-error-p eof-value))
- (let* ((stream (car streams))
- (result (,fun stream nil nil)))
- (when result (return result)))
- (pop (concatenated-stream-streams stream))))))
+ `(defun ,name (stream eof-error-p eof-value)
+ (do ((streams (concatenated-stream-streams stream)
+ (cdr streams)))
+ ((null streams)
+ (eof-or-lose stream eof-error-p eof-value))
+ (let* ((stream (car streams))
+ (result (,fun stream nil nil)))
+ (when result (return result)))
+ (pop (concatenated-stream-streams stream))))))
(in-fun concatenated-in read-char)
(in-fun concatenated-bin read-byte))
(remaining-bytes numbytes))
((null streams)
(if eof-errorp
- (error 'end-of-file :stream stream)
- (- numbytes remaining-bytes)))
+ (error 'end-of-file :stream stream)
+ (- numbytes remaining-bytes)))
(let* ((stream (car streams))
(bytes-read (read-n-bytes stream buffer current-start
- remaining-bytes nil)))
+ remaining-bytes nil)))
(incf current-start bytes-read)
(decf remaining-bytes bytes-read)
(when (zerop remaining-bytes) (return numbytes)))
(defun concatenated-misc (stream operation &optional arg1 arg2)
(let* ((left (concatenated-stream-streams stream))
- (current (car left)))
+ (current (car left)))
(case operation
(:listen
(unless left
- (return-from concatenated-misc :eof))
+ (return-from concatenated-misc :eof))
(loop
- (let ((stuff (if (ansi-stream-p current)
- (funcall (ansi-stream-misc current) current
- :listen)
- (stream-misc-dispatch current :listen))))
- (cond ((eq stuff :eof)
- ;; Advance STREAMS, and try again.
- (pop (concatenated-stream-streams stream))
- (setf current
- (car (concatenated-stream-streams stream)))
- (unless current
- ;; No further streams. EOF.
- (return :eof)))
- (stuff
- ;; Stuff's available.
- (return t))
- (t
- ;; Nothing is available yet.
- (return nil))))))
+ (let ((stuff (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current
+ :listen)
+ (stream-misc-dispatch current :listen))))
+ (cond ((eq stuff :eof)
+ ;; Advance STREAMS, and try again.
+ (pop (concatenated-stream-streams stream))
+ (setf current
+ (car (concatenated-stream-streams stream)))
+ (unless current
+ ;; No further streams. EOF.
+ (return :eof)))
+ (stuff
+ ;; Stuff's available.
+ (return t))
+ (t
+ ;; Nothing is available yet.
+ (return nil))))))
(:clear-input (when left (clear-input current)))
(:unread (when left (unread-char arg1 current)))
(:close
(set-closed-flame stream))
(t
(when left
- (if (ansi-stream-p current)
- (funcall (ansi-stream-misc current) current operation arg1 arg2)
- (stream-misc-dispatch current operation arg1 arg2)))))))
+ (if (ansi-stream-p current)
+ (funcall (ansi-stream-misc current) current operation arg1 arg2)
+ (stream-misc-dispatch current operation arg1 arg2)))))))
\f
;;;; echo streams
(defstruct (echo-stream
- (:include two-way-stream
- (in #'echo-in)
- (bin #'echo-bin)
- (misc #'echo-misc)
- (n-bin #'ill-bin))
- (:constructor %make-echo-stream (input-stream output-stream))
- (:copier nil))
- unread-stuff)
+ (:include two-way-stream
+ (in #'echo-in)
+ (bin #'echo-bin)
+ (misc #'echo-misc)
+ (n-bin #'echo-n-bin))
+ (:constructor %make-echo-stream (input-stream output-stream))
+ (:copier nil))
+ (unread-stuff nil :type boolean))
(def!method print-object ((x echo-stream) stream)
(print-unreadable-object (x stream :type t :identity t)
(format stream
- ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
- (two-way-stream-input-stream x)
- (two-way-stream-output-stream x))))
+ ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
+ (two-way-stream-input-stream x)
+ (two-way-stream-output-stream x))))
(defun make-echo-stream (input-stream output-stream)
#!+sb-doc
the output stream."
(unless (output-stream-p output-stream)
(error 'type-error
- :datum output-stream
- :expected-type '(satisfies output-stream-p)))
+ :datum output-stream
+ :expected-type '(satisfies output-stream-p)))
(unless (input-stream-p input-stream)
(error 'type-error
- :datum input-stream
- :expected-type '(satisfies input-stream-p)))
+ :datum input-stream
+ :expected-type '(satisfies input-stream-p)))
(funcall #'%make-echo-stream input-stream output-stream))
(macrolet ((in-fun (name in-fun out-fun &rest args)
- `(defun ,name (stream ,@args)
- (or (pop (echo-stream-unread-stuff stream))
- (let* ((in (echo-stream-input-stream stream))
- (out (echo-stream-output-stream stream))
- (result (if eof-error-p
- (,in-fun in ,@args)
- (,in-fun in nil in))))
- (cond
- ((eql result in) eof-value)
- (t (,out-fun result out) result)))))))
+ `(defun ,name (stream ,@args)
+ (let* ((unread-stuff-p (echo-stream-unread-stuff stream))
+ (in (echo-stream-input-stream stream))
+ (out (echo-stream-output-stream stream))
+ (result (if eof-error-p
+ (,in-fun in ,@args)
+ (,in-fun in nil in))))
+ (setf (echo-stream-unread-stuff stream) nil)
+ (cond
+ ((eql result in) eof-value)
+ ;; If unread-stuff was true, the character read
+ ;; from the input stream was previously echoed.
+ (t (unless unread-stuff-p (,out-fun result out)) result))))))
(in-fun echo-in read-char write-char eof-error-p eof-value)
(in-fun echo-bin read-byte write-byte eof-error-p eof-value))
-\f
-;;;; base STRING-STREAM stuff
-(defstruct (string-stream
- (:include ansi-stream)
- (:constructor nil)
- (:copier nil))
- ;; FIXME: This type declaration is true, and will probably continue
- ;; to be true. However, note well the comments in DEFTRANSFORM
- ;; REPLACE, implying that performance of REPLACE is somewhat
- ;; critical to performance of string streams. If (VECTOR CHARACTER)
- ;; ever becomes different from (VECTOR BASE-CHAR), the transform
- ;; probably needs to be extended.
- (string (missing-arg) :type (vector character)))
+(defun echo-n-bin (stream buffer start numbytes eof-error-p)
+ (let ((bytes-read 0))
+ ;; Note: before ca 1.0.27.18, the logic for handling unread
+ ;; characters never could have worked, so probably nobody has ever
+ ;; tried doing bivalent block I/O through an echo stream; this may
+ ;; not work either.
+ (when (echo-stream-unread-stuff stream)
+ (let* ((char (read-char stream))
+ (octets (string-to-octets
+ (string char)
+ :external-format
+ (stream-external-format
+ (echo-stream-input-stream stream))))
+ (octet-count (length octets))
+ (blt-count (min octet-count numbytes)))
+ (replace buffer octets :start1 start :end1 (+ start blt-count))
+ (incf start blt-count)
+ (decf numbytes blt-count)))
+ (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+ start numbytes nil))
+ (cond
+ ((not eof-error-p)
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ bytes-read)
+ ((> numbytes bytes-read)
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ (error 'end-of-file :stream stream))
+ (t
+ (write-sequence buffer (echo-stream-output-stream stream)
+ :start start :end (+ start bytes-read))
+ (aver (= numbytes (+ start bytes-read)))
+ numbytes))))
\f
;;;; STRING-INPUT-STREAM stuff
(defstruct (string-input-stream
- (:include string-stream
- (in #'string-inch)
- (bin #'ill-bin)
- (n-bin #'string-stream-read-n-bytes)
- (misc #'string-in-misc)
- (string (missing-arg) :type simple-string))
- (:constructor internal-make-string-input-stream
- (string current end))
- (:copier nil))
+ (:include ansi-stream
+ (in #'string-inch)
+ (bin #'ill-bin)
+ (n-bin #'ill-bin)
+ (misc #'string-in-misc))
+ (:constructor internal-make-string-input-stream
+ (string current end))
+ (:copier nil))
+ (string (missing-arg) :type simple-string)
(current (missing-arg) :type index)
(end (missing-arg) :type index))
(defun string-inch (stream eof-error-p eof-value)
(declare (type string-input-stream stream))
(let ((string (string-input-stream-string stream))
- (index (string-input-stream-current stream)))
+ (index (string-input-stream-current stream)))
(cond ((>= index (the index (string-input-stream-end stream)))
- (eof-or-lose stream eof-error-p eof-value))
- (t
- (setf (string-input-stream-current stream) (1+ index))
- (char string index)))))
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (setf (string-input-stream-current stream) (1+ index))
+ (char string index)))))
(defun string-binch (stream eof-error-p eof-value)
(declare (type string-input-stream stream))
(let ((string (string-input-stream-string stream))
- (index (string-input-stream-current stream)))
+ (index (string-input-stream-current stream)))
(cond ((>= index (the index (string-input-stream-end stream)))
- (eof-or-lose stream eof-error-p eof-value))
- (t
- (setf (string-input-stream-current stream) (1+ index))
- (char-code (char string index))))))
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (setf (string-input-stream-current stream) (1+ index))
+ (char-code (char string index))))))
(defun string-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type string-input-stream stream)
- (type index start requested))
+ (type index start requested))
(let* ((string (string-input-stream-string stream))
- (index (string-input-stream-current stream))
- (available (- (string-input-stream-end stream) index))
- (copy (min available requested)))
+ (index (string-input-stream-current stream))
+ (available (- (string-input-stream-end stream) index))
+ (copy (min available requested)))
(declare (type simple-string string))
(when (plusp copy)
(setf (string-input-stream-current stream)
- (truly-the index (+ index copy)))
- (sb!sys:without-gcing
- (system-area-copy (vector-sap string)
- (* index sb!vm:n-byte-bits)
- (if (typep buffer 'system-area-pointer)
- buffer
- (vector-sap buffer))
- (* start sb!vm:n-byte-bits)
- (* copy sb!vm:n-byte-bits))))
+ (truly-the index (+ index copy)))
+ ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point?
+ ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24
+ (with-pinned-objects (string buffer)
+ (system-area-ub8-copy (vector-sap string)
+ index
+ (if (typep buffer 'system-area-pointer)
+ buffer
+ (vector-sap buffer))
+ start
+ copy)))
(if (and (> requested copy) eof-error-p)
- (error 'end-of-file :stream stream)
- copy)))
+ (error 'end-of-file :stream stream)
+ copy)))
(defun string-in-misc (stream operation &optional arg1 arg2)
(declare (type string-input-stream stream)
- (ignore arg2))
+ (ignore arg2))
(case operation
(:file-position
(if arg1
- (setf (string-input-stream-current stream)
- (case arg1
- (:start 0)
- (:end (string-input-stream-end stream))
- ;; We allow moving position beyond EOF. Errors happen
- ;; on read, not move -- or the user may extend the
- ;; input string.
- (t arg1)))
- (string-input-stream-current stream)))
+ (setf (string-input-stream-current stream)
+ (case arg1
+ (:start 0)
+ (:end (string-input-stream-end stream))
+ ;; We allow moving position beyond EOF. Errors happen
+ ;; on read, not move -- or the user may extend the
+ ;; input string.
+ (t arg1)))
+ (string-input-stream-current stream)))
;; According to ANSI: "Should signal an error of type type-error
;; if stream is not a stream associated with a file."
;; This is checked by FILE-LENGTH, so no need to do it here either.
(:unread (decf (string-input-stream-current stream)))
(:close (set-closed-flame stream))
(:listen (or (/= (the index (string-input-stream-current stream))
- (the index (string-input-stream-end stream)))
- :eof))
+ (the index (string-input-stream-end stream)))
+ :eof))
(:element-type (array-element-type (string-input-stream-string stream)))))
(defun make-string-input-stream (string &optional (start 0) end)
"Return an input stream which will supply the characters of STRING between
START and END in order."
(declare (type string string)
- (type index start)
- (type (or index null) end))
- (let* ((string (coerce string '(simple-array character (*))))
- (end (%check-vector-sequence-bounds string start end)))
+ (type index start)
+ (type (or index null) end))
+ (let* ((string (coerce string '(simple-array character (*)))))
+ ;; FIXME: Why WITH-ARRAY-DATA, since the array is already simple?
(with-array-data ((string string) (start start) (end end))
(internal-make-string-input-stream
string ;; now simple
end))))
\f
;;;; STRING-OUTPUT-STREAM stuff
+;;;;
+;;;; FIXME: This, like almost none of the stream code is particularly
+;;;; interrupt or thread-safe. While it should not be possible to
+;;;; corrupt the heap here, it certainly is possible to end up with
+;;;; a string-output-stream whose internal state is messed up.
+;;;;
+;;;; FIXME: It would be nice to support space-efficient
+;;;; string-output-streams with element-type base-char. This would
+;;;; mean either a separate subclass, or typecases in functions.
+
+(defparameter *string-output-stream-buffer-initial-size* 64)
+#!-sb-fluid
+(declaim (inline string-output-string-stream-buffer
+ string-output-string-stream-pointer
+ string-output-string-stream-index))
(defstruct (string-output-stream
- (:include string-stream
- (out #'string-ouch)
- (sout #'string-sout)
- (misc #'string-out-misc)
- ;; The string we throw stuff in.
- (string (missing-arg)
- :type (simple-array character (*))))
- (:constructor make-string-output-stream
- (&key (element-type 'character)
- &aux (string (make-string 40))))
- (:copier nil))
- ;; Index of the next location to use.
- (index 0 :type fixnum)
- ;; Index cache for string-output-stream-last-index
- (index-cache 0 :type fixnum)
+ (:include ansi-stream
+ (out #'string-ouch)
+ (sout #'string-sout)
+ (misc #'string-out-misc))
+ (:constructor make-string-output-stream
+ (&key (element-type 'character)
+ &aux (buffer
+ (make-string
+ *string-output-stream-buffer-initial-size*))))
+ (:copier nil))
+ ;; The string we throw stuff in.
+ (buffer (missing-arg) :type (simple-array character (*)))
+ ;; Chains of buffers to use
+ (prev nil)
+ (next nil)
+ ;; Index of the next location to use in the current string.
+ (pointer 0 :type index)
+ ;; Global location in the stream
+ (index 0 :type index)
+ ;; Index cache: when we move backwards we save the greater of this
+ ;; and index here, so the greater of index and this is always the
+ ;; end of the stream.
+ (index-cache 0 :type index)
;; Requested element type
- (element-type 'character))
+ (element-type 'character :type type-specifier))
#!+sb-doc
(setf (fdocumentation 'make-string-output-stream 'function)
- "Return an output stream which will accumulate all output given it for
- the benefit of the function GET-OUTPUT-STREAM-STRING.")
-
-(defun string-output-stream-last-index (stream)
- (max (string-output-stream-index stream)
- (string-output-stream-index-cache stream)))
+ "Return an output stream which will accumulate all output given it for the
+benefit of the function GET-OUTPUT-STREAM-STRING.")
+
+;;; Pushes the current segment onto the prev-list, and either pops
+;;; or allocates a new one.
+(defun string-output-stream-new-buffer (stream size)
+ (declare (index size))
+ (/show0 "/string-output-stream-new-buffer")
+ (push (string-output-stream-buffer stream)
+ (string-output-stream-prev stream))
+ (setf (string-output-stream-buffer stream)
+ (or (pop (string-output-stream-next stream))
+ ;; FIXME: This would be the correct place to detect that
+ ;; more then FIXNUM characters are being written to the
+ ;; stream, and do something about it.
+ (make-string size))))
+
+;;; Moves to the end of the next segment or the current one if there are
+;;; no more segments. Returns true as long as there are next segments.
+(defun string-output-stream-next-buffer (stream)
+ (/show0 "/string-output-stream-next-buffer")
+ (let* ((old (string-output-stream-buffer stream))
+ (new (pop (string-output-stream-next stream)))
+ (old-size (length old))
+ (skipped (- old-size (string-output-stream-pointer stream))))
+ (cond (new
+ (let ((new-size (length new)))
+ (push old (string-output-stream-prev stream))
+ (setf (string-output-stream-buffer stream) new
+ (string-output-stream-pointer stream) new-size)
+ (incf (string-output-stream-index stream) (+ skipped new-size)))
+ t)
+ (t
+ (setf (string-output-stream-pointer stream) old-size)
+ (incf (string-output-stream-index stream) skipped)
+ nil))))
+
+;;; Moves to the start of the previous segment or the current one if there
+;;; are no more segments. Returns true as long as there are prev segments.
+(defun string-output-stream-prev-buffer (stream)
+ (/show0 "/string-output-stream-prev-buffer")
+ (let ((old (string-output-stream-buffer stream))
+ (new (pop (string-output-stream-prev stream)))
+ (skipped (string-output-stream-pointer stream)))
+ (cond (new
+ (push old (string-output-stream-next stream))
+ (setf (string-output-stream-buffer stream) new
+ (string-output-stream-pointer stream) 0)
+ (decf (string-output-stream-index stream) (+ skipped (length new)))
+ t)
+ (t
+ (setf (string-output-stream-pointer stream) 0)
+ (decf (string-output-stream-index stream) skipped)
+ nil))))
(defun string-ouch (stream character)
- (let ((current (string-output-stream-index stream))
- (workspace (string-output-stream-string stream)))
- (declare (type (simple-array character (*)) workspace)
- (type fixnum current))
- (if (= current (the fixnum (length workspace)))
- (let ((new-workspace (make-string (* current 2))))
- (replace new-workspace workspace)
- (setf (aref new-workspace current) character
- (string-output-stream-string stream) new-workspace))
- (setf (aref workspace current) character))
- (setf (string-output-stream-index stream) (1+ current))))
+ (/show0 "/string-ouch")
+ (let ((pointer (string-output-stream-pointer stream))
+ (buffer (string-output-stream-buffer stream))
+ (index (string-output-stream-index stream)))
+ (cond ((= pointer (length buffer))
+ (setf buffer (string-output-stream-new-buffer stream index)
+ (aref buffer 0) character
+ (string-output-stream-pointer stream) 1))
+ (t
+ (setf (aref buffer pointer) character
+ (string-output-stream-pointer stream) (1+ pointer))))
+ (setf (string-output-stream-index stream) (1+ index))))
(defun string-sout (stream string start end)
(declare (type simple-string string)
- (type fixnum start end))
- (let* ((string (if (typep string '(simple-array character (*)))
- string
- (coerce string '(simple-array character (*)))))
- (current (string-output-stream-index stream))
- (length (- end start))
- (dst-end (+ length current))
- (workspace (string-output-stream-string stream)))
- (declare (type (simple-array character (*)) workspace string)
- (type fixnum current length dst-end))
- (if (> dst-end (the fixnum (length workspace)))
- (let ((new-workspace (make-string (+ (* current 2) length))))
- (replace new-workspace workspace :end2 current)
- (replace new-workspace string
- :start1 current :end1 dst-end
- :start2 start :end2 end)
- (setf (string-output-stream-string stream) new-workspace))
- (replace workspace string
- :start1 current :end1 dst-end
- :start2 start :end2 end))
- (setf (string-output-stream-index stream) dst-end)))
+ (type index start end))
+ (let* ((full-length (- end start))
+ (length full-length)
+ (buffer (string-output-stream-buffer stream))
+ (pointer (string-output-stream-pointer stream))
+ (space (- (length buffer) pointer))
+ (here (min space length))
+ (stop (+ start here))
+ (overflow (- length space)))
+ (declare (index length space here stop full-length)
+ (fixnum overflow)
+ (type (simple-array character (*)) buffer))
+ (tagbody
+ :more
+ (when (plusp here)
+ (etypecase string
+ ((simple-array character (*))
+ (replace buffer string :start1 pointer :start2 start :end2 stop))
+ (simple-base-string
+ (replace buffer string :start1 pointer :start2 start :end2 stop))
+ ((simple-array nil (*))
+ (replace buffer string :start1 pointer :start2 start :end2 stop)))
+ (setf (string-output-stream-pointer stream) (+ here pointer)))
+ (when (plusp overflow)
+ (setf start stop
+ length (- end start)
+ buffer (string-output-stream-new-buffer
+ stream (max overflow (string-output-stream-index stream)))
+ pointer 0
+ space (length buffer)
+ here (min space length)
+ stop (+ start here)
+ ;; there may be more overflow if we used a buffer
+ ;; already allocated to the stream
+ overflow (- length space))
+ (go :more)))
+ (incf (string-output-stream-index stream) full-length)))
+
+;;; Factored out of the -misc method due to size.
+(defun set-string-output-stream-file-position (stream pos)
+ (let* ((index (string-output-stream-index stream))
+ (end (max index (string-output-stream-index-cache stream))))
+ (declare (index index end))
+ (setf (string-output-stream-index-cache stream) end)
+ (cond ((eq :start pos)
+ (loop while (string-output-stream-prev-buffer stream)))
+ ((eq :end pos)
+ (loop while (string-output-stream-next-buffer stream))
+ (let ((over (- (string-output-stream-index stream) end)))
+ (decf (string-output-stream-pointer stream) over))
+ (setf (string-output-stream-index stream) end))
+ ((< pos index)
+ (loop while (< pos index)
+ do (string-output-stream-prev-buffer stream)
+ (setf index (string-output-stream-index stream)))
+ (let ((step (- pos index)))
+ (incf (string-output-stream-pointer stream) step)
+ (setf (string-output-stream-index stream) pos)))
+ ((> pos index)
+ ;; We allow moving beyond the end of stream, implicitly
+ ;; extending the output stream.
+ (let ((next (string-output-stream-next-buffer stream)))
+ ;; Update after -next-buffer, INDEX is kept pointing at
+ ;; the end of the current buffer.
+ (setf index (string-output-stream-index stream))
+ (loop while (and next (> pos index))
+ do (setf next (string-output-stream-next-buffer stream)
+ index (string-output-stream-index stream))))
+ ;; Allocate new buffer if needed, or step back to
+ ;; the desired index and set pointer and index
+ ;; correctly.
+ (let ((diff (- pos index)))
+ (if (plusp diff)
+ (let* ((new (string-output-stream-new-buffer stream diff))
+ (size (length new)))
+ (aver (= pos (+ index size)))
+ (setf (string-output-stream-pointer stream) size
+ (string-output-stream-index stream) pos))
+ (let ((size (length (string-output-stream-buffer stream))))
+ (setf (string-output-stream-pointer stream) (+ size diff)
+ (string-output-stream-index stream) pos))))))))
(defun string-out-misc (stream operation &optional arg1 arg2)
(declare (ignore arg2))
+ (declare (optimize speed))
(case operation
- (:file-position
- (if arg1
- (let ((end (string-output-stream-last-index stream)))
- (setf (string-output-stream-index-cache stream) end
- (string-output-stream-index stream)
- (case arg1
- (:start 0)
- (:end end)
- (t
- ;; We allow moving beyond the end of stream,
- ;; implicitly extending the output stream.
- (let ((buffer (string-output-stream-string stream)))
- (when (> arg1 (length buffer))
- (setf (string-output-stream-string stream)
- (make-string
- arg1 :element-type (array-element-type buffer))
- (subseq (string-output-stream-string stream)
- 0 end)
- (subseq buffer 0 end))))
- arg1))))
- (string-output-stream-index stream)))
- (:close (set-closed-flame stream))
(:charpos
- (do ((index (1- (the fixnum (string-output-stream-index stream)))
- (1- index))
- (count 0 (1+ count))
- (string (string-output-stream-string stream)))
- ((< index 0) count)
- (declare (type (simple-array character (*)) string)
- (type fixnum index count))
- (if (char= (schar string index) #\newline)
- (return count))))
- (:element-type (array-element-type (string-output-stream-string stream)))))
+ ;; Keeping this first is a silly micro-optimization: FRESH-LINE
+ ;; makes this the most common one.
+ (/show0 "/string-out-misc charpos")
+ (prog ((pointer (string-output-stream-pointer stream))
+ (buffer (string-output-stream-buffer stream))
+ (prev (string-output-stream-prev stream))
+ (base 0))
+ (declare (type (or null (simple-array character (*))) buffer))
+ :next
+ (let ((pos (when buffer
+ (position #\newline buffer :from-end t :end pointer))))
+ (when (or pos (not buffer))
+ ;; If newline is at index I, and pointer at index I+N, charpos
+ ;; is N-1. If there is no newline, and pointer is at index N,
+ ;; charpos is N.
+ (return (+ base (if pos (- pointer pos 1) pointer))))
+ (setf base (+ base pointer)
+ buffer (pop prev)
+ pointer (length buffer))
+ (/show0 "/string-out-misc charpos next")
+ (go :next))))
+ (:file-position
+ (/show0 "/string-out-misc file-position")
+ (when arg1
+ (set-string-output-stream-file-position stream arg1))
+ (string-output-stream-index stream))
+ (:close
+ (/show0 "/string-out-misc close")
+ (set-closed-flame stream))
+ (:element-type (string-output-stream-element-type stream))))
;;; Return a string of all the characters sent to a stream made by
;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function.
(defun get-output-stream-string (stream)
(declare (type string-output-stream stream))
- (let* ((length (string-output-stream-last-index stream))
- (element-type (string-output-stream-element-type stream))
- (result
- (case element-type
- ;; Overwhelmingly common case; can be inlined.
- ((character) (make-string length))
- (t (make-string length :element-type element-type)))))
- ;; For the benefit of the REPLACE transform, let's do this, so
- ;; that the common case isn't ludicrously expensive.
- (etypecase result
- ((simple-array character (*))
- (replace result (string-output-stream-string stream)))
- ((simple-array nil (*))
- (replace result (string-output-stream-string stream))))
+ (let* ((length (max (string-output-stream-index stream)
+ (string-output-stream-index-cache stream)))
+ (element-type (string-output-stream-element-type stream))
+ (prev (string-output-stream-prev stream))
+ (this (string-output-stream-buffer stream))
+ (next (string-output-stream-next stream))
+ (result
+ (case element-type
+ ;; overwhelmingly common case: can be inlined
+ ;;
+ ;; FIXME: If we were willing to use %SHRINK-VECTOR here,
+ ;; and allocate new strings the size of 2 * index in
+ ;; STRING-SOUT, we would not need to allocate one here in
+ ;; the common case, but could just use the last one
+ ;; allocated, and chop it down to size..
+ ;;
+ ((character) (make-string length))
+ ;; slightly less common cases: inline it anyway
+ ((base-char standard-char)
+ (make-string length :element-type 'base-char))
+ (t
+ (make-string length :element-type element-type)))))
+
(setf (string-output-stream-index stream) 0
- (string-output-stream-index-cache stream) 0)
- result))
+ (string-output-stream-index-cache stream) 0
+ (string-output-stream-pointer stream) 0
+ ;; throw them away for simplicity's sake: this way the rest of the
+ ;; implementation can assume that the greater of INDEX and INDEX-CACHE
+ ;; is always within the last buffer.
+ (string-output-stream-prev stream) nil
+ (string-output-stream-next stream) nil)
+
+ (flet ((replace-all (fun)
+ (let ((start 0))
+ (declare (index start))
+ (setf prev (nreverse prev))
+ (dolist (buffer prev)
+ (funcall fun buffer start)
+ (incf start (length buffer)))
+ (funcall fun this start)
+ (incf start (length this))
+ (dolist (buffer next)
+ (funcall fun buffer start)
+ (incf start (length buffer)))
+ ;; Hack: erase the pointers to strings, to make it less
+ ;; likely that the conservative GC will accidentally
+ ;; retain the buffers.
+ (fill prev nil)
+ (fill next nil))))
+ (macrolet ((frob (type)
+ `(replace-all (lambda (buffer from)
+ (declare (type ,type result)
+ (type (simple-array character (*))
+ buffer))
+ (replace result buffer :start1 from)))))
+ (etypecase result
+ ((simple-array character (*))
+ (frob (simple-array character (*))))
+ (simple-base-string
+ (frob simple-base-string))
+ ((simple-array nil (*))
+ (frob (simple-array nil (*)))))))
-;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
-;;; GET-OUTPUT-STREAM-STRING would return them.
-(defun dump-output-stream-string (in-stream out-stream)
- (%write-string (string-output-stream-string in-stream)
- out-stream
- 0
- (string-output-stream-last-index in-stream))
- (setf (string-output-stream-index in-stream) 0
- (string-output-stream-index-cache in-stream) 0))
+ result))
\f
;;;; fill-pointer streams
;;; the CLM, but they are required for the implementation of
;;; WITH-OUTPUT-TO-STRING.
+;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope
+;;; of efficiency.
+(declaim (inline vector-with-fill-pointer))
+(defun vector-with-fill-pointer-p (x)
+ (and (vectorp x)
+ (array-has-fill-pointer-p x)))
+
(deftype string-with-fill-pointer ()
- '(and (vector character)
- (satisfies array-has-fill-pointer-p)))
+ `(and (or (vector character) (vector base-char))
+ (satisfies vector-with-fill-pointer-p)))
(defstruct (fill-pointer-output-stream
- (:include string-stream
- (out #'fill-pointer-ouch)
- (sout #'fill-pointer-sout)
- (misc #'fill-pointer-misc)
- ;; a string with a fill pointer where we stuff
- ;; the stuff we write
- (string (missing-arg)
- :type string-with-fill-pointer
- :read-only t))
- (:constructor make-fill-pointer-output-stream (string))
- (:copier nil)))
+ (:include ansi-stream
+ (out #'fill-pointer-ouch)
+ (sout #'fill-pointer-sout)
+ (misc #'fill-pointer-misc))
+ (:constructor make-fill-pointer-output-stream (string))
+ (:copier nil))
+ ;; a string with a fill pointer where we stuff the stuff we write
+ (string (missing-arg) :type string-with-fill-pointer :read-only t))
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
- (current (fill-pointer buffer))
- (current+1 (1+ current)))
+ (current (fill-pointer buffer))
+ (current+1 (1+ current)))
(declare (fixnum current))
(with-array-data ((workspace buffer) (start) (end))
- (declare (type (simple-array character (*)) workspace))
- (let ((offset-current (+ start current)))
- (declare (fixnum offset-current))
- (if (= offset-current end)
- (let* ((new-length (1+ (* current 2)))
- (new-workspace (make-string new-length)))
- (declare (simple-string new-workspace))
- (%byte-blt workspace start
- new-workspace 0 current)
- (setf workspace new-workspace
- offset-current current)
- (set-array-header buffer workspace new-length
- current+1 0 new-length nil))
- (setf (fill-pointer buffer) current+1))
- (setf (schar workspace offset-current) character)))
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*)))
+ workspace
+ (let ((offset-current (+ start current)))
+ (declare (fixnum offset-current))
+ (if (= offset-current end)
+ (let* ((new-length (1+ (* current 2)))
+ (new-workspace
+ (ecase (array-element-type workspace)
+ (character (make-string new-length
+ :element-type 'character))
+ (base-char (make-string new-length
+ :element-type 'base-char)))))
+ (replace new-workspace workspace :start2 start :end2 offset-current)
+ (setf workspace new-workspace
+ offset-current current)
+ (set-array-header buffer workspace new-length
+ current+1 0 new-length nil nil))
+ (setf (fill-pointer buffer) current+1))
+ (setf (char workspace offset-current) character))))
current+1))
(defun fill-pointer-sout (stream string start end)
- (declare (simple-string string) (fixnum start end))
- (let* ((string (if (typep string '(simple-array character (*)))
- string
- (coerce string '(simple-array character (*)))))
- (buffer (fill-pointer-output-stream-string stream))
- (current (fill-pointer buffer))
- (string-len (- end start))
- (dst-end (+ string-len current)))
- (declare (fixnum current dst-end string-len))
- (with-array-data ((workspace buffer) (dst-start) (dst-length))
- (declare (type (simple-array character (*)) workspace))
- (let ((offset-dst-end (+ dst-start dst-end))
- (offset-current (+ dst-start current)))
- (declare (fixnum offset-dst-end offset-current))
- (if (> offset-dst-end dst-length)
- (let* ((new-length (+ (the fixnum (* current 2)) string-len))
- (new-workspace (make-string new-length)))
- (declare (type (simple-array character (*)) new-workspace))
- (%byte-blt workspace dst-start
- new-workspace 0 current)
- (setf workspace new-workspace)
- (setf offset-current current)
- (setf offset-dst-end dst-end)
- (set-array-header buffer
- workspace
- new-length
- dst-end
- 0
- new-length
- nil))
- (setf (fill-pointer buffer) dst-end))
- (%byte-blt string start
- workspace offset-current offset-dst-end)))
- dst-end))
+ (declare (fixnum start end))
+ (string-dispatch
+ ((simple-array character (*))
+ (simple-array base-char (*)))
+ string
+ (let* ((buffer (fill-pointer-output-stream-string stream))
+ (current (fill-pointer buffer))
+ (string-len (- end start))
+ (dst-end (+ string-len current)))
+ (declare (fixnum current dst-end string-len))
+ (with-array-data ((workspace buffer) (dst-start) (dst-length))
+ (let ((offset-dst-end (+ dst-start dst-end))
+ (offset-current (+ dst-start current)))
+ (declare (fixnum offset-dst-end offset-current))
+ (if (> offset-dst-end dst-length)
+ (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+ (new-workspace
+ (ecase (array-element-type workspace)
+ (character (make-string new-length
+ :element-type 'character))
+ (base-char (make-string new-length
+ :element-type 'base-char)))))
+ (replace new-workspace workspace
+ :start2 dst-start :end2 offset-current)
+ (setf workspace new-workspace
+ offset-current current
+ offset-dst-end dst-end)
+ (set-array-header buffer workspace new-length
+ dst-end 0 new-length nil nil))
+ (setf (fill-pointer buffer) dst-end))
+ (replace workspace string
+ :start1 offset-current :start2 start :end2 end)))
+ dst-end)))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
- (declare (ignore arg1 arg2))
+ (declare (ignore arg2))
(case operation
(:file-position
(let ((buffer (fill-pointer-output-stream-string stream)))
(if arg1
- (setf (fill-pointer buffer)
- (case arg1
- (:start 0)
- ;; Fill-pointer is always at fill-pointer we will
- ;; make :END move to the end of the actual string.
- (:end (array-total-size buffer))
- ;; We allow moving beyond the end of string if the
- ;; string is adjustable.
- (t (when (>= arg1 (array-total-size buffer))
- (if (adjustable-array-p buffer)
- (adjust-array buffer arg1)
- (error "Cannot move FILE-POSITION beyond the end ~
+ (setf (fill-pointer buffer)
+ (case arg1
+ (:start 0)
+ ;; Fill-pointer is always at fill-pointer we will
+ ;; make :END move to the end of the actual string.
+ (:end (array-total-size buffer))
+ ;; We allow moving beyond the end of string if the
+ ;; string is adjustable.
+ (t (when (>= arg1 (array-total-size buffer))
+ (if (adjustable-array-p buffer)
+ (adjust-array buffer arg1)
+ (error "Cannot move FILE-POSITION beyond the end ~
of WITH-OUTPUT-TO-STRING stream ~
constructed with non-adjustable string.")))
- arg1)))
- (fill-pointer buffer))))
+ arg1)))
+ (fill-pointer buffer))))
(:charpos
(let* ((buffer (fill-pointer-output-stream-string stream))
- (current (fill-pointer buffer)))
+ (current (fill-pointer buffer)))
(with-array-data ((string buffer) (start) (end current))
- (declare (simple-string string) (ignore start))
- (let ((found (position #\newline string :test #'char=
- :end end :from-end t)))
- (if found
- (- end (the fixnum found))
- current)))))
- (:element-type (array-element-type
- (fill-pointer-output-stream-string stream)))))
-\f
-;;;; indenting streams
-
-(defstruct (indenting-stream (:include ansi-stream
- (out #'indenting-out)
- (sout #'indenting-sout)
- (misc #'indenting-misc))
- (:constructor make-indenting-stream (stream))
- (:copier nil))
- ;; the stream we're based on
- stream
- ;; how much we indent on each line
- (indentation 0))
-
-#!+sb-doc
-(setf (fdocumentation 'make-indenting-stream 'function)
- "Return an output stream which indents its output by some amount.")
-
-;;; INDENTING-INDENT writes the correct number of spaces needed to indent
-;;; output on the given STREAM based on the specified SUB-STREAM.
-(defmacro indenting-indent (stream sub-stream)
- ;; KLUDGE: bare magic number 60
- `(do ((i 0 (+ i 60))
- (indentation (indenting-stream-indentation ,stream)))
- ((>= i indentation))
- (%write-string
- " "
- ,sub-stream
- 0
- (min 60 (- indentation i)))))
-
-;;; INDENTING-OUT writes a character to an indenting stream.
-(defun indenting-out (stream char)
- (let ((sub-stream (indenting-stream-stream stream)))
- (write-char char sub-stream)
- (if (char= char #\newline)
- (indenting-indent stream sub-stream))))
-
-;;; INDENTING-SOUT writes a string to an indenting stream.
-(defun indenting-sout (stream string start end)
- (declare (simple-string string) (fixnum start end))
- (do ((i start)
- (sub-stream (indenting-stream-stream stream)))
- ((= i end))
- (let ((newline (position #\newline string :start i :end end)))
- (cond (newline
- (%write-string string sub-stream i (1+ newline))
- (indenting-indent stream sub-stream)
- (setq i (+ newline 1)))
- (t
- (%write-string string sub-stream i end)
- (setq i end))))))
-
-;;; INDENTING-MISC just treats just the :LINE-LENGTH message
-;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
-;;; the base stream minus the stream's indentation.
-(defun indenting-misc (stream operation &optional arg1 arg2)
- (let ((sub-stream (indenting-stream-stream stream)))
- (if (ansi-stream-p sub-stream)
- (let ((method (ansi-stream-misc sub-stream)))
- (case operation
- (:line-length
- (let ((line-length (funcall method sub-stream operation)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (funcall method sub-stream operation)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (funcall method sub-stream operation arg1 arg2))))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (case operation
- (:line-length
- (let ((line-length (stream-line-length sub-stream)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (stream-line-column sub-stream)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (stream-misc-dispatch sub-stream operation arg1 arg2))))))
-
-(declaim (maybe-inline read-char unread-char read-byte listen))
+ (declare (simple-string string) (ignore start))
+ (let ((found (position #\newline string :test #'char=
+ :end end :from-end t)))
+ (if found
+ (- end (the fixnum found))
+ current)))))
+ (:element-type
+ (array-element-type
+ (fill-pointer-output-stream-string stream)))))
\f
;;;; case frobbing streams, used by FORMAT ~(...~)
(defstruct (case-frob-stream
- (:include ansi-stream
- (misc #'case-frob-misc))
- (:constructor %make-case-frob-stream (target out sout))
- (:copier nil))
+ (:include ansi-stream
+ (misc #'case-frob-misc))
+ (:constructor %make-case-frob-stream (target out sout))
+ (:copier nil))
(target (missing-arg) :type stream))
(defun make-case-frob-stream (target kind)
#!+sb-doc
"Return a stream that sends all output to the stream TARGET, but modifies
the case of letters, depending on KIND, which should be one of:
- :upcase - convert to upper case.
- :downcase - convert to lower case.
- :capitalize - convert the first letter of words to upper case and the
- rest of the word to lower case.
- :capitalize-first - convert the first letter of the first word to upper
- case and everything else to lower case."
+ :UPCASE - convert to upper case.
+ :DOWNCASE - convert to lower case.
+ :CAPITALIZE - convert the first letter of words to upper case and the
+ rest of the word to lower case.
+ :CAPITALIZE-FIRST - convert the first letter of the first word to upper
+ case and everything else to lower case."
(declare (type stream target)
- (type (member :upcase :downcase :capitalize :capitalize-first)
- kind)
- (values stream))
+ (type (member :upcase :downcase :capitalize :capitalize-first)
+ kind)
+ (values stream))
(if (case-frob-stream-p target)
;; If we are going to be writing to a stream that already does
;; case frobbing, why bother frobbing the case just so it can
;; frob it again?
target
(multiple-value-bind (out sout)
- (ecase kind
- (:upcase
- (values #'case-frob-upcase-out
- #'case-frob-upcase-sout))
- (:downcase
- (values #'case-frob-downcase-out
- #'case-frob-downcase-sout))
- (:capitalize
- (values #'case-frob-capitalize-out
- #'case-frob-capitalize-sout))
- (:capitalize-first
- (values #'case-frob-capitalize-first-out
- #'case-frob-capitalize-first-sout)))
- (%make-case-frob-stream target out sout))))
+ (ecase kind
+ (:upcase
+ (values #'case-frob-upcase-out
+ #'case-frob-upcase-sout))
+ (:downcase
+ (values #'case-frob-downcase-out
+ #'case-frob-downcase-sout))
+ (:capitalize
+ (values #'case-frob-capitalize-out
+ #'case-frob-capitalize-sout))
+ (:capitalize-first
+ (values #'case-frob-capitalize-first-out
+ #'case-frob-capitalize-first-sout)))
+ (%make-case-frob-stream target out sout))))
(defun case-frob-misc (stream op &optional arg1 arg2)
(declare (type case-frob-stream stream))
(t
(let ((target (case-frob-stream-target stream)))
(if (ansi-stream-p target)
- (funcall (ansi-stream-misc target) target op arg1 arg2)
- (stream-misc-dispatch target op arg1 arg2))))))
+ (funcall (ansi-stream-misc target) target op arg1 arg2)
+ (stream-misc-dispatch target op arg1 arg2))))))
(defun case-frob-upcase-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream))
- (char (char-upcase char)))
+ (char (char-upcase char)))
(if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))))
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))))
(defun case-frob-upcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
- (type index start)
- (type (or index null) end))
+ (type simple-string str)
+ (type index start)
+ (type (or index null) end))
(let* ((target (case-frob-stream-target stream))
- (len (length str))
- (end (or end len))
- (string (if (and (zerop start) (= len end))
- (string-upcase str)
- (nstring-upcase (subseq str start end))))
- (string-len (- end start)))
+ (len (length str))
+ (end (or end len))
+ (string (if (and (zerop start) (= len end))
+ (string-upcase str)
+ (nstring-upcase (subseq str start end))))
+ (string-len (- end start)))
(if (ansi-stream-p target)
- (funcall (ansi-stream-sout target) target string 0 string-len)
- (stream-write-string target string 0 string-len))))
+ (funcall (ansi-stream-sout target) target string 0 string-len)
+ (stream-write-string target string 0 string-len))))
(defun case-frob-downcase-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream))
- (char (char-downcase char)))
+ (char (char-downcase char)))
(if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))))
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))))
(defun case-frob-downcase-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
- (type index start)
- (type (or index null) end))
+ (type simple-string str)
+ (type index start)
+ (type (or index null) end))
(let* ((target (case-frob-stream-target stream))
- (len (length str))
- (end (or end len))
- (string (if (and (zerop start) (= len end))
- (string-downcase str)
- (nstring-downcase (subseq str start end))))
- (string-len (- end start)))
+ (len (length str))
+ (end (or end len))
+ (string (if (and (zerop start) (= len end))
+ (string-downcase str)
+ (nstring-downcase (subseq str start end))))
+ (string-len (- end start)))
(if (ansi-stream-p target)
- (funcall (ansi-stream-sout target) target string 0 string-len)
- (stream-write-string target string 0 string-len))))
+ (funcall (ansi-stream-sout target) target string 0 string-len)
+ (stream-write-string target string 0 string-len))))
(defun case-frob-capitalize-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
- (let ((char (char-upcase char)))
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char)))
- (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
- (setf (case-frob-stream-sout stream)
- #'case-frob-capitalize-aux-sout))
- (t
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))))))
+ (let ((char (char-upcase char)))
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char)))
+ (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-aux-sout))
+ (t
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))))))
(defun case-frob-capitalize-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
- (type index start)
- (type (or index null) end))
+ (type simple-string str)
+ (type index start)
+ (type (or index null) end))
(let* ((target (case-frob-stream-target stream))
- (str (subseq str start end))
- (len (length str))
- (inside-word nil))
+ (str (subseq str start end))
+ (len (length str))
+ (inside-word nil))
(dotimes (i len)
(let ((char (schar str i)))
- (cond ((not (alphanumericp char))
- (setf inside-word nil))
- (inside-word
- (setf (schar str i) (char-downcase char)))
- (t
- (setf inside-word t)
- (setf (schar str i) (char-upcase char))))))
+ (cond ((not (alphanumericp char))
+ (setf inside-word nil))
+ (inside-word
+ (setf (schar str i) (char-downcase char)))
+ (t
+ (setf inside-word t)
+ (setf (schar str i) (char-upcase char))))))
(when inside-word
(setf (case-frob-stream-out stream)
- #'case-frob-capitalize-aux-out)
+ #'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
- #'case-frob-capitalize-aux-sout))
+ #'case-frob-capitalize-aux-sout))
(if (ansi-stream-p target)
- (funcall (ansi-stream-sout target) target str 0 len)
- (stream-write-string target str 0 len))))
+ (funcall (ansi-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
(defun case-frob-capitalize-aux-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
- (let ((char (char-downcase char)))
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))))
- (t
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))
- (setf (case-frob-stream-out stream)
- #'case-frob-capitalize-out)
- (setf (case-frob-stream-sout stream)
- #'case-frob-capitalize-sout)))))
+ (let ((char (char-downcase char)))
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))))
+ (t
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-capitalize-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-sout)))))
(defun case-frob-capitalize-aux-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
- (type index start)
- (type (or index null) end))
+ (type simple-string str)
+ (type index start)
+ (type (or index null) end))
(let* ((target (case-frob-stream-target stream))
- (str (subseq str start end))
- (len (length str))
- (inside-word t))
+ (str (subseq str start end))
+ (len (length str))
+ (inside-word t))
(dotimes (i len)
(let ((char (schar str i)))
- (cond ((not (alphanumericp char))
- (setf inside-word nil))
- (inside-word
- (setf (schar str i) (char-downcase char)))
- (t
- (setf inside-word t)
- (setf (schar str i) (char-upcase char))))))
+ (cond ((not (alphanumericp char))
+ (setf inside-word nil))
+ (inside-word
+ (setf (schar str i) (char-downcase char)))
+ (t
+ (setf inside-word t)
+ (setf (schar str i) (char-upcase char))))))
(unless inside-word
(setf (case-frob-stream-out stream)
- #'case-frob-capitalize-out)
+ #'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
- #'case-frob-capitalize-sout))
+ #'case-frob-capitalize-sout))
(if (ansi-stream-p target)
- (funcall (ansi-stream-sout target) target str 0 len)
- (stream-write-string target str 0 len))))
+ (funcall (ansi-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
(defun case-frob-capitalize-first-out (stream char)
(declare (type case-frob-stream stream)
- (type base-char char))
+ (type character char))
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
- (let ((char (char-upcase char)))
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char)))
- (setf (case-frob-stream-out stream)
- #'case-frob-downcase-out)
- (setf (case-frob-stream-sout stream)
- #'case-frob-downcase-sout))
- (t
- (if (ansi-stream-p target)
- (funcall (ansi-stream-out target) target char)
- (stream-write-char target char))))))
+ (let ((char (char-upcase char)))
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char)))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-downcase-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-downcase-sout))
+ (t
+ (if (ansi-stream-p target)
+ (funcall (ansi-stream-out target) target char)
+ (stream-write-char target char))))))
(defun case-frob-capitalize-first-sout (stream str start end)
(declare (type case-frob-stream stream)
- (type simple-base-string str)
- (type index start)
- (type (or index null) end))
+ (type simple-string str)
+ (type index start)
+ (type (or index null) end))
(let* ((target (case-frob-stream-target stream))
- (str (subseq str start end))
- (len (length str)))
+ (str (subseq str start end))
+ (len (length str)))
(dotimes (i len)
(let ((char (schar str i)))
- (when (alphanumericp char)
- (setf (schar str i) (char-upcase char))
- (do ((i (1+ i) (1+ i)))
- ((= i len))
- (setf (schar str i) (char-downcase (schar str i))))
- (setf (case-frob-stream-out stream)
- #'case-frob-downcase-out)
- (setf (case-frob-stream-sout stream)
- #'case-frob-downcase-sout)
- (return))))
+ (when (alphanumericp char)
+ (setf (schar str i) (char-upcase char))
+ (do ((i (1+ i) (1+ i)))
+ ((= i len))
+ (setf (schar str i) (char-downcase (schar str i))))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-downcase-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-downcase-sout)
+ (return))))
(if (ansi-stream-p target)
- (funcall (ansi-stream-sout target) target str 0 len)
- (stream-write-string target str 0 len))))
+ (funcall (ansi-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
\f
;;;; READ-SEQUENCE
then the extra elements near the end of sequence are not updated, and
the index of the next element is returned."
(declare (type sequence seq)
- (type stream stream)
- (type index start)
- (type sequence-end end)
- (values index))
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
+ (values index))
(if (ansi-stream-p stream)
(ansi-stream-read-sequence seq stream start end)
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-read-sequence stream seq start end)))
+(declaim (inline compatible-vector-and-stream-element-types-p))
+(defun compatible-vector-and-stream-element-types-p (vector stream)
+ (declare (type vector vector)
+ (type ansi-stream stream))
+ (or (and (typep vector '(simple-array (unsigned-byte 8) (*)))
+ (subtypep (stream-element-type stream) '(unsigned-byte 8)))
+ (and (typep vector '(simple-array (signed-byte 8) (*)))
+ (subtypep (stream-element-type stream) '(signed-byte 8)))))
+
(defun ansi-stream-read-sequence (seq stream start %end)
(declare (type sequence seq)
- (type ansi-stream stream)
- (type index start)
- (type sequence-end %end)
- (values index))
+ (type ansi-stream stream)
+ (type index start)
+ (type sequence-end %end)
+ (values index))
(let ((end (or %end (length seq))))
(declare (type index end))
(etypecase seq
(list
(let ((read-function
- (if (subtypep (stream-element-type stream) 'character)
- #'read-char
- #'read-byte)))
- (do ((rem (nthcdr start seq) (rest rem))
- (i start (1+ i)))
- ((or (endp rem) (>= i end)) i)
- (declare (type list rem)
- (type index i))
- (let ((el (funcall read-function stream nil :eof)))
- (when (eq el :eof)
- (return i))
- (setf (first rem) el)))))
+ (if (subtypep (stream-element-type stream) 'character)
+ #'ansi-stream-read-char
+ #'ansi-stream-read-byte)))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)) i)
+ (declare (type list rem)
+ (type index i))
+ (let ((el (funcall read-function stream nil :eof nil)))
+ (when (eq el :eof)
+ (return i))
+ (setf (first rem) el)))))
(vector
- (with-array-data ((data seq) (offset-start start) (offset-end end))
- (typecase data
- ((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*))
- simple-string)
- (let* ((numbytes (- end start))
- (bytes-read (sb!sys:read-n-bytes stream
- data
- offset-start
- numbytes
- nil)))
- (if (< bytes-read numbytes)
- (+ start bytes-read)
- end)))
- (t
- (let ((read-function
- (if (subtypep (stream-element-type stream) 'character)
- #'read-char
- #'read-byte)))
- (do ((i offset-start (1+ i)))
- ((>= i offset-end) end)
- (declare (type index i))
- (let ((el (funcall read-function stream nil :eof)))
- (when (eq el :eof)
- (return (+ start (- i offset-start))))
- (setf (aref data i) el)))))))))))
+ (with-array-data ((data seq) (offset-start start) (offset-end end)
+ :check-fill-pointer t)
+ (cond ((compatible-vector-and-stream-element-types-p data stream)
+ (let* ((numbytes (- end start))
+ (bytes-read (read-n-bytes stream data offset-start
+ numbytes nil)))
+ (if (< bytes-read numbytes)
+ (+ start bytes-read)
+ end)))
+ ((and (ansi-stream-cin-buffer stream)
+ (typep seq 'simple-string))
+ (ansi-stream-read-string-from-frc-buffer seq stream
+ start %end))
+ (t
+ (let ((read-function
+ (if (subtypep (stream-element-type stream) 'character)
+ ;; If the stream-element-type is CHARACTER,
+ ;; this might be a bivalent stream. If the
+ ;; sequence is a specialized unsigned-byte
+ ;; vector, try to read use binary IO. It'll
+ ;; signal an error if stream is an pure
+ ;; character stream.
+ (if (subtypep (array-element-type data)
+ 'unsigned-byte)
+ #'ansi-stream-read-byte
+ #'ansi-stream-read-char)
+ #'ansi-stream-read-byte)))
+ (do ((i offset-start (1+ i)))
+ ((>= i offset-end) end)
+ (declare (type index i))
+ (let ((el (funcall read-function stream nil :eof nil)))
+ (when (eq el :eof)
+ (return (+ start (- i offset-start))))
+ (setf (aref data i) el)))))))))))
+
+(defun ansi-stream-read-string-from-frc-buffer (seq stream start %end)
+ (declare (type simple-string seq)
+ (type ansi-stream stream)
+ (type index start)
+ (type (or null index) %end))
+ (let ((needed (- (or %end (length seq))
+ start))
+ (read 0))
+ (prepare-for-fast-read-char stream
+ (declare (ignore %frc-method%))
+ (unless %frc-buffer%
+ (return-from ansi-stream-read-string-from-frc-buffer nil))
+ (labels ((refill-buffer ()
+ (prog1
+ (fast-read-char-refill stream nil nil)
+ (setf %frc-index% (ansi-stream-in-index %frc-stream%))))
+ (add-chunk ()
+ (let* ((end (length %frc-buffer%))
+ (len (min (- end %frc-index%)
+ (- needed read))))
+ (declare (type index end len read needed))
+ (string-dispatch (simple-base-string
+ (simple-array character (*)))
+ seq
+ (replace seq %frc-buffer%
+ :start1 (+ start read)
+ :end1 (+ start read len)
+ :start2 %frc-index%
+ :end2 (+ %frc-index% len)))
+ (incf read len)
+ (incf %frc-index% len)
+ (when (or (eql needed read)
+ (refill-buffer))
+ (done-with-fast-read-char)
+ (return-from ansi-stream-read-string-from-frc-buffer
+ (+ start read))))))
+ (declare (inline refill-buffer))
+ (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
+ (refill-buffer))
+ ;; EOF had been reached before we read anything
+ ;; at all. Return the EOF value or signal the error.
+ (done-with-fast-read-char)
+ (return-from ansi-stream-read-string-from-frc-buffer start))
+ (loop (add-chunk))))))
+
\f
;;;; WRITE-SEQUENCE
#!+sb-doc
"Write the elements of SEQ bounded by START and END to STREAM."
(declare (type sequence seq)
- (type stream stream)
- (type index start)
- (type sequence-end end)
- (values sequence))
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
+ (values sequence))
(if (ansi-stream-p stream)
(ansi-stream-write-sequence seq stream start end)
;; must be Gray-streams FUNDAMENTAL-STREAM
(defun ansi-stream-write-sequence (seq stream start %end)
(declare (type sequence seq)
- (type ansi-stream stream)
- (type index start)
- (type sequence-end %end)
- (values sequence))
+ (type ansi-stream stream)
+ (type index start)
+ (type sequence-end %end)
+ (values sequence))
(let ((end (or %end (length seq))))
(declare (type index end))
(etypecase seq
(list
(let ((write-function
- (if (subtypep (stream-element-type stream) 'character)
- #'write-char
- #'write-byte)))
- (do ((rem (nthcdr start seq) (rest rem))
- (i start (1+ i)))
- ((or (endp rem) (>= i end)) seq)
- (declare (type list rem)
- (type index i))
- (funcall write-function (first rem) stream))))
+ (if (subtypep (stream-element-type stream) 'character)
+ (ansi-stream-out stream)
+ (ansi-stream-bout stream))))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)))
+ (declare (type list rem)
+ (type index i))
+ (funcall write-function stream (first rem)))))
(string
(%write-string seq stream start end))
(vector
- (let ((write-function
- (if (subtypep (stream-element-type stream) 'character)
- #'write-char
- #'write-byte)))
- (do ((i start (1+ i)))
- ((>= i end) seq)
- (declare (type index i))
- (funcall write-function (aref seq i) stream)))))))
+ (with-array-data ((data seq) (offset-start start) (offset-end end)
+ :check-fill-pointer t)
+ (labels
+ ((output-seq-in-loop ()
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ (lambda (stream object)
+ ;; This might be a bivalent stream, so we need
+ ;; to dispatch on a per-element basis, rather
+ ;; than just based on the sequence or stream
+ ;; element types.
+ (if (characterp object)
+ (funcall (ansi-stream-out stream)
+ stream object)
+ (funcall (ansi-stream-bout stream)
+ stream object)))
+ (ansi-stream-bout stream))))
+ (do ((i offset-start (1+ i)))
+ ((>= i offset-end))
+ (declare (type index i))
+ (funcall write-function stream (aref data i))))))
+ (if (and (fd-stream-p stream)
+ (compatible-vector-and-stream-element-types-p data stream))
+ (buffer-output stream data offset-start offset-end)
+ (output-seq-in-loop)))))))
+ seq)
\f
;;;; etc.