master: Fix file-position when ansi-stream-in-buffer is used
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 59adbea07c30bd1047e51cd83ffd9d9ae17688cd (commit)
from 00034f235fe352972ab69ca7a9c77c20155ffd00 (commit)
- Log -----------------------------------------------------------------
commit 59adbea07c30bd1047e51cd83ffd9d9ae17688cd
Author: Stas Boukarev <[email protected]>
Date: Fri Aug 7 22:11:58 2026 +0300
Fix file-position when ansi-stream-in-buffer is used
---
src/code/stream.lisp | 76 ++++++++++++++++++++++++++------------------------
tests/stream.pure.lisp | 5 ++++
2 files changed, 44 insertions(+), 37 deletions(-)
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index e3fc4a2f7..379069143 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -206,44 +206,46 @@
(let ((res (truly-the (or null index) (call-ansi-stream-misc stream :get-file-position)))
(delta (- +ansi-stream-in-buffer-length+
(ansi-stream-in-index stream))))
- (if (eql delta 0)
- res
- (when res
- (let ((char-size (if (fd-stream-p stream)
- (fd-stream-char-size stream)
- (external-format-char-size (stream-external-format stream)))))
- ;; For variable width encodings, count how many
- ;; bytes between the previous position and the
- ;; current position in the current character
- ;; buffer
- (+
- (- res
- (buffer-head (fd-stream-ibuf stream)))
+ (cond ((eql delta 0)
+ res)
+ ((ansi-stream-in-buffer stream)
+ (- res delta))
+ (res
+ (let ((char-size (if (fd-stream-p stream)
+ (fd-stream-char-size stream)
+ (external-format-char-size (stream-external-format stream)))))
+ ;; For variable width encodings, count how many
+ ;; bytes between the previous position and the
+ ;; current position in the current character
+ ;; buffer
+ (+
+ (- res
+ (buffer-head (fd-stream-ibuf 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
- (etypecase char-size
- (fixnum
- (+ (ansi-stream-char-buffer-byte-position-start stream)
- (* (- (ansi-stream-in-index stream)
- (ansi-stream-char-buffer-start stream))
- (truly-the (unsigned-byte 8) char-size))))
- (function
- (let ((codepoint (ansi-stream-char-buffer-byte-position-at stream))
- (target-codepoint (ansi-stream-in-index stream)))
- (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))))))))))))
+ (cond ((<= (ansi-stream-in-index stream)
+ (ansi-stream-char-buffer-start stream))
+ ;; reading from "instead"
+ (ansi-stream-char-buffer-byte-position-start stream))
+ (t
+ (etypecase char-size
+ (fixnum
+ (+ (ansi-stream-char-buffer-byte-position-start stream)
+ (* (- (ansi-stream-in-index stream)
+ (ansi-stream-char-buffer-start stream))
+ (truly-the (unsigned-byte 8) char-size))))
+ (function
+ (let ((codepoint (ansi-stream-char-buffer-byte-position-at stream))
+ (target-codepoint (ansi-stream-in-index stream)))
+ (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
diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp
index 3551104d7..40fec67dd 100644
--- a/tests/stream.pure.lisp
+++ b/tests/stream.pure.lisp
@@ -561,3 +561,8 @@
(with-open-file (i "zero")
(with-open-file (o (or #+win32 "nul" "/dev/null") :if-exists :append :direction :output)
(assert (null (file-position (make-two-way-stream i o)))))))
+
+(with-test (:name :binary-buffered-file-position)
+ (with-open-file (s "zero" :element-type '(unsigned-byte 8))
+ (read-sequence (make-list 10) s)
+ (assert (= (file-position s) 10))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL