(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))))))))
-
+ (ansi-stream-in-index stream)))
+ #!+sb-unicode
+ (let* ((external-format (stream-external-format stream))
+ (ef-entry (find-external-format external-format))
+ (variable-width-p (variable-width-external-format-p ef-entry))
+ (char-len (bytes-for-char-fun ef-entry)))
+ (- res
+ (if variable-width-p
+ (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-len (aref buffer i)))
+ (* (funcall char-len #\x) ; arbitrary argument
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream)))))))))))
(defun file-position (stream &optional position)
- (ansi-stream-file-position stream 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".
(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
(declare (ignore recursive-p))
(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)))))))))
+ ;; Check whether the FAST-READ-CHAR buffer contains a newline. If it
+ ;; does, we can do things quickly by just copying the line from the
+ ;; buffer instead of doing repeated calls to FAST-READ-CHAR.
+ (when %frc-buffer%
+ (locally
+ ;; For %FIND-POSITION transform
+ (declare (optimize (speed 2)))
+ (let ((pos (position #\Newline %frc-buffer%
+ :test #'char=
+ :start %frc-index%)))
+ (when pos
+ (let* ((len (- pos %frc-index%))
+ (res (make-string len)))
+ (replace res %frc-buffer% :start2 %frc-index% :end2 pos)
+ (setf %frc-index% (1+ pos))
+ (done-with-fast-read-char)
+ (return-from ansi-stream-read-line res))))))
+ (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)
(done-with-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)
- (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)))))
+ (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.
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
;; 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)
(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) (*)))
- (let* ((numbytes (- end start))
- (bytes-read (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)
- #'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)))))))))))
+ (if (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))
+ (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))))))))))
\f
;;;; WRITE-SEQUENCE
((output-seq-in-loop ()
(let ((write-function
(if (subtypep (stream-element-type stream) 'character)
- (ansi-stream-out stream)
+ (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))))))
- (typecase data
- ((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*)))
- (if (fd-stream-p stream)
- (output-raw-bytes stream data offset-start offset-end)
- (output-seq-in-loop)))
- (t
- (output-seq-in-loop))))))))
+ (if (and (fd-stream-p stream)
+ (compatible-vector-and-stream-element-types-p data stream))
+ (output-raw-bytes stream data offset-start offset-end)
+ (output-seq-in-loop)))))))
seq)
\f
;;;; etc.
projects / sbcl.git / blobdiff