- (flet ((add-byte (b)
- (setf (aref array index) b)
- (incf index)))
- (declare (inline add-byte))
- (loop for i of-type index from sstart below send
- do (let ((code (char-code (char string i))))
- (case (char-len-as-utf8 code)
- (1
- (add-byte code))
- (2
- (add-byte (logior #b11000000 (ldb (byte 5 6) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
- (3
- (add-byte (logior #b11100000 (ldb (byte 4 12) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 0) code))))
- (4
- (add-byte (logior #b11110000 (ldb (byte 3 18) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 12) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 6) code)))
- (add-byte (logior #b10000000 (ldb (byte 6 0) code))))))
- finally (return array)))))))
+ (tagbody
+ :no-error
+ (flet ((add-byte (b)
+ (setf (aref array index) b)
+ (incf index)))
+ (declare (inline add-byte))
+ (loop for i of-type index from sstart below send
+ for code = (char-code (char string i))
+ do (output-code :first-error)
+ finally (return-from string->utf8 array)))
+ :first-error
+ (setf new-array (make-array (* index 2) :adjustable t
+ :element-type '(unsigned-byte 8)
+ :fill-pointer index))
+ (replace new-array array)
+ :error
+ (let ((replacement (encoding-error :utf-8 string index)))
+ (flet ((add-byte (b) (vector-push-extend b new-array)))
+ (dotimes (i (length replacement))
+ (add-byte (aref replacement i)))
+ (loop for i of-type index from (1+ error-position) below send
+ for code = (char-code (char string i))
+ do (output-code :error)
+ finally (return-from string->utf8
+ (progn
+ (unless (zerop null-padding)
+ (vector-push-extend 0 new-array))
+ (copy-seq new-array)))))))))))