- (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
- (defun ,name (array pos end)
- (declare (optimize speed (safety 0))
- (type ,type array)
- (type array-range pos end))
- ;; returns the number of bytes consumed and nil if it's a
- ;; valid character or the number of bytes consumed and a
- ;; replacement string if it's not.
- (let ((initial-byte (,accessor array pos))
- (reject-reason nil)
- (reject-position pos)
- (remaining-bytes (- end pos)))
- (declare (type array-range reject-position remaining-bytes))
- (labels ((valid-utf8-starter-byte-p (b)
- (declare (type (unsigned-byte 8) b))
- (let ((ok (cond
- ((zerop (logand b #b10000000)) 1)
- ((= (logand b #b11100000) #b11000000)
- 2)
- ((= (logand b #b11110000) #b11100000)
- 3)
- ((= (logand b #b11111000) #b11110000)
- 4)
- ((= (logand b #b11111100) #b11111000)
- 5)
- ((= (logand b #b11111110) #b11111100)
- 6)
- (t
- nil))))
- (unless ok
- (setf reject-reason 'invalid-utf8-starter-byte))
- ok))
- (enough-bytes-left-p (x)
- (let ((ok (> end (+ pos (1- x)))))
- (unless ok
- (setf reject-reason 'end-of-input-in-character))
- ok))
- (valid-secondary-p (x)
- (let* ((idx (the array-range (+ pos x)))
- (b (,accessor array idx))
- (ok (= (logand b #b11000000) #b10000000)))
- (unless ok
- (setf reject-reason 'invalid-utf8-continuation-byte)
- (setf reject-position idx))
- ok))
- (preliminary-ok-for-length (maybe-len len)
- (and (eql maybe-len len)
- ;; Has to be done in this order so that
- ;; certain broken sequences (e.g., the
- ;; two-byte sequence `"initial (length 3)"
- ;; "non-continuation"' -- `#xef #x32')
- ;; signal only part of that sequence as
- ;; erronous.
- (loop for i from 1 below (min len remaining-bytes)
- always (valid-secondary-p i))
- (enough-bytes-left-p len)))
- (overlong-chk (x y)
- (let ((ok (or (/= initial-byte x)
- (/= (logior (,accessor array (the array-range (+ pos 1)))
- y)
- y))))
- (unless ok
- (setf reject-reason 'overlong-utf8-sequence))
- ok))
- (character-below-char-code-limit-p ()
- ;; This is only called on a four-byte sequence
- ;; (two in non-unicode builds) to ensure we
- ;; don't go over SBCL's character limts.
- (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
- nil)
- ((> (aref lexically-max 0) (,accessor array pos))
- t)
- ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
- nil)
- #!+sb-unicode
- ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
- t)
- #!+sb-unicode
- ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
- nil)
- #!+sb-unicode
- ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
- t)
- #!+sb-unicode
- ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
- nil)
- (t t))))
- (unless ok
- (setf reject-reason 'character-out-of-range))
- ok)))
- (declare (inline valid-utf8-starter-byte-p
- enough-bytes-left-p
- valid-secondary-p
- preliminary-ok-for-length
- overlong-chk))
- (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
- (cond ((eql maybe-len 1)
- (values 1 nil))
- ((and (preliminary-ok-for-length maybe-len 2)
- (overlong-chk #b11000000 #b10111111)
- (overlong-chk #b11000001 #b10111111)
- #!-sb-unicode (character-below-char-code-limit-p))
- (values 2 nil))
- ((and (preliminary-ok-for-length maybe-len 3)
- (overlong-chk #b11100000 #b10011111)
- #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
- (values 3 nil))
- ((and (preliminary-ok-for-length maybe-len 4)
- (overlong-chk #b11110000 #b10001111)
- #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
- (character-below-char-code-limit-p))
- (values 4 nil))
- ((and (preliminary-ok-for-length maybe-len 5)
- (overlong-chk #b11111000 #b10000111)
- (not (setf reject-reason 'character-out-of-range)))
- (bug "can't happen"))
- ((and (preliminary-ok-for-length maybe-len 6)
- (overlong-chk #b11111100 #b10000011)
- (not (setf reject-reason 'character-out-of-range)))
- (bug "can't happen"))
- (t
- (let* ((bad-end (ecase reject-reason
- (invalid-utf8-starter-byte
- (1+ pos))
- (end-of-input-in-character
- end)
- (invalid-utf8-continuation-byte
- reject-position)
- ((overlong-utf8-sequence character-out-of-range)
- (+ pos maybe-len))))
- (bad-len (- bad-end pos)))
- (declare (type array-range bad-end bad-len))
- (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
- (values bad-len replacement)))))))))))))
+ (declare (type (simple-array (unsigned-byte 8) (#!+sb-unicode 4 #!-sb-unicode 2)) lexically-max))
+ (defun ,name (array pos end)
+ (declare (optimize speed (safety 0))
+ (type ,type array)
+ (type array-range pos end))
+ ;; returns the number of bytes consumed and nil if it's a
+ ;; valid character or the number of bytes consumed and a
+ ;; replacement string if it's not.
+ (let ((initial-byte (,accessor array pos))
+ (reject-reason nil)
+ (reject-position pos)
+ (remaining-bytes (- end pos)))
+ (declare (type array-range reject-position remaining-bytes))
+ (labels ((valid-utf8-starter-byte-p (b)
+ (declare (type (unsigned-byte 8) b))
+ (let ((ok (cond
+ ((zerop (logand b #b10000000)) 1)
+ ((= (logand b #b11100000) #b11000000)
+ 2)
+ ((= (logand b #b11110000) #b11100000)
+ 3)
+ ((= (logand b #b11111000) #b11110000)
+ 4)
+ ((= (logand b #b11111100) #b11111000)
+ 5)
+ ((= (logand b #b11111110) #b11111100)
+ 6)
+ (t
+ nil))))
+ (unless ok
+ (setf reject-reason 'invalid-utf8-starter-byte))
+ ok))
+ (enough-bytes-left-p (x)
+ (let ((ok (> end (+ pos (1- x)))))
+ (unless ok
+ (setf reject-reason 'end-of-input-in-character))
+ ok))
+ (valid-secondary-p (x)
+ (let* ((idx (the array-range (+ pos x)))
+ (b (,accessor array idx))
+ (ok (= (logand b #b11000000) #b10000000)))
+ (unless ok
+ (setf reject-reason 'invalid-utf8-continuation-byte)
+ (setf reject-position idx))
+ ok))
+ (preliminary-ok-for-length (maybe-len len)
+ (and (eql maybe-len len)
+ ;; Has to be done in this order so that
+ ;; certain broken sequences (e.g., the
+ ;; two-byte sequence `"initial (length 3)"
+ ;; "non-continuation"' -- `#xef #x32')
+ ;; signal only part of that sequence as
+ ;; erronous.
+ (loop for i from 1 below (min len remaining-bytes)
+ always (valid-secondary-p i))
+ (enough-bytes-left-p len)))
+ (overlong-chk (x y)
+ (let ((ok (or (/= initial-byte x)
+ (/= (logior (,accessor array (the array-range (+ pos 1)))
+ y)
+ y))))
+ (unless ok
+ (setf reject-reason 'overlong-utf8-sequence))
+ ok))
+ (character-below-char-code-limit-p ()
+ ;; This is only called on a four-byte sequence
+ ;; (two in non-unicode builds) to ensure we
+ ;; don't go over SBCL's character limts.
+ (let ((ok (cond ((< (aref lexically-max 0) (,accessor array pos))
+ nil)
+ ((> (aref lexically-max 0) (,accessor array pos))
+ t)
+ ((< (aref lexically-max 1) (,accessor array (+ pos 1)))
+ nil)
+ #!+sb-unicode
+ ((> (aref lexically-max 1) (,accessor array (+ pos 1)))
+ t)
+ #!+sb-unicode
+ ((< (aref lexically-max 2) (,accessor array (+ pos 2)))
+ nil)
+ #!+sb-unicode
+ ((> (aref lexically-max 2) (,accessor array (+ pos 2)))
+ t)
+ #!+sb-unicode
+ ((< (aref lexically-max 3) (,accessor array (+ pos 3)))
+ nil)
+ (t t))))
+ (unless ok
+ (setf reject-reason 'character-out-of-range))
+ ok)))
+ (declare (inline valid-utf8-starter-byte-p
+ enough-bytes-left-p
+ valid-secondary-p
+ preliminary-ok-for-length
+ overlong-chk))
+ (let ((maybe-len (valid-utf8-starter-byte-p initial-byte)))
+ (cond ((eql maybe-len 1)
+ (values 1 nil))
+ ((and (preliminary-ok-for-length maybe-len 2)
+ (overlong-chk #b11000000 #b10111111)
+ (overlong-chk #b11000001 #b10111111)
+ #!-sb-unicode (character-below-char-code-limit-p))
+ (values 2 nil))
+ ((and (preliminary-ok-for-length maybe-len 3)
+ (overlong-chk #b11100000 #b10011111)
+ #!-sb-unicode (not (setf reject-reason 'character-out-of-range)))
+ (values 3 nil))
+ ((and (preliminary-ok-for-length maybe-len 4)
+ (overlong-chk #b11110000 #b10001111)
+ #!-sb-unicode (not (setf reject-reason 'character-out-of-range))
+ (character-below-char-code-limit-p))
+ (values 4 nil))
+ ((and (preliminary-ok-for-length maybe-len 5)
+ (overlong-chk #b11111000 #b10000111)
+ (not (setf reject-reason 'character-out-of-range)))
+ (bug "can't happen"))
+ ((and (preliminary-ok-for-length maybe-len 6)
+ (overlong-chk #b11111100 #b10000011)
+ (not (setf reject-reason 'character-out-of-range)))
+ (bug "can't happen"))
+ (t
+ (let* ((bad-end (ecase reject-reason
+ (invalid-utf8-starter-byte
+ (1+ pos))
+ (end-of-input-in-character
+ end)
+ (invalid-utf8-continuation-byte
+ reject-position)
+ ((overlong-utf8-sequence character-out-of-range)
+ (+ pos maybe-len))))
+ (bad-len (- bad-end pos)))
+ (declare (type array-range bad-end bad-len))
+ (let ((replacement (decoding-error array pos bad-end :utf-8 reject-reason reject-position)))
+ (values bad-len replacement)))))))))))))