mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Stay in FD-STREAM-READ-SEQUENCE/UTF-8 after resync, replace restarts
These were returning NIL after those. This was no good for the control flow in ANSI-STREAM-READ-STRING-FROM-FRC-BUFFER.
This commit is contained in:
Richard M Kreuter
Stas Boukarev
parent
a2c2464243
commit
ca2b46c7c6
|
|
@ -919,72 +919,69 @@
|
|||
(return index))))))
|
||||
|
||||
;;; Bypass the character buffer, the caller must ensure that it's empty
|
||||
(macrolet ((def-fd-stream-read-sequence/utf-8 (name string-type simd-op newline-variant)
|
||||
#-(and sb-unicode 64-bit little-endian)
|
||||
(declare (ignore simd-op))
|
||||
`(defun ,name (stream string start end
|
||||
&aux (index start) ,@(when (eql newline-variant :crlf) '(eof)))
|
||||
(declare (type fd-stream stream)
|
||||
(type index start end index)
|
||||
(type ,string-type string))
|
||||
(block outer
|
||||
(loop
|
||||
(do ((instead (fd-stream-instead stream)))
|
||||
((= (fill-pointer instead) 0)
|
||||
(setf (fd-stream-listen stream) nil))
|
||||
(setf (aref string index) (vector-pop instead))
|
||||
(incf index)
|
||||
(when (= index end)
|
||||
(when (= (fill-pointer instead) 0)
|
||||
(setf (fd-stream-listen stream) nil))
|
||||
(return index)))
|
||||
#+(and sb-unicode 64-bit little-endian)
|
||||
(setf index (,simd-op index end string (fd-stream-ibuf stream)))
|
||||
(let* ((ibuf (fd-stream-ibuf stream))
|
||||
(head (buffer-head ibuf))
|
||||
(tail (buffer-tail ibuf))
|
||||
(sap (buffer-sap ibuf))
|
||||
,@(when (eql newline-variant :crlf) '(requested-refill))
|
||||
incomplete)
|
||||
(declare (type index head tail))
|
||||
(flet ((decode-break (reason)
|
||||
(setf (buffer-head ibuf) head)
|
||||
(when (stream-decoding-error-and-handle stream reason 1)
|
||||
(return-from outer index))
|
||||
(return)))
|
||||
(utf8-char-loop :crlf ,(eql newline-variant :crlf)))
|
||||
(when (= index end)
|
||||
(setf (buffer-head ibuf) head)
|
||||
(return index))
|
||||
(unless (catch 'eof-input-catcher (refill-input-buffer stream))
|
||||
(,@(if (eql newline-variant :crlf)
|
||||
'(if requested-refill (setf eof t))
|
||||
'(progn))
|
||||
(when (or (not incomplete)
|
||||
(stream-decoding-error-and-handle stream (- tail head) 1))
|
||||
(return index))))))))))
|
||||
(def-fd-stream-read-sequence/utf-8
|
||||
fd-stream-read-sequence/utf-8-to-string
|
||||
(macrolet ((def (name string-type simd-op newline-variant)
|
||||
#-(and sb-unicode 64-bit little-endian)
|
||||
(declare (ignore simd-op))
|
||||
`(defun ,name (stream string start end
|
||||
&aux (index start) ,@(when (eql newline-variant :crlf) '(eof)))
|
||||
(declare (type fd-stream stream)
|
||||
(type index start end index)
|
||||
(type ,string-type string))
|
||||
(tagbody
|
||||
loop
|
||||
(do ((instead (fd-stream-instead stream)))
|
||||
((= (fill-pointer instead) 0)
|
||||
(setf (fd-stream-listen stream) nil))
|
||||
(setf (aref string index) (vector-pop instead))
|
||||
(incf index)
|
||||
(when (= index end)
|
||||
(when (= (fill-pointer instead) 0)
|
||||
(setf (fd-stream-listen stream) nil))
|
||||
(return index)))
|
||||
#+(and sb-unicode 64-bit little-endian)
|
||||
(setf index (,simd-op index end string (fd-stream-ibuf stream)))
|
||||
(let* ((ibuf (fd-stream-ibuf stream))
|
||||
(head (buffer-head ibuf))
|
||||
(tail (buffer-tail ibuf))
|
||||
(sap (buffer-sap ibuf))
|
||||
,@(when (eql newline-variant :crlf) '(requested-refill))
|
||||
incomplete)
|
||||
(declare (type index head tail))
|
||||
(flet ((decode-break (reason)
|
||||
(setf (buffer-head ibuf) head)
|
||||
(if (stream-decoding-error-and-handle stream reason 1)
|
||||
(return-from ,name index)
|
||||
(go loop))))
|
||||
(utf8-char-loop :crlf ,(eql newline-variant :crlf)))
|
||||
(when (= index end)
|
||||
(setf (buffer-head ibuf) head)
|
||||
(return-from ,name index))
|
||||
(unless (catch 'eof-input-catcher (refill-input-buffer stream))
|
||||
(,@(if (eql newline-variant :crlf)
|
||||
'(if requested-refill (setf eof t))
|
||||
'(progn))
|
||||
(when (or (not incomplete)
|
||||
(stream-decoding-error-and-handle stream (- tail head) 1))
|
||||
(return-from ,name index)))))
|
||||
(go loop)))))
|
||||
(def fd-stream-read-sequence/utf-8-to-string
|
||||
(simple-array character (*))
|
||||
sb-vm::simd-copy-utf8-to-character-string
|
||||
:lf)
|
||||
sb-vm::simd-copy-utf8-to-character-string
|
||||
:lf)
|
||||
#+sb-unicode
|
||||
(def-fd-stream-read-sequence/utf-8
|
||||
fd-stream-read-sequence/utf-8-to-base-string
|
||||
simple-base-string
|
||||
sb-vm::simd-copy-utf8-to-base-string
|
||||
:lf)
|
||||
(def-fd-stream-read-sequence/utf-8
|
||||
fd-stream-read-sequence/utf-8-crlf-to-character-string
|
||||
(def fd-stream-read-sequence/utf-8-to-base-string
|
||||
simple-base-string
|
||||
sb-vm::simd-copy-utf8-to-base-string
|
||||
:lf)
|
||||
(def fd-stream-read-sequence/utf-8-crlf-to-character-string
|
||||
(simple-array character (*))
|
||||
sb-vm::simd-copy-utf8-crlf-to-character-string
|
||||
:crlf)
|
||||
sb-vm::simd-copy-utf8-crlf-to-character-string
|
||||
:crlf)
|
||||
#+sb-unicode
|
||||
(def-fd-stream-read-sequence/utf-8
|
||||
fd-stream-read-sequence/utf-8-crlf-to-base-string
|
||||
simple-base-string
|
||||
sb-vm::simd-copy-utf8-crlf-to-base-string
|
||||
:crlf))
|
||||
(def fd-stream-read-sequence/utf-8-crlf-to-base-string
|
||||
simple-base-string
|
||||
sb-vm::simd-copy-utf8-crlf-to-base-string
|
||||
:crlf))
|
||||
|
||||
#+(and sb-unicode 64-bit little-endian
|
||||
(not (or arm64 x86-64)))
|
||||
|
|
|
|||
|
|
@ -2345,12 +2345,16 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
|
|||
(replace seq %frc-buffer%
|
||||
:start1 start
|
||||
:start2 %frc-index%)
|
||||
;; Isn't this DONE-WITH-FAST-READ-CHAR?
|
||||
(setf (ansi-stream-in-index %frc-stream%)
|
||||
+ansi-stream-in-buffer-length+)
|
||||
(incf start buffered))))
|
||||
(declare (inline refill-buffer copy))
|
||||
(cond
|
||||
;; Read directly into the string when possible
|
||||
;; Caution: FD-STREAM-READ-SEQUENCE methods used to return
|
||||
;; NIL sometimes. Now they just do all of READ-SEQUENCE's
|
||||
;; contract. So don't worry about fall-thru here.
|
||||
((and (> (- needed buffered)
|
||||
(/ +ansi-stream-in-buffer-length+ 2))
|
||||
(fd-stream-p stream)
|
||||
|
|
|
|||
|
|
@ -364,6 +364,63 @@
|
|||
(error "wanted ~S, got ~S (~S)" character got n))))
|
||||
(assert (eql (read-char s nil s) s))))))
|
||||
|
||||
(with-test (:name (read-sequence :utf-8 :decoding-error-restarts))
|
||||
(flet ((test (bytes replacement string-length element-type
|
||||
expected-string expected-end &optional (start 0))
|
||||
(let ((file *test-path*))
|
||||
(with-open-file (stream file :direction :output
|
||||
:if-exists :supersede
|
||||
:element-type '(unsigned-byte 8))
|
||||
(dolist (byte bytes) (write-byte byte stream)))
|
||||
(unwind-protect
|
||||
(with-open-file (stream file :external-format :utf-8
|
||||
:element-type element-type)
|
||||
(handler-bind
|
||||
((sb-int:character-decoding-error
|
||||
(lambda (ignore)
|
||||
(declare (ignore ignore))
|
||||
(typecase replacement
|
||||
((or string character)
|
||||
(invoke-restart 'sb-impl::input-replacement replacement))
|
||||
(null (invoke-restart 'sb-int:attempt-resync))
|
||||
((eql :eof) (invoke-restart 'sb-int:force-end-of-file))))))
|
||||
(let* ((pad #\space)
|
||||
(string (make-string string-length :initial-element pad)))
|
||||
(let ((end (read-sequence string stream :start start)))
|
||||
(assert
|
||||
(equal (list (string-right-trim (list pad) string) end)
|
||||
(list expected-string expected-end)))))))
|
||||
(handler-case (delete-file file)
|
||||
(file-error ()))))))
|
||||
(let ((bad-bytes '(65 #xE0 66 67)))
|
||||
;; This doesn't call FD-STREAM-READ-SEQUENCE/UTF-8-TO-STRING because
|
||||
;; the requested number of characters, 10, is less than half a CIN
|
||||
;; buffer size. So it gives the right answer.
|
||||
(test bad-bytes #\? 10 'character "A?BC" 4)
|
||||
;; A bivalent stream has no CIN buffer, so this won't call
|
||||
;; FD-STREAM-READ-SEQUENCE/UTF-8-TO-STRING.
|
||||
(test bad-bytes #\? 10 :default "A?BC" 4)
|
||||
;; But when the stream has a CIN buffer and >256 characters are
|
||||
;; requested, when FD-STREAM-READ-SEQUENCE/UTF-8-TO-STRING
|
||||
;; encounters a decoding error, it returns NIL, which causes
|
||||
;; ANSI-STREAM-READ-STRING-FROM-FRC-BUFFER to fall thru to code that
|
||||
;; clobbers the string from the initial START arg.
|
||||
(test bad-bytes #\? 257 'character "A?BC" 4) ;; comes out as "?BC", 3 in 2.5.9
|
||||
;; One more for good luck
|
||||
(test bad-bytes "xyz" 259 'character " AxyzBC" 8 2)
|
||||
;; Now all 4 again but with ATTEMPT-RESYNC.
|
||||
(test bad-bytes nil 10 'character "ABC" 3)
|
||||
(test bad-bytes nil 10 :default "ABC" 3)
|
||||
(test bad-bytes nil 257 'character "ABC" 3) ;; comes out as "BC", 2 in 2.5.9
|
||||
(test bad-bytes nil 259 'character " ABC" 5 2) ;; comes out as "BC", 4 in 2.5.9
|
||||
;; And again with FORCE-END-OF-FILE. (These all worked right in
|
||||
;; 2.5.9, because after fall-thru there was nothing left in the
|
||||
;; stream to overwrite the #\A.
|
||||
(test bad-bytes :eof 10 'character "A" 1)
|
||||
(test bad-bytes :eof 10 :default "A" 1)
|
||||
(test bad-bytes :eof 257 'character "A" 1)
|
||||
(test bad-bytes :eof 259 'character " A" 3 2))))
|
||||
|
||||
;;; Test character decode restarts.
|
||||
(with-open-file (s *test-path* :direction :output
|
||||
:if-exists :supersede :element-type '(unsigned-byte 8))
|
||||
|
|
|
|||
Loading…
Reference in a new issue