- (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))
- (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))
- (replace workspace string
- :start1 offset-current :start2 start :end2 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)))