common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Move some code to the caller of external-format-char-size

Browse source
This commit is contained in:
Stas Boukarev 2026-08-07 19:49:30 +03:00
parent cb64b7018a
commit b2a1d003f4
2 changed files with 45 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
src/code/external-formats/enc-basic.lisp
View file

@ -829,44 +829,34 @@
(setf (buffer-head ibuf) head)))
(make-defs (($newline || -crlf))
(defun count-utf8$newline-byte-to-chars (stream)
(declare (optimize speed))
(let* ((ibuf (fd-stream-ibuf stream))
(sap (buffer-sap ibuf))
(index (ansi-stream-char-buffer-byte-position stream))
(codepoint (ansi-stream-char-buffer-byte-position-at stream))
(target-codepoint (ansi-stream-in-index stream)))
(declare (index index codepoint))
(when (<= (ansi-stream-in-index stream)
(ansi-stream-char-buffer-start stream)) ;; reading from "instead"
(return-from count-utf8$newline-byte-to-chars
(ansi-stream-char-buffer-byte-position-start stream)))
(when (< target-codepoint codepoint) ;; unread-char happened
;; start from scratch
(setf index (ansi-stream-char-buffer-byte-position-start stream)
codepoint (ansi-stream-char-buffer-start stream)))
(loop
(when (>= codepoint target-codepoint)
(setf (ansi-stream-char-buffer-byte-position-at stream) (ansi-stream-in-index stream)
(ansi-stream-char-buffer-byte-position stream) index)
(return index))
(let ((byte (sap-ref-8 sap index))
($when (eq '$newline '-crlf)
(tail (buffer-tail ibuf))))
(cond ((< byte #x80)
(incf index)
($when (eq '$newline '-crlf)
(when (and (= byte 13)
(< index tail)
(= (sap-ref-8 sap index) 10))
(incf index))))
((< byte #xe0)
(incf index 2))
((< byte #xf0)
(incf index 3))
(t
(incf index 4))))
(incf codepoint)))))
(defun count-utf8$newline-byte-to-chars (stream)
(declare (optimize speed))
(let* ((ibuf (fd-stream-ibuf stream))
(sap (buffer-sap ibuf))
(index (ansi-stream-char-buffer-byte-position stream))
(codepoint (ansi-stream-char-buffer-byte-position-at stream))
(target-codepoint (ansi-stream-in-index stream)))
(declare (index index codepoint))
(loop
(when (>= codepoint target-codepoint)
(return index))
(let ((byte (sap-ref-8 sap index))
($when (eq '$newline '-crlf)
(tail (buffer-tail ibuf))))
(cond ((< byte #x80)
(incf index)
($when (eq '$newline '-crlf)
(when (and (= byte 13)
(< index tail)
(= (sap-ref-8 sap index) 10))
(incf index))))
((< byte #xe0)
(incf index 2))
((< byte #xf0)
(incf index 3))
(t
(incf index 4))))
(incf codepoint)))))
(defun fd-stream-read-n-characters/utf-8 (stream string size-buffer start end &aux (index start))
(declare (ignore size-buffer))

18
src/code/stream.lisp
View file

@ -226,7 +226,23 @@
(+
(- res
(buffer-head (fd-stream-ibuf stream)))
(funcall char-size stream)))))))))))
(let ((codepoint (ansi-stream-char-buffer-byte-position-at stream))
(target-codepoint (ansi-stream-in-index stream)))
(cond ((<= (ansi-stream-in-index stream)
(ansi-stream-char-buffer-start stream))
;; reading from "instead"
(ansi-stream-char-buffer-byte-position-start stream))
(t
(when (< target-codepoint codepoint) ;; unread-char happened
;; start from scratch
(setf (ansi-stream-char-buffer-byte-position stream)
(ansi-stream-char-buffer-byte-position-start stream)
(ansi-stream-char-buffer-byte-position-at stream)
(ansi-stream-char-buffer-start stream)))
(let ((byte (funcall char-size stream)))
(setf (ansi-stream-char-buffer-byte-position-at stream) (ansi-stream-in-index stream)
(ansi-stream-char-buffer-byte-position stream) byte)
byte))))))))))))))
;;; You're not allowed to specify NIL for the position but we were permitting
;;; it, which made it impossible to test for a bad call that tries to assign