;;; and hence must be an N-BIN method.
(defun fast-read-char-refill (stream eof-error-p eof-value)
(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)))
+ (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))
+ (n-character-array-bytes
+ #.(/ (sb!vm:saetp-n-bits
+ (find 'character
+ sb!vm:*specialized-array-element-type-properties*
+ :key #'sb!vm:saetp-specifier))
+ sb!vm:n-byte-bits)))
(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))
- (aref ibuf start)))))
+ (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
+ n-character-array-bytes)
+ (* sb!vm:vector-data-offset
+ sb!vm:n-word-bits))
+ ibuf (+ (the index (* start
+ sb!vm:n-byte-bits
+ n-character-array-bytes))
+ (* sb!vm:vector-data-offset
+ sb!vm:n-word-bits))
+ (* count
+ sb!vm:n-byte-bits
+ n-character-array-bytes)))
+ (setf (ansi-stream-in-index stream) (1+ start))
+ (aref ibuf start)))))
;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
;;; leave room for unreading.
(element-type (string-output-stream-element-type stream))
(result
(case element-type
- ;; Overwhelmingly common case; can be inlined.
+ ;; overwhelmingly common case: can be inlined
((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)))))
;; 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-base-string
+ (replace result (string-output-stream-string stream)))
((simple-array nil (*))
(replace result (string-output-stream-string stream))))
(setf (string-output-stream-index stream) 0
;;; the CLM, but they are required for the implementation of
;;; WITH-OUTPUT-TO-STRING.
+;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
+;;; ideally without destroying all hope of efficiency.
(deftype string-with-fill-pointer ()
'(and (vector character)
(satisfies array-has-fill-pointer-p)))
(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)
+ (declare (type (simple-array character (*)) new-workspace))
+ (replace new-workspace workspace
+ :start2 start :end2 offset-current)
(setf workspace new-workspace
offset-current current)
(set-array-header buffer workspace new-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))
+ (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))
(setf (fill-pointer buffer) dst-end))
- (%byte-blt string start
- workspace offset-current offset-dst-end)))
+ (replace workspace string
+ :start1 offset-current :start2 start :end2 end)))
dst-end))
(defun fill-pointer-misc (stream operation &optional 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)))
(if (ansi-stream-p target)
(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)))
(if (ansi-stream-p target)
(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)))
(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)))
(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)))