mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Reimplement :REPLACEMENT external-formats
Don't wrap a handler around every stream or octet function. Instead, thread the replacement from the external format through the various functions all the way to the coding error site, and inline handling a coding error if a replacement is provided. In the process, also somewhat unify the behaviour of restarts around stream and octet encoding- and decoding-errors: provide a USE-VALUE restart whose argument should be a character, a string, an octet or an octet sequence, which will be used as a replacement (with encoding or decoding if necessary) to the operation that caused the error. Note a couple of TODOs in the process.
This commit is contained in:
Christophe Rhodes
parent
7484a14c41
commit
cf4d7a4e5c
|
|
@ -21,28 +21,28 @@
|
|||
(string-to-octets-name/crlf (symbolicate string-to-octets-name '/crlf)))
|
||||
`(progn
|
||||
(declaim (inline ,get-bytes-name ,get-bytes-name/cr))
|
||||
(defun ,get-bytes-name (string pos)
|
||||
(defun ,get-bytes-name (string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range pos))
|
||||
(get-latin-bytes #',code->-name ',external-format string pos))
|
||||
(defun ,string-to-octets-name (string sstart send null-padding)
|
||||
(get-latin-bytes #',code->-name ',external-format replacement string pos))
|
||||
(defun ,string-to-octets-name (string sstart send null-padding replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send))
|
||||
(values (string->latin% string sstart send #',get-bytes-name null-padding)))
|
||||
(defun ,get-bytes-name/cr (string pos)
|
||||
(values (string->latin% string sstart send #',get-bytes-name null-padding replacement)))
|
||||
(defun ,get-bytes-name/cr (string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range pos))
|
||||
(get-latin-bytes (lambda (code) (,code->-name (if (= code 10) 13 code)))
|
||||
',external-format string pos))
|
||||
(defun ,string-to-octets-name/cr (string sstart send null-padding)
|
||||
'(,external-format :newline :cr) replacement string pos))
|
||||
(defun ,string-to-octets-name/cr (string sstart send null-padding replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send))
|
||||
(values (string->latin% string sstart send #',get-bytes-name/cr null-padding)))
|
||||
(defun ,string-to-octets-name/crlf (string sstart send null-padding)
|
||||
(values (string->latin% string sstart send #',get-bytes-name/cr null-padding replacement)))
|
||||
(defun ,string-to-octets-name/crlf (string sstart send null-padding replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send))
|
||||
|
|
@ -57,7 +57,8 @@
|
|||
(vector-push-extend (,code->-name 13) array)
|
||||
(vector-push-extend byte array))
|
||||
((null byte)
|
||||
(let ((replacement (encoding-error ',external-format string i)))
|
||||
(let ((replacement (encoding-error '(,external-format :newline :crlf)
|
||||
replacement string i)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (j (length replacement))
|
||||
(vector-push-extend (aref replacement j) array))))
|
||||
|
|
@ -79,10 +80,11 @@
|
|||
``((define-condition ,',decoding-condition-name (octet-decoding-error) ())))
|
||||
,,(if invalid-bytes-p
|
||||
``(progn
|
||||
(defun ,(make-od-name ',octets-to-string-name accessor) (array astart aend)
|
||||
(defun ,(make-od-name ',octets-to-string-name accessor) (array astart aend replacement)
|
||||
(declare (optimize speed)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
(type array-range astart aend)
|
||||
(ignorable replacement))
|
||||
(let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
|
||||
(loop for apos from astart below aend
|
||||
do (let* ((byte (,accessor array apos))
|
||||
|
|
@ -92,6 +94,7 @@
|
|||
(code-char code)
|
||||
(decoding-error array apos (1+ apos)
|
||||
,',external-format
|
||||
replacement
|
||||
',',decoding-condition-name
|
||||
apos))))
|
||||
(if (characterp string-content)
|
||||
|
|
@ -99,10 +102,11 @@
|
|||
(loop for c across string-content
|
||||
do (vector-push-extend c string))))
|
||||
finally (return (coerce string 'simple-string)))))
|
||||
(defun ,(make-od-name ',octets-to-string-name/cr accessor) (array astart aend)
|
||||
(defun ,(make-od-name ',octets-to-string-name/cr accessor) (array astart aend replacement)
|
||||
(declare (optimize speed)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
(type array-range astart aend)
|
||||
(ignorable replacement))
|
||||
(let ((string (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t)))
|
||||
(loop for apos from astart below aend
|
||||
do (let* ((byte (,accessor array apos))
|
||||
|
|
@ -111,7 +115,8 @@
|
|||
(cond
|
||||
((null code)
|
||||
(decoding-error array apos (1+ apos)
|
||||
,',external-format
|
||||
'(,',external-format :newline :cr)
|
||||
replacement
|
||||
',',decoding-condition-name
|
||||
apos))
|
||||
((= code 13) (code-char 10))
|
||||
|
|
@ -122,15 +127,18 @@
|
|||
do (vector-push-extend c string))))
|
||||
finally (return (coerce string 'simple-string))))))
|
||||
``(progn
|
||||
(defun ,(make-od-name ',octets-to-string-name accessor) (array astart aend)
|
||||
(defun ,(make-od-name ',octets-to-string-name accessor) (array astart aend replacement)
|
||||
(declare (ignore replacement))
|
||||
(,(make-od-name 'latin->string accessor) array astart aend #',',->code-name))
|
||||
(defun ,(make-od-name ',octets-to-string-name/cr accessor) (array astart aend)
|
||||
(defun ,(make-od-name ',octets-to-string-name/cr accessor) (array astart aend replacement)
|
||||
(declare (ignore replacement))
|
||||
(,(make-od-name 'latin->string accessor) array astart aend
|
||||
(lambda (x) (let ((code (,',->code-name x))) (if (= code 13) 10 code)))))))
|
||||
(defun ,(make-od-name ',octets-to-string-name/crlf accessor) (array astart aend)
|
||||
(defun ,(make-od-name ',octets-to-string-name/crlf accessor) (array astart aend replacement)
|
||||
(declare (optimize speed)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
(type array-range astart aend)
|
||||
(ignorable replacement))
|
||||
(let ((string (make-array (- aend astart) :element-type 'character
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for apos from astart below aend
|
||||
|
|
@ -141,7 +149,8 @@
|
|||
,@',(when invalid-bytes-p
|
||||
`(((null code)
|
||||
(decoding-error array apos (1+ apos)
|
||||
,external-format
|
||||
'(,external-format :newline :crlf)
|
||||
replacement
|
||||
',decoding-condition-name
|
||||
apos))))
|
||||
((= code 13)
|
||||
|
|
@ -331,7 +340,7 @@
|
|||
(add-byte (logior #x80 (ldb (byte 6 6) code)))
|
||||
(add-byte (logior #x80 (ldb (byte 6 0) code))))))
|
||||
(def (name newline)
|
||||
`(defun ,name (string sstart send null-padding)
|
||||
`(defun ,name (string sstart send null-padding replacement)
|
||||
(declare (optimize (speed 3) #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type (integer 0 1) null-padding)
|
||||
|
|
@ -370,7 +379,11 @@
|
|||
:fill-pointer index))
|
||||
(replace new-array array)
|
||||
:error
|
||||
(let ((replacement (encoding-error :utf-8 string index)))
|
||||
(let ((replacement (encoding-error
|
||||
,(if (eql newline :lf)
|
||||
:utf-8
|
||||
`'(:utf-8 :newline ,newline))
|
||||
replacement string index)))
|
||||
(flet ((add-byte (b) (vector-push-extend b new-array)))
|
||||
(dotimes (i (length replacement))
|
||||
(add-byte (aref replacement i)))
|
||||
|
|
@ -395,7 +408,7 @@
|
|||
|
||||
;;; from UTF-8
|
||||
|
||||
(macrolet ((def (crlfp definer-name base-name)
|
||||
(macrolet ((def (crlfp newline definer-name base-name)
|
||||
`(progn
|
||||
(defmacro ,definer-name (accessor type)
|
||||
(let ((name (make-od-name ',base-name accessor)))
|
||||
|
|
@ -403,9 +416,9 @@
|
|||
;;(declaim (inline ,name))
|
||||
(let ((lexically-max
|
||||
(string->utf8 (string (code-char ,(1- char-code-limit)))
|
||||
0 1 0)))
|
||||
0 1 0 nil)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (#+sb-unicode 4 #-sb-unicode 2)) lexically-max))
|
||||
(defun ,name (array pos end)
|
||||
(defun ,name (array pos end replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos end))
|
||||
|
|
@ -523,11 +536,14 @@
|
|||
(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)))
|
||||
(let ((replacement (decoding-error array pos bad-end
|
||||
,,(if newline ``'(:utf-8 :newline ,,newline) '':utf-8)
|
||||
replacement reject-reason reject-position)))
|
||||
(values bad-len replacement)))))))))))))
|
||||
(instantiate-octets-definition ,definer-name))))
|
||||
(def nil define-bytes-per-utf8-character bytes-per-utf8-character)
|
||||
(def t define-bytes-per-utf8-character/crlf bytes-per-utf8-character/crlf))
|
||||
(def nil nil define-bytes-per-utf8-character bytes-per-utf8-character)
|
||||
(def nil :cr define-bytes-per-utf8-character/clr bytes-per-utf8-character/cr)
|
||||
(def t :crlf define-bytes-per-utf8-character/crlf bytes-per-utf8-character/crlf))
|
||||
|
||||
(macrolet ((def (newline definer-name base-name)
|
||||
`(progn
|
||||
|
|
@ -574,7 +590,7 @@
|
|||
(defmacro ,definer-name (accessor type)
|
||||
(let ((name (make-od-name ',base-name accessor)))
|
||||
`(progn
|
||||
(defun ,name (array astart aend)
|
||||
(defun ,name (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -582,7 +598,7 @@
|
|||
(loop with pos = astart
|
||||
while (< pos aend)
|
||||
do (multiple-value-bind (bytes invalid)
|
||||
(,(make-od-name ',bytes-per-base-name accessor) array pos aend)
|
||||
(,(make-od-name ',bytes-per-base-name accessor) array pos aend replacement)
|
||||
(declare (type (or null string) invalid))
|
||||
(cond
|
||||
((null invalid)
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@
|
|||
|
||||
;;; Conversion to UCS-2{LE,BE}
|
||||
(declaim (inline char->ucs-2le))
|
||||
(defun char->ucs-2le (char dest string pos)
|
||||
(defun char->ucs-2le (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
|
|
@ -96,13 +96,13 @@
|
|||
(declare (inline add-byte))
|
||||
(add-byte (ldb (byte 8 0) code))
|
||||
(add-byte (ldb (byte 8 8) code)))
|
||||
(let ((replacement (encoding-error :ucs-2le string pos)))
|
||||
(let ((replacement (encoding-error :ucs-2le replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest))))))
|
||||
|
||||
(declaim (inline char->ucs-2be))
|
||||
(defun char->ucs-2be (char dest string pos)
|
||||
(defun char->ucs-2be (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
|
|
@ -113,12 +113,12 @@
|
|||
(declare (inline add-byte))
|
||||
(add-byte (ldb (byte 8 8) code))
|
||||
(add-byte (ldb (byte 8 0) code)))
|
||||
(let ((replacement (encoding-error :ucs-2be string pos)))
|
||||
(let ((replacement (encoding-error :ucs-2be replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest))))))
|
||||
|
||||
(defun string->ucs-2le (string sstart send additional-space)
|
||||
(defun string->ucs-2le (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -126,12 +126,12 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->ucs-2le (char string i) array string i))
|
||||
do (char->ucs-2le (char string i) array string i replacement))
|
||||
(dotimes (i (* 2 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
||||
(defun string->ucs-2be (string sstart send additional-space)
|
||||
(defun string->ucs-2be (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -139,7 +139,7 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->ucs-2be (char string i) array string i))
|
||||
do (char->ucs-2be (char string i) array string i replacement))
|
||||
(dotimes (i (* 2 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
|
@ -289,10 +289,11 @@
|
|||
(add-byte (ldb (byte 8 8) code))
|
||||
(add-byte (ldb (byte 8 0) code)))))
|
||||
|
||||
(defun string->ucs-4le (string sstart send additional-space)
|
||||
(defun string->ucs-4le (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
(type array-range sstart send additional-space)
|
||||
(ignore replacement))
|
||||
(let ((array (make-array (* 4 (+ additional-space (- send sstart)))
|
||||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
|
|
@ -302,10 +303,11 @@
|
|||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
||||
(defun string->ucs-4be (string sstart send additional-space)
|
||||
(defun string->ucs-4be (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
(type array-range sstart send additional-space)
|
||||
(ignore replacement))
|
||||
(let ((array (make-array (* 4 (+ additional-space (- send sstart)))
|
||||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
|
|
@ -333,7 +335,7 @@
|
|||
(let ((name-le (make-od-name 'simple-get-ucs-4le-char accessor))
|
||||
(name-be (make-od-name 'simple-get-ucs-4be-char accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array pos bytes)
|
||||
(defun ,name-le (array pos bytes replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos)
|
||||
|
|
@ -351,9 +353,9 @@
|
|||
(dpb (cref 1) (byte 8 8) (cref 0))))))))
|
||||
(if (< code char-code-limit)
|
||||
(code-char code)
|
||||
(decoding-error array pos (+ pos bytes) :ucs-4le
|
||||
(decoding-error array pos (+ pos bytes) :ucs-4le replacement
|
||||
'octet-decoding-error pos))))
|
||||
(defun ,name-be (array pos bytes)
|
||||
(defun ,name-be (array pos bytes replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos)
|
||||
|
|
@ -370,7 +372,7 @@
|
|||
(dpb (cref 2) (byte 8 8) (cref 3))))))))
|
||||
(if (< code char-code-limit)
|
||||
(code-char code)
|
||||
(decoding-error array pos (+ pos bytes) :ucs-4be
|
||||
(decoding-error array pos (+ pos bytes) :ucs-4be replacement
|
||||
'octet-decoding-error pos)))))))
|
||||
|
||||
(eval-when (:compile-toplevel)
|
||||
|
|
@ -381,7 +383,7 @@
|
|||
(let ((name-le (make-od-name 'ucs-4le->string accessor))
|
||||
(name-be (make-od-name 'ucs-4be->string accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array astart aend)
|
||||
(defun ,name-le (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -392,14 +394,14 @@
|
|||
(,(make-od-name 'bytes-per-ucs-4le-character accessor) array pos aend)
|
||||
(declare (type (or null string) invalid))
|
||||
(aver (null invalid))
|
||||
(let ((thing (,(make-od-name 'simple-get-ucs-4le-char accessor) array pos bytes)))
|
||||
(let ((thing (,(make-od-name 'simple-get-ucs-4le-char accessor) array pos bytes replacement)))
|
||||
(typecase thing
|
||||
(character (vector-push-extend thing string))
|
||||
(string (dotimes (i (length thing))
|
||||
(vector-push-extend (char thing i) string)))))
|
||||
(incf pos bytes)))
|
||||
string))
|
||||
(defun ,name-be (array astart aend)
|
||||
(defun ,name-be (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -410,7 +412,7 @@
|
|||
(,(make-od-name 'bytes-per-ucs-4be-character accessor) array pos aend)
|
||||
(declare (type (or null string) invalid))
|
||||
(aver (null invalid))
|
||||
(let ((thing (,(make-od-name 'simple-get-ucs-4be-char accessor) array pos bytes)))
|
||||
(let ((thing (,(make-od-name 'simple-get-ucs-4be-char accessor) array pos bytes replacement)))
|
||||
(typecase thing
|
||||
(character (vector-push-extend thing string))
|
||||
(string (dotimes (i (length thing))
|
||||
|
|
|
|||
|
|
@ -25,12 +25,12 @@
|
|||
|
||||
;;; Conversion to UTF-16{LE,BE}
|
||||
(declaim (inline char->utf-16le))
|
||||
(defun char->utf-16le (char dest string pos)
|
||||
(defun char->utf-16le (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
(if (utf-noncharacter-code-p code)
|
||||
(let ((replacement (encoding-error :utf-16le string pos)))
|
||||
(let ((replacement (encoding-error :utf-16le replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest)))
|
||||
|
|
@ -52,12 +52,12 @@
|
|||
(add-byte (ldb (byte 8 8) low)))))))))
|
||||
|
||||
(declaim (inline char->utf-16be))
|
||||
(defun char->utf-16be (char dest string pos)
|
||||
(defun char->utf-16be (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
(if (utf-noncharacter-code-p code)
|
||||
(let ((replacement (encoding-error :utf-16be string pos)))
|
||||
(let ((replacement (encoding-error :utf-16be replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest)))
|
||||
|
|
@ -78,7 +78,7 @@
|
|||
(add-byte (ldb (byte 8 8) low))
|
||||
(add-byte (ldb (byte 8 0) low)))))))))
|
||||
|
||||
(defun string->utf-16le (string sstart send additional-space)
|
||||
(defun string->utf-16le (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -86,12 +86,12 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->utf-16le (char string i) array string i))
|
||||
do (char->utf-16le (char string i) array string i replacement))
|
||||
(dotimes (i (* 2 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
||||
(defun string->utf-16be (string sstart send additional-space)
|
||||
(defun string->utf-16be (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -99,7 +99,7 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->utf-16be (char string i) array string i))
|
||||
do (char->utf-16be (char string i) array string i replacement))
|
||||
(dotimes (i (* 2 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
|
@ -110,45 +110,45 @@
|
|||
(let ((name-le (make-od-name 'bytes-per-utf-16le-character accessor))
|
||||
(name-be (make-od-name 'bytes-per-utf-16be-character accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array pos end)
|
||||
(defun ,name-le (array pos end replacement)
|
||||
(let ((remaining (- end pos)))
|
||||
(when (< remaining 2)
|
||||
(return-from ,name-le (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))))
|
||||
(return-from ,name-le (values remaining (decoding-error array pos end :utf-16le replacement 'octet-decoding-error pos))))
|
||||
(let ((low (dpb (,accessor array (+ pos 1)) (byte 8 8) (,accessor array pos))))
|
||||
(if (<= #xd800 low #xdbff)
|
||||
(if (< remaining 4)
|
||||
(values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))
|
||||
(values remaining (decoding-error array pos end :utf-16le replacement 'octet-decoding-error pos))
|
||||
(let ((high (dpb (,accessor array (+ pos 3)) (byte 8 8) (,accessor array (+ pos 2)))))
|
||||
(if (<= #xdc00 high #xdfff)
|
||||
(let ((code (dpb (ldb (byte 10 0) low) (byte 10 10) (ldb (byte 10 0) high))))
|
||||
(if (= (logand code #xfffe) #xfffe)
|
||||
(values 4 (decoding-error array pos (+ pos 4) :utf-16le 'octet-decoding-error pos))
|
||||
(values 4 (decoding-error array pos (+ pos 4) :utf-16le replacement 'octet-decoding-error pos))
|
||||
(values 4 nil)))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos)))))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le replacement 'octet-decoding-error pos)))))
|
||||
(if (or (<= #xdc00 low #xdfff)
|
||||
(<= #xfdd0 low #xfdef)
|
||||
(= (logand low #xfffe) #xfffe))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le replacement 'octet-decoding-error pos))
|
||||
(values 2 nil))))))
|
||||
(defun ,name-be (array pos end)
|
||||
(defun ,name-be (array pos end replacement)
|
||||
(let ((remaining (- end pos)))
|
||||
(when (< remaining 2)
|
||||
(return-from ,name-be (values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))))
|
||||
(return-from ,name-be (values remaining (decoding-error array pos end :utf-16le replacement 'octet-decoding-error pos))))
|
||||
(let ((low (dpb (,accessor array pos) (byte 8 8) (,accessor array (+ pos 1)))))
|
||||
(if (<= #xd800 low #xdbff)
|
||||
(if (< remaining 4)
|
||||
(values remaining (decoding-error array pos end :utf-16le 'octet-decoding-error pos))
|
||||
(values remaining (decoding-error array pos end :utf-16le replacement 'octet-decoding-error pos))
|
||||
(let ((high (dpb (,accessor array (+ pos 2)) (byte 8 8) (,accessor array (+ pos 3)))))
|
||||
(if (<= #xdc00 high #xdfff)
|
||||
(let ((code (dpb (ldb (byte 10 0) low) (byte 10 10) (ldb (byte 10 0) high))))
|
||||
(if (= (logand code #xfffe) #xfffe)
|
||||
(values 4 (decoding-error array pos (+ pos 4) :utf-16le 'octet-decoding-error pos))
|
||||
(values 4 (decoding-error array pos (+ pos 4) :utf-16le replacement 'octet-decoding-error pos))
|
||||
(values 4 nil)))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos)))))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le replacement 'octet-decoding-error pos)))))
|
||||
(if (or (<= #xdc00 low #xdfff)
|
||||
(<= #xfdd0 low #xfdef)
|
||||
(= (logand low #xfffe) #xfffe))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le 'octet-decoding-error pos))
|
||||
(values 2 (decoding-error array pos (+ pos 2) :utf-16le replacement 'octet-decoding-error pos))
|
||||
(values 2 nil)))))))))
|
||||
(instantiate-octets-definition define-bytes-per-utf16-character)
|
||||
|
||||
|
|
@ -212,7 +212,7 @@
|
|||
(let ((name-le (make-od-name 'utf-16le->string accessor))
|
||||
(name-be (make-od-name 'utf-16be->string accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array astart aend)
|
||||
(defun ,name-le (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -220,7 +220,7 @@
|
|||
(loop with pos = astart
|
||||
while (< pos aend)
|
||||
do (multiple-value-bind (bytes invalid)
|
||||
(,(make-od-name 'bytes-per-utf-16le-character accessor) array pos aend)
|
||||
(,(make-od-name 'bytes-per-utf-16le-character accessor) array pos aend replacement)
|
||||
(declare (type (or null string) invalid))
|
||||
(cond
|
||||
((null invalid)
|
||||
|
|
@ -232,7 +232,7 @@
|
|||
(vector-push-extend (char invalid i) string))))
|
||||
(incf pos bytes)))
|
||||
string))
|
||||
(defun ,name-be (array astart aend)
|
||||
(defun ,name-be (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
(loop with pos = astart
|
||||
while (< pos aend)
|
||||
do (multiple-value-bind (bytes invalid)
|
||||
(,(make-od-name 'bytes-per-utf-16be-character accessor) array pos aend)
|
||||
(,(make-od-name 'bytes-per-utf-16be-character accessor) array pos aend replacement)
|
||||
(declare (type (or null string) invalid))
|
||||
(cond
|
||||
((null invalid)
|
||||
|
|
@ -328,12 +328,12 @@
|
|||
:char-encodable-p (not (utf-noncharacter-code-p (char-code |ch|))))
|
||||
|
||||
(declaim (inline char->utf-32le))
|
||||
(defun char->utf-32le (char dest string pos)
|
||||
(defun char->utf-32le (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
(if (utf-noncharacter-code-p code)
|
||||
(let ((replacement (encoding-error :utf-32le string pos)))
|
||||
(let ((replacement (encoding-error :utf-32le replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest)))
|
||||
|
|
@ -347,12 +347,12 @@
|
|||
(add-byte (ldb (byte 8 24) code))))))
|
||||
|
||||
(declaim (inline char->utf-32be))
|
||||
(defun char->utf-32be (char dest string pos)
|
||||
(defun char->utf-32be (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (char-code char)))
|
||||
(if (utf-noncharacter-code-p code)
|
||||
(let ((replacement (encoding-error :utf-32be string pos)))
|
||||
(let ((replacement (encoding-error :utf-32be replacement string pos)))
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) replacement))
|
||||
(dotimes (i (length replacement))
|
||||
(vector-push-extend (aref replacement i) dest)))
|
||||
|
|
@ -365,7 +365,7 @@
|
|||
(add-byte (ldb (byte 8 8) code))
|
||||
(add-byte (ldb (byte 8 0) code))))))
|
||||
|
||||
(defun string->utf-32le (string sstart send additional-space)
|
||||
(defun string->utf-32le (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -373,12 +373,12 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->utf-32le (char string i) array string i))
|
||||
do (char->utf-32le (char string i) array string i replacement))
|
||||
(dotimes (i (* 4 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
||||
(defun string->utf-32be (string sstart send additional-space)
|
||||
(defun string->utf-32be (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -386,7 +386,7 @@
|
|||
:element-type '(unsigned-byte 8)
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop for i from sstart below send
|
||||
do (char->utf-32be (char string i) array string i))
|
||||
do (char->utf-32be (char string i) array string i replacement))
|
||||
(dotimes (i (* 4 additional-space))
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
|
@ -409,7 +409,7 @@
|
|||
(let ((name-le (make-od-name 'simple-get-utf-32le-char accessor))
|
||||
(name-be (make-od-name 'simple-get-utf-32be-char accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array pos bytes)
|
||||
(defun ,name-le (array pos bytes replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos)
|
||||
|
|
@ -428,9 +428,9 @@
|
|||
(if (and (< code char-code-limit)
|
||||
(not (utf-noncharacter-code-p code)))
|
||||
(code-char code)
|
||||
(decoding-error array pos (+ pos bytes) :utf-32le
|
||||
(decoding-error array pos (+ pos bytes) :utf-32le replacement
|
||||
'octet-decoding-error pos))))
|
||||
(defun ,name-be (array pos bytes)
|
||||
(defun ,name-be (array pos bytes replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos)
|
||||
|
|
@ -448,7 +448,7 @@
|
|||
(if (and (< code char-code-limit)
|
||||
(not (utf-noncharacter-code-p code)))
|
||||
(code-char code)
|
||||
(decoding-error array pos (+ pos bytes) :utf-32be
|
||||
(decoding-error array pos (+ pos bytes) :utf-32be replacement
|
||||
'octet-decoding-error pos)))))))
|
||||
|
||||
(declaim (muffle-conditions compiler-note))
|
||||
|
|
@ -458,7 +458,7 @@
|
|||
(let ((name-le (make-od-name 'utf-32le->string accessor))
|
||||
(name-be (make-od-name 'utf-32be->string accessor)))
|
||||
`(progn
|
||||
(defun ,name-le (array astart aend)
|
||||
(defun ,name-le (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -469,14 +469,14 @@
|
|||
(,(make-od-name 'bytes-per-utf-32le-character accessor) array pos aend)
|
||||
(declare (type (or null string) invalid))
|
||||
(aver (null invalid))
|
||||
(let ((thing (,(make-od-name 'simple-get-utf-32le-char accessor) array pos bytes)))
|
||||
(let ((thing (,(make-od-name 'simple-get-utf-32le-char accessor) array pos bytes replacement)))
|
||||
(typecase thing
|
||||
(character (vector-push-extend thing string))
|
||||
(string (dotimes (i (length thing))
|
||||
(vector-push-extend (char thing i) string)))))
|
||||
(incf pos bytes)))
|
||||
string))
|
||||
(defun ,name-be (array astart aend)
|
||||
(defun ,name-be (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -487,7 +487,7 @@
|
|||
(,(make-od-name 'bytes-per-utf-32be-character accessor) array pos aend)
|
||||
(declare (type (or null string) invalid))
|
||||
(aver (null invalid))
|
||||
(let ((thing (,(make-od-name 'simple-get-utf-32be-char accessor) array pos bytes)))
|
||||
(let ((thing (,(make-od-name 'simple-get-utf-32be-char accessor) array pos bytes replacement)))
|
||||
(typecase thing
|
||||
(character (vector-push-extend thing string))
|
||||
(string (dotimes (i (length thing))
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@
|
|||
(make-od-name-list 'invalid format 'continuation-byte)))
|
||||
`(progn
|
||||
;;(declaim (inline ,name))
|
||||
(defun ,name (array pos end)
|
||||
(defun ,name (array pos end replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos end))
|
||||
|
|
@ -108,7 +108,7 @@
|
|||
reject-position)))
|
||||
(bad-len (- bad-end pos)))
|
||||
(declare (type array-range bad-end bad-len))
|
||||
(let ((replacement (decoding-error array pos bad-end ,format reject-reason reject-position)))
|
||||
(let ((replacement (decoding-error array pos bad-end ,format replacement reject-reason reject-position)))
|
||||
(values bad-len replacement))))))))))))
|
||||
|
||||
(defun define-simple-get-mb-char-1 (accessor type format mb-to-ucs)
|
||||
|
|
@ -116,7 +116,7 @@
|
|||
(malformed (make-od-name 'malformed format)))
|
||||
`(progn
|
||||
(declaim (inline ,name))
|
||||
(defun ,name (array pos bytes)
|
||||
(defun ,name (array pos bytes replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range pos)
|
||||
|
|
@ -133,7 +133,7 @@
|
|||
(if code
|
||||
(code-char code)
|
||||
(decoding-error array pos (+ pos bytes) ,format
|
||||
',malformed pos))))))))
|
||||
replacement ',malformed pos))))))))
|
||||
|
||||
(defun define-mb->string-1 (accessor type format)
|
||||
(let ((name
|
||||
|
|
@ -143,7 +143,7 @@
|
|||
(simple-get-mb-char
|
||||
(make-od-name-list 'simple-get format 'char accessor)))
|
||||
`(progn
|
||||
(defun ,name (array astart aend)
|
||||
(defun ,name (array astart aend replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type ,type array)
|
||||
(type array-range astart aend))
|
||||
|
|
@ -151,11 +151,11 @@
|
|||
(loop with pos = astart
|
||||
while (< pos aend)
|
||||
do (multiple-value-bind (bytes invalid)
|
||||
(,bytes-per-mb-character array pos aend)
|
||||
(,bytes-per-mb-character array pos aend replacement)
|
||||
(declare (type (or null string) invalid))
|
||||
(cond
|
||||
((null invalid)
|
||||
(let ((thing (,simple-get-mb-char array pos bytes)))
|
||||
(let ((thing (,simple-get-mb-char array pos bytes replacement)))
|
||||
(typecase thing
|
||||
(character (vector-push-extend thing string))
|
||||
(string
|
||||
|
|
@ -199,7 +199,7 @@
|
|||
(octet-decoding-error) ())
|
||||
|
||||
(declaim (inline ,char->mb))
|
||||
(defun ,char->mb (char dest string pos)
|
||||
(defun ,char->mb (char dest string pos replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type (array (unsigned-byte 8) (*)) dest))
|
||||
(let ((code (,ucs-to-mb (char-code char))))
|
||||
|
|
@ -219,9 +219,12 @@
|
|||
(add-byte (ldb (byte 8 16) code))
|
||||
(add-byte (ldb (byte 8 8) code))
|
||||
(add-byte (ldb (byte 8 0) code)))))
|
||||
(encoding-error ,format string pos))))
|
||||
;; TODO: it looks like this doesn't actually
|
||||
;; participate in the protocol: we should emit the
|
||||
;; octets that this returns.
|
||||
(encoding-error ,format replacement string pos))))
|
||||
|
||||
(defun ,string->mb (string sstart send additional-space)
|
||||
(defun ,string->mb (string sstart send additional-space replacement)
|
||||
(declare (optimize speed #.*safety-0*)
|
||||
(type simple-string string)
|
||||
(type array-range sstart send additional-space))
|
||||
|
|
@ -230,7 +233,7 @@
|
|||
:adjustable t
|
||||
:fill-pointer 0)))
|
||||
(loop for i from sstart below send
|
||||
do (,char->mb (char string i) array string i))
|
||||
do (,char->mb (char string i) array string i replacement))
|
||||
(dotimes (i additional-space)
|
||||
(vector-push-extend 0 array))
|
||||
(coerce array '(simple-array (unsigned-byte 8) (*)))))
|
||||
|
|
|
|||
|
|
@ -161,6 +161,7 @@
|
|||
(external-format :latin-1)
|
||||
;; fixed width, or function to call with a character
|
||||
(char-size 1 :type (or fixnum function))
|
||||
(replacement nil :type (or null character string (simple-array (unsigned-byte 8) 1)))
|
||||
(output-bytes #'ill-out :type function))
|
||||
|
||||
(defun fd-stream-bivalent-p (stream)
|
||||
|
|
@ -527,62 +528,109 @@
|
|||
;;; Returning true goes into end of file handling, false will enter another
|
||||
;;; round of input buffer filling followed by re-entering character decode.
|
||||
(defun stream-decoding-error-and-handle (stream octet-count)
|
||||
(restart-case
|
||||
(error 'stream-decoding-error
|
||||
:external-format (stream-external-format stream)
|
||||
:stream stream
|
||||
:octets (let ((buffer (fd-stream-ibuf stream)))
|
||||
(sap-ref-octets (buffer-sap buffer)
|
||||
(buffer-head buffer)
|
||||
octet-count)))
|
||||
(attempt-resync ()
|
||||
:report (lambda (stream)
|
||||
(format stream
|
||||
"~@<Attempt to resync the stream at a ~
|
||||
(let ((external-format (stream-external-format stream))
|
||||
(replacement (fd-stream-replacement stream)))
|
||||
(labels ((replacement (thing)
|
||||
(let* ((string (decoding-replacement-stringify thing external-format))
|
||||
(reversed (reverse string))
|
||||
(instead (fd-stream-instead stream)))
|
||||
(dotimes (i (length reversed))
|
||||
(vector-push-extend (char reversed i) instead))
|
||||
(when (> (length reversed) 0)
|
||||
(setf (fd-stream-listen stream) t))
|
||||
(resync)))
|
||||
(resync ()
|
||||
(fd-stream-resync stream)
|
||||
nil))
|
||||
(if replacement
|
||||
(replacement replacement)
|
||||
(restart-case
|
||||
(error 'stream-decoding-error
|
||||
:external-format external-format
|
||||
:stream stream
|
||||
:octets (let ((buffer (fd-stream-ibuf stream)))
|
||||
(sap-ref-octets (buffer-sap buffer)
|
||||
(buffer-head buffer)
|
||||
octet-count)))
|
||||
(attempt-resync ()
|
||||
:report (lambda (stream)
|
||||
(format stream
|
||||
"~@<Attempt to resync the stream at a ~
|
||||
character boundary and continue.~@:>"))
|
||||
(fd-stream-resync stream)
|
||||
nil)
|
||||
(force-end-of-file ()
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Force an end of file.~@:>"))
|
||||
(setf (fd-stream-eof-forced-p stream) t))
|
||||
(input-replacement (string)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Use string as replacement input, ~
|
||||
(resync))
|
||||
(force-end-of-file ()
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Force an end of file.~@:>"))
|
||||
(setf (fd-stream-eof-forced-p stream) t))
|
||||
(use-value (replacement)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Use datum as replacement input, ~
|
||||
attempt to resync at a character ~
|
||||
boundary and continue.~@:>"))
|
||||
:interactive (lambda ()
|
||||
(read-evaluated-form
|
||||
"Replacement byte, bytes, character, or string (evaluated): "))
|
||||
(replacement replacement))
|
||||
(input-replacement (thing)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Use string as replacement input, ~
|
||||
attempt to resync at a character ~
|
||||
boundary and continue.~@:>"))
|
||||
:interactive (lambda ()
|
||||
(format *query-io* "~@<Enter a string: ~@:>")
|
||||
(finish-output *query-io*)
|
||||
(list (read *query-io*)))
|
||||
(let ((string (reverse (string string)))
|
||||
(instead (fd-stream-instead stream)))
|
||||
(dotimes (i (length string))
|
||||
(vector-push-extend (char string i) instead))
|
||||
(fd-stream-resync stream)
|
||||
(when (> (length string) 0)
|
||||
(setf (fd-stream-listen stream) t)))
|
||||
nil)))
|
||||
:interactive (lambda ()
|
||||
(format *query-io* "~@<Enter a string: ~@:>")
|
||||
(finish-output *query-io*)
|
||||
(list (read *query-io*)))
|
||||
(replacement thing)))))))
|
||||
) ; end MACROLET
|
||||
|
||||
(defun encoding-replacement-adjust-charpos (replacement stream)
|
||||
(typecase replacement
|
||||
(character (if (char= replacement #\Newline)
|
||||
(setf (fd-stream-output-column stream) 0)
|
||||
(incf (fd-stream-output-column stream) 1)))
|
||||
(string (let ((newline-pos (position #\Newline replacement :from-end t)))
|
||||
(if newline-pos
|
||||
(setf (fd-stream-output-column stream) (- (length replacement) newline-pos 1))
|
||||
(incf (fd-stream-output-column stream) (length replacement)))))
|
||||
((unsigned-byte 8))
|
||||
((simple-array (unsigned-byte 8) 1))))
|
||||
|
||||
(defun stream-encoding-error-and-handle (stream code)
|
||||
(restart-case
|
||||
(error 'stream-encoding-error
|
||||
:external-format (stream-external-format stream)
|
||||
:stream stream
|
||||
:code code)
|
||||
(output-nothing ()
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Skip output of this character.~@:>")))
|
||||
(output-replacement (string)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Output replacement string.~@:>"))
|
||||
:interactive (lambda ()
|
||||
(format *query-io* "~@<Enter a string: ~@:>")
|
||||
(finish-output *query-io*)
|
||||
(list (read *query-io*)))
|
||||
(let ((string (string string)))
|
||||
(fd-sout stream (string string) 0 (length string))))))
|
||||
(let ((external-format (stream-external-format stream))
|
||||
(replacement (fd-stream-replacement stream)))
|
||||
(labels ((replacement (thing)
|
||||
(let ((octets (encoding-replacement-octetify thing external-format)))
|
||||
(ecase (fd-stream-buffering stream)
|
||||
(:full (buffer-output stream octets 0 (length octets)))
|
||||
(:line (buffer-output stream octets 0 (length octets)))
|
||||
(:none (write-or-buffer-output stream octets 0 (length octets))))
|
||||
(encoding-replacement-adjust-charpos thing stream))))
|
||||
(if replacement
|
||||
(replacement replacement)
|
||||
(restart-case
|
||||
(error 'stream-encoding-error
|
||||
:external-format external-format
|
||||
:stream stream
|
||||
:code code)
|
||||
(output-nothing ()
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Skip output of this character.~@:>")))
|
||||
(use-value (replacement)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Use datum as replacement output.~@:>"))
|
||||
:interactive (lambda ()
|
||||
(read-evaluated-form
|
||||
"Replacement byte, bytes, character, or string (evaluated): "))
|
||||
(replacement replacement))
|
||||
(output-replacement (string)
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Output replacement string.~@:>"))
|
||||
:interactive (lambda ()
|
||||
(format *query-io* "~@<Enter a string: ~@:>")
|
||||
(finish-output *query-io*)
|
||||
(list (read *query-io*)))
|
||||
(let ((string (string string)))
|
||||
(fd-sout stream (string string) 0 (length string)))))))))
|
||||
|
||||
(defun %external-format-encoding-error (stream code)
|
||||
(if (streamp stream)
|
||||
|
|
@ -833,6 +881,7 @@
|
|||
(names (missing-arg) :type list :read-only t)
|
||||
(newline-variant (missing-arg) :type (member :crlf :lf :cr) :read-only t)
|
||||
(default-replacement-character (missing-arg) :type character)
|
||||
(replacement nil :type (or null character string (simple-array (unsigned-byte 8) 1)))
|
||||
(read-n-chars-fun (missing-arg) :type function)
|
||||
(read-char-fun (missing-arg) :type function)
|
||||
(write-n-bytes-fun (missing-arg) :type function)
|
||||
|
|
@ -903,6 +952,7 @@
|
|||
1
|
||||
(ef-write-n-bytes-fun entry)
|
||||
(ef-char-size entry)
|
||||
(ef-replacement entry)
|
||||
(canonize-external-format external-format entry)))))
|
||||
(dolist (entry *output-routines*)
|
||||
(when (and (subtypep type (first entry))
|
||||
|
|
@ -1261,6 +1311,7 @@
|
|||
1
|
||||
(ef-read-n-chars-fun entry)
|
||||
(ef-char-size entry)
|
||||
(ef-replacement entry)
|
||||
(canonize-external-format external-format entry)))))
|
||||
(dolist (entry *input-routines*)
|
||||
(when (and (subtypep type (first entry))
|
||||
|
|
@ -1777,6 +1828,7 @@
|
|||
(bivalent-stream-p (eq element-type :default))
|
||||
normalized-external-format
|
||||
char-size
|
||||
replacement
|
||||
(bin-routine #'ill-bin)
|
||||
(bin-type nil)
|
||||
(bin-size nil)
|
||||
|
|
@ -1831,14 +1883,14 @@
|
|||
target-type)))
|
||||
(when (or (not character-stream-p) bivalent-stream-p)
|
||||
(setf (values bin-routine bin-type bin-size read-n-characters
|
||||
char-size normalized-external-format)
|
||||
char-size replacement normalized-external-format)
|
||||
(pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
|
||||
target-type)
|
||||
external-format))
|
||||
(unless bin-routine (no-input-routine)))
|
||||
(when character-stream-p
|
||||
(setf (values cin-routine cin-type cin-size read-n-characters
|
||||
char-size normalized-external-format)
|
||||
char-size replacement normalized-external-format)
|
||||
(pick-input-routine target-type external-format))
|
||||
(unless cin-routine (no-input-routine))))
|
||||
(setf (fd-stream-in fd-stream) cin-routine
|
||||
|
|
@ -1848,7 +1900,8 @@
|
|||
(setf input-type (or cin-type bin-type))
|
||||
(when normalized-external-format
|
||||
(setf (fd-stream-external-format fd-stream) normalized-external-format
|
||||
(fd-stream-char-size fd-stream) char-size))
|
||||
(fd-stream-char-size fd-stream) char-size
|
||||
(fd-stream-replacement fd-stream) replacement))
|
||||
(when (= (or cin-size 1) (or bin-size 1) 1)
|
||||
(setf (fd-stream-n-bin fd-stream) ;XXX
|
||||
(if (and character-stream-p (not bivalent-stream-p))
|
||||
|
|
@ -1879,7 +1932,7 @@
|
|||
(when output-p
|
||||
(when (or (not character-stream-p) bivalent-stream-p)
|
||||
(setf (values bout-routine bout-type bout-size output-bytes
|
||||
char-size normalized-external-format)
|
||||
char-size replacement normalized-external-format)
|
||||
(let ((buffering (fd-stream-buffering fd-stream)))
|
||||
(if bivalent-stream-p
|
||||
(pick-output-routine '(unsigned-byte 8)
|
||||
|
|
@ -1894,7 +1947,7 @@
|
|||
target-type)))
|
||||
(when character-stream-p
|
||||
(setf (values cout-routine cout-type cout-size output-bytes
|
||||
char-size normalized-external-format)
|
||||
char-size replacement normalized-external-format)
|
||||
(pick-output-routine target-type
|
||||
(fd-stream-buffering fd-stream)
|
||||
external-format))
|
||||
|
|
@ -1904,6 +1957,7 @@
|
|||
target-type)))
|
||||
(when normalized-external-format
|
||||
(setf (fd-stream-external-format fd-stream) normalized-external-format
|
||||
(fd-stream-replacement fd-stream) replacement
|
||||
(fd-stream-char-size fd-stream) char-size))
|
||||
(when character-stream-p
|
||||
(setf (fd-stream-output-bytes fd-stream) output-bytes))
|
||||
|
|
|
|||
|
|
@ -36,31 +36,35 @@
|
|||
(octets-encoding-error-position c)))
|
||||
(octets-encoding-error-external-format c)))))
|
||||
|
||||
(declaim (ftype (sfunction (t t t) (simple-array (unsigned-byte 8) 1))
|
||||
(defun encoding-replacement-octetify (thing external-format)
|
||||
(etypecase thing
|
||||
;; TODO: make sure EXTERNAL-FORMAT here does not have a REPLACEMENT, and handle
|
||||
;; encoding errors explicitly
|
||||
(character
|
||||
(string-to-octets (string thing) :external-format external-format))
|
||||
(string
|
||||
(string-to-octets thing :external-format external-format))
|
||||
((unsigned-byte 8) (make-array 1 :element-type '(unsigned-byte 8) :initial-element thing))
|
||||
(sequence (coerce thing '(simple-array (unsigned-byte 8) 1)))))
|
||||
|
||||
(declaim (ftype (sfunction (t t t t) (simple-array (unsigned-byte 8) 1))
|
||||
encoding-error))
|
||||
(defun encoding-error (external-format string pos)
|
||||
(restart-case
|
||||
(error 'octets-encoding-error
|
||||
:external-format external-format
|
||||
:string string
|
||||
:position pos)
|
||||
(use-value (replacement)
|
||||
:report "Supply a set of bytes to use in place of the invalid one."
|
||||
:interactive
|
||||
(lambda ()
|
||||
(read-evaluated-form
|
||||
"Replacement byte, bytes, character, or string (evaluated): "))
|
||||
(typecase replacement
|
||||
((unsigned-byte 8)
|
||||
(make-array 1 :element-type '(unsigned-byte 8) :initial-element replacement))
|
||||
(character
|
||||
(string-to-octets (string replacement)
|
||||
:external-format external-format))
|
||||
(string
|
||||
(string-to-octets replacement
|
||||
:external-format external-format))
|
||||
(t
|
||||
(coerce replacement '(simple-array (unsigned-byte 8) (*))))))))
|
||||
(defun encoding-error (external-format replacement string pos)
|
||||
(flet ((replacement (replacement) (encoding-replacement-octetify replacement external-format)))
|
||||
(if replacement
|
||||
(replacement replacement)
|
||||
(restart-case
|
||||
(error 'octets-encoding-error
|
||||
:external-format external-format
|
||||
:string string
|
||||
:position pos)
|
||||
(use-value (replacement)
|
||||
:report "Supply a set of bytes to use in place of the invalid one."
|
||||
:interactive
|
||||
(lambda ()
|
||||
(read-evaluated-form
|
||||
"Replacement byte, bytes, character, or string (evaluated): "))
|
||||
(replacement replacement))))))
|
||||
|
||||
;;; decoding condition
|
||||
|
||||
|
|
@ -98,21 +102,37 @@
|
|||
(define-condition invalid-utf8-continuation-byte (octet-decoding-error) ())
|
||||
(define-condition overlong-utf8-sequence (octet-decoding-error) ())
|
||||
|
||||
(defun decoding-error (array start end external-format reason pos)
|
||||
(restart-case
|
||||
(error reason
|
||||
:external-format external-format
|
||||
:array array
|
||||
:start start
|
||||
:end end
|
||||
:pos pos)
|
||||
(use-value (s)
|
||||
:report "Supply a replacement string designator."
|
||||
:interactive
|
||||
(lambda ()
|
||||
(read-evaluated-form
|
||||
"Enter a replacement string designator (evaluated): "))
|
||||
(string s))))
|
||||
(defun decoding-replacement-stringify (thing external-format)
|
||||
(etypecase thing
|
||||
(character (string thing))
|
||||
(string thing)
|
||||
;; TODO: make sure EXTERNAL-FORMAT here does not have a REPLACEMENT, and handle
|
||||
;; decoding errors explicitly
|
||||
((unsigned-byte 8)
|
||||
(let ((octets (make-array 1 :element-type '(unsigned-byte 8) :initial-element thing)))
|
||||
(octets-to-string octets :external-format external-format)))
|
||||
(sequence
|
||||
(let ((octets (coerce thing '(simple-array (unsigned-byte 8) 1))))
|
||||
(octets-to-string octets :external-format external-format)))))
|
||||
|
||||
(defun decoding-error (array start end external-format replacement reason pos)
|
||||
(flet ((replacement (thing) (decoding-replacement-stringify thing external-format)))
|
||||
(if replacement
|
||||
(replacement replacement)
|
||||
(restart-case
|
||||
(error reason
|
||||
:external-format external-format
|
||||
:array array
|
||||
:start start
|
||||
:end end
|
||||
:pos pos)
|
||||
(use-value (replacement)
|
||||
:report "Supply a replacement string."
|
||||
:interactive
|
||||
(lambda ()
|
||||
(read-evaluated-form
|
||||
"Replacement byte, bytes, character, or string (evaluated): "))
|
||||
(replacement replacement))))))
|
||||
|
||||
;;; Utilities used in both to-string and to-octet conversions
|
||||
|
||||
|
|
@ -222,17 +242,17 @@
|
|||
nil))))))))
|
||||
|
||||
(declaim (inline get-latin-bytes))
|
||||
(defun get-latin-bytes (mapper external-format string pos)
|
||||
(defun get-latin-bytes (mapper external-format replacement string pos)
|
||||
(let ((code (funcall mapper (char-code (char string pos)))))
|
||||
(declare (type (or null char-code) code))
|
||||
(values (cond
|
||||
((and code (< code 256)) code)
|
||||
(t
|
||||
(encoding-error external-format string pos)))
|
||||
(encoding-error external-format replacement string pos)))
|
||||
1)))
|
||||
|
||||
(declaim (inline string->latin%))
|
||||
(defun string->latin% (string sstart send get-bytes null-padding)
|
||||
(defun string->latin% (string sstart send get-bytes null-padding replacement)
|
||||
(declare (optimize speed)
|
||||
(type simple-string string)
|
||||
(type index sstart send)
|
||||
|
|
@ -251,7 +271,7 @@
|
|||
(tagbody
|
||||
:no-error
|
||||
(loop for pos of-type index from sstart below send
|
||||
do (let ((byte (funcall get-bytes string pos)))
|
||||
do (let ((byte (funcall get-bytes string pos replacement)))
|
||||
(typecase byte
|
||||
((unsigned-byte 8)
|
||||
(locally (declare (optimize (sb-c:insert-array-bounds-checks 0)))
|
||||
|
|
@ -280,7 +300,7 @@
|
|||
(vector-push-extend (aref thing i) new-octets))))))
|
||||
(extend error-replacement)
|
||||
(loop for pos of-type index from (1+ error-position) below send
|
||||
do (extend (funcall get-bytes string pos))
|
||||
do (extend (funcall get-bytes string pos replacement))
|
||||
finally (return-from string->latin%
|
||||
(progn
|
||||
(unless (zerop null-padding)
|
||||
|
|
@ -365,8 +385,9 @@ subsequence bounded by START and END)."
|
|||
(end end)
|
||||
:check-fill-pointer t)
|
||||
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
|
||||
(let ((ef (maybe-defaulted-external-format external-format)))
|
||||
(funcall (ef-octets-to-string-fun ef) vector start end))))
|
||||
(let* ((ef (maybe-defaulted-external-format external-format))
|
||||
(replacement (ef-replacement ef)))
|
||||
(funcall (ef-octets-to-string-fun ef) vector start end replacement))))
|
||||
|
||||
(declaim (ftype (sfunction (string &key (:external-format t)
|
||||
(:start index)
|
||||
|
|
@ -399,9 +420,10 @@ STRING (or the subsequence bounded by START and END)."
|
|||
(end end)
|
||||
:check-fill-pointer t)
|
||||
(declare (type simple-string string))
|
||||
(let ((ef (maybe-defaulted-external-format external-format)))
|
||||
(let* ((ef (maybe-defaulted-external-format external-format))
|
||||
(replacement (ef-replacement ef)))
|
||||
(funcall (ef-string-to-octets-fun ef) string start end
|
||||
(if null-terminate 1 0)))))
|
||||
(if null-terminate 1 0) replacement))))
|
||||
|
||||
;;; Vector of all available EXTERNAL-FORMAT instances. Each format is named
|
||||
;;; by one or more keyword symbols. The mapping from symbol to index into this
|
||||
|
|
@ -433,101 +455,64 @@ STRING (or the subsequence bounded by START and END)."
|
|||
(setf (get name :external-format) free-index))
|
||||
(setf (aref table free-index) ef)))
|
||||
|
||||
(defun wrap-external-format-functions (external-format fun)
|
||||
(let ((result (%copy-external-format external-format)))
|
||||
(macrolet ((frob (accessor)
|
||||
`(setf (,accessor result) (funcall fun (,accessor result)))))
|
||||
(frob ef-read-n-chars-fun)
|
||||
(frob ef-read-char-fun)
|
||||
(frob ef-write-n-bytes-fun)
|
||||
(frob ef-write-char-none-buffered-fun)
|
||||
(frob ef-write-char-line-buffered-fun)
|
||||
(frob ef-write-char-full-buffered-fun)
|
||||
(frob ef-resync-fun)
|
||||
(frob ef-bytes-for-char-fun)
|
||||
(frob ef-read-c-string-fun)
|
||||
(frob ef-write-c-string-fun)
|
||||
(frob ef-octets-to-string-fun)
|
||||
(frob ef-string-to-octets-fun))
|
||||
result))
|
||||
;;; This function was moved from 'fd-stream' because it depends on
|
||||
;;; the various error classes, two of which are defined just above.
|
||||
;;; XXX: Why does this get called with :DEFAULT and NIL when neither is
|
||||
;;; the name of any format? Shouldn't those be handled higher up,
|
||||
;;; or else this should return the actual default?
|
||||
(defun get-external-format (external-format)
|
||||
(flet ((replacement-handlerify (entry replacement)
|
||||
(wrap-external-format-functions
|
||||
entry
|
||||
(lambda (fun)
|
||||
(and fun
|
||||
(lambda (&rest rest)
|
||||
(declare (dynamic-extent rest))
|
||||
(handler-bind
|
||||
((stream-decoding-error
|
||||
(lambda (c)
|
||||
(declare (ignore c))
|
||||
(invoke-restart 'input-replacement replacement)))
|
||||
(stream-encoding-error
|
||||
(lambda (c)
|
||||
(declare (ignore c))
|
||||
(invoke-restart 'output-replacement replacement)))
|
||||
(octets-encoding-error
|
||||
(lambda (c) (use-value replacement c)))
|
||||
(octet-decoding-error
|
||||
(lambda (c) (use-value replacement c))))
|
||||
(apply fun rest))))))))
|
||||
|
||||
(binding*
|
||||
(((format-name newline replacement)
|
||||
(etypecase external-format
|
||||
;; This seem like such an unnecessarily general way to
|
||||
;; pass optional parameters. What's up with that? (I
|
||||
;; think it's because BINDING* uses MULTIPLE-VALUE-BIND
|
||||
;; but optionals are most easily handled with
|
||||
;; DESTRUCTURING-BIND)
|
||||
((cons keyword)
|
||||
(values (car external-format)
|
||||
(getf (cdr external-format) :newline :lf)
|
||||
(getf (cdr external-format) :replacement)))
|
||||
(symbol
|
||||
(values external-format :lf nil))))
|
||||
(table-index (get format-name :external-format) :exit-if-null)
|
||||
(formats *external-formats*)
|
||||
(table-entry
|
||||
;; The table entry can be one of:
|
||||
;; 1. #<external-format>
|
||||
;; 2. (#<external-format> ((:crlf #\char) . #<modified-ef>) ...)
|
||||
;; for a list of modified formats that alter the
|
||||
;; newline encoding and choice of replacement character.
|
||||
;; 3. "namestring" - to autoload from a fasl containing
|
||||
;; the named format.
|
||||
(let ((ef (svref formats table-index)))
|
||||
(etypecase ef
|
||||
((or instance list) ef)
|
||||
#+nil
|
||||
(string
|
||||
;; Theoretically allow demand-loading the external-format
|
||||
;; from a fasl of this name. (Not done yet)
|
||||
;; (module-provide-contrib ef)
|
||||
(let ((ef (svref formats table-index)))
|
||||
(aver (external-format-p ef))
|
||||
ef)))))
|
||||
((base-format variations)
|
||||
(if (listp table-entry)
|
||||
(values (car table-entry) (cdr table-entry))
|
||||
(values table-entry nil)))
|
||||
(newline-base-format
|
||||
(if (eql newline :lf)
|
||||
base-format
|
||||
(cdr (assoc (list newline) variations :test #'equal)))))
|
||||
(binding*
|
||||
(((format-name newline replacement)
|
||||
(etypecase external-format
|
||||
;; This seem like such an unnecessarily general way to
|
||||
;; pass optional parameters. What's up with that? (I
|
||||
;; think it's because BINDING* uses MULTIPLE-VALUE-BIND
|
||||
;; but optionals are most easily handled with
|
||||
;; DESTRUCTURING-BIND)
|
||||
((cons keyword)
|
||||
(values (car external-format)
|
||||
(getf (cdr external-format) :newline :lf)
|
||||
(getf (cdr external-format) :replacement)))
|
||||
(symbol
|
||||
(values external-format :lf nil))))
|
||||
(table-index (get format-name :external-format) :exit-if-null)
|
||||
(formats *external-formats*)
|
||||
(table-entry
|
||||
;; The table entry can be one of:
|
||||
;; 1. #<external-format>
|
||||
;; 2. (#<external-format> ((:crlf #\char) . #<modified-ef>) ...)
|
||||
;; for a list of modified formats that alter the
|
||||
;; newline encoding and choice of replacement character.
|
||||
;; 3. "namestring" - to autoload from a fasl containing
|
||||
;; the named format.
|
||||
(let ((ef (svref formats table-index)))
|
||||
(etypecase ef
|
||||
((or instance list) ef)
|
||||
#+nil
|
||||
(string
|
||||
;; Theoretically allow demand-loading the external-format
|
||||
;; from a fasl of this name. (Not done yet)
|
||||
;; (module-provide-contrib ef)
|
||||
(let ((ef (svref formats table-index)))
|
||||
(aver (external-format-p ef))
|
||||
ef)))))
|
||||
((base-format variations)
|
||||
(if (listp table-entry)
|
||||
(values (car table-entry) (cdr table-entry))
|
||||
(values table-entry nil)))
|
||||
(newline-base-format
|
||||
(if (eql newline :lf)
|
||||
base-format
|
||||
(cdr (assoc (list newline) variations :test #'equal)))))
|
||||
(when (or (not newline-base-format) (not replacement))
|
||||
(return-from get-external-format newline-base-format))
|
||||
(loop
|
||||
(let ((key (cons newline replacement)))
|
||||
(awhen (assoc key variations :test #'equal)
|
||||
(return (cdr it)))
|
||||
(let* ((new-ef (replacement-handlerify newline-base-format replacement))
|
||||
(let* ((new-ef (let ((copy (copy-structure newline-base-format)))
|
||||
(setf (ef-replacement copy) replacement)
|
||||
copy))
|
||||
(new-table-entry
|
||||
(cons base-format (acons key new-ef variations)))
|
||||
(old (cas (svref formats table-index) table-entry new-table-entry)))
|
||||
|
|
@ -536,7 +521,7 @@ STRING (or the subsequence bounded by START and END)."
|
|||
;; CAS failure -> some other thread added an entry. It's probably
|
||||
;; for the same replacement char which is usually #\ufffd.
|
||||
;; So try again. At worst this conses some more garbage.
|
||||
(setq table-entry old)))))))
|
||||
(setq table-entry old))))))
|
||||
|
||||
(push
|
||||
`("SB-IMPL"
|
||||
|
|
|
|||
|
|
@ -101,9 +101,7 @@
|
|||
(with-test (:name (,(macroexpand 'name env) :file ,inxf))
|
||||
(with-open-file (s *test-path* :external-format ',inxf)
|
||||
(handler-bind ((sb-int:character-decoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::attempt-resync c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (make-string 20))
|
||||
(count (read-sequence string s)))
|
||||
(assert (equal (map 'list 'identity (subseq string 0 count)) ,expected))))))
|
||||
|
|
@ -129,9 +127,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -140,7 +136,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
@ -305,9 +301,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -97,9 +97,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -108,7 +106,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
|
|||
|
|
@ -97,9 +97,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -108,7 +106,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
@ -284,9 +282,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -98,9 +98,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -109,7 +107,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
@ -255,9 +253,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -97,9 +97,7 @@
|
|||
(with-test (:name (,(macroexpand 'name env) :file ,inxf))
|
||||
(with-open-file (s *test-path* :external-format ',inxf)
|
||||
(handler-bind ((sb-int:character-decoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::attempt-resync c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (make-string 20))
|
||||
(count (read-sequence string s)))
|
||||
(assert (equal (map 'list 'identity (subseq string 0 count)) ,expected))))))
|
||||
|
|
@ -125,9 +123,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -136,7 +132,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
@ -301,9 +297,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -26,9 +26,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -26,9 +26,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -26,9 +26,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -26,9 +26,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
|
|
@ -131,9 +131,7 @@
|
|||
(with-test (:name (,(macroexpand 'name env) :file ,inxf))
|
||||
(with-open-file (s *test-path* :external-format ',inxf)
|
||||
(handler-bind ((sb-int:character-decoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::attempt-resync c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (make-string 20))
|
||||
(count (read-sequence string s)))
|
||||
(assert (equal (map 'list 'identity (subseq string 0 count)) ,expected))))))
|
||||
|
|
@ -159,9 +157,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(write-sequence ,chars s)))
|
||||
(with-test (:name (,(macroexpand 'name env) :file ,outxf))
|
||||
(with-open-file (s *test-path* :element-type '(unsigned-byte 8))
|
||||
|
|
@ -170,7 +166,7 @@
|
|||
(assert (equal (map 'list 'identity (subseq vector 0 count)) ,expected)))))
|
||||
(with-test (:name (,(macroexpand 'name env) :octets ,outxf))
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c) (use-value nil c))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let* ((string (coerce chars 'string))
|
||||
(octets (sb-ext:string-to-octets string :external-format ',outxf)))
|
||||
(assert (typep octets '(simple-array (unsigned-byte 8) 1)))
|
||||
|
|
@ -336,9 +332,7 @@
|
|||
:external-format ',outxf
|
||||
:direction :output :if-exists :supersede)
|
||||
(handler-bind ((sb-int:character-encoding-error
|
||||
(lambda (c)
|
||||
(let ((restart (find-restart 'sb-impl::output-nothing c)))
|
||||
(invoke-restart restart)))))
|
||||
(lambda (c) (use-value "" c))))
|
||||
(let ((pos (file-position s))
|
||||
(len (file-string-length s string)))
|
||||
(let ((actual
|
||||
|
|
|
|||
Loading…
Reference in a new issue