correct octets in c-string decoding errors

  Also add SAP-REF-OCTETS for grabbing a vector of bytes from
  memory. We'll need it elsewhere as well.

  Fixes lp#985505

diff --git a/NEWS b/NEWS
index 1c5d75f..678758b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,8 @@ changes relative to sbcl-1.0.56:
   * bug fix: fix miscompilation of some logand forms with large constant
     arguments.  (lp#974406)
   * bug fix: account for funcallable-instance objects properly in ROOM.
+  * bug fix: incorrect octets reported for c-string decoding errors.
+    (lp#985505)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 09532f1..2ef025b 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2376,6 +2376,7 @@ SB-KERNEL) have been undone, but probably more remain."
                "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-WORD"
                "SAP-REF-8"
                "SAP-REF-DOUBLE" "SAP-REF-LISPOBJ" "SAP-REF-LONG"
+               "SAP-REF-OCTETS"
                "SAP-REF-SAP" "SAP-REF-SINGLE"
                "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>="
                "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 6dff66f..311a4b9 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -443,11 +443,10 @@
   (error 'c-string-encoding-error
          :external-format external-format
          :code code))
-
-(defun c-string-decoding-error (external-format octets)
+(defun c-string-decoding-error (external-format sap offset count)
   (error 'c-string-decoding-error
          :external-format external-format
-         :octets octets))
+         :octets (sap-ref-octets sap offset count)))
 
 ;;; Returning true goes into end of file handling, false will enter another
 ;;; round of input buffer filling followed by re-entering character decode.
@@ -1594,7 +1593,8 @@
                                    (incf head size)
                                    nil))
                            (when decode-break-reason
-                             (c-string-decoding-error ,name decode-break-reason))
+                             (c-string-decoding-error
+                              ,name sap head decode-break-reason))
                            (when (zerop (char-code char))
                              (return count))))
                  (string (make-string length :element-type element-type)))
@@ -1613,7 +1613,8 @@
                       (incf head size)
                       nil))
               (when decode-break-reason
-                (c-string-decoding-error ,name decode-break-reason))
+                (c-string-decoding-error
+                 ,name sap head decode-break-reason))
               (setf (aref string index) char)))))
 
       (defun ,output-c-string-function (string)

diff --git a/src/code/target-sap.lisp b/src/code/target-sap.lisp
index edb3a16..17f7191 100644 (file)
--- a/src/code/target-sap.lisp
+++ b/src/code/target-sap.lisp
@@ -65,6 +65,14 @@
            (fixnum offset))
   (sap-ref-8 sap offset))
 
+(defun sap-ref-octets (sap offset count)
+  (declare (type system-area-pointer sap)
+           (fixnum offset count))
+  (let ((buffer (make-array count :element-type '(unsigned-byte 8))))
+    (dotimes (i count)
+      (setf (aref buffer i) (sap-ref-8 sap (+ offset i))))
+    buffer))
+
 ;;; Return the 16-bit word at OFFSET bytes from SAP.
 (defun sap-ref-16 (sap offset)
   (declare (type system-area-pointer sap)

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index fe5c18e..ff4f65b 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -332,4 +332,41 @@
                 (storage-condition ()
                   :enomem)))))
 
+(with-test (:name :bug-985505)
+  ;; Check that correct octets are reported for a c-string-decoding error.
+  (assert
+   (eq :unibyte
+       (handler-case
+           (let ((c-string (coerce #(70 111 195 182 0)
+                                   '(vector (unsigned-byte 8)))))
+             (sb-sys:with-pinned-objects (c-string)
+               (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
+                                             :ascii 'character)))
+         (sb-int:c-string-decoding-error (e)
+           (assert (equalp #(195) (sb-int:character-decoding-error-octets e)))
+           :unibyte))))
+  (assert
+   (eq :multibyte-4
+       (handler-case
+           (let ((c-string (coerce #(70 111 246 0)
+                                   '(vector (unsigned-byte 8)))))
+             (sb-sys:with-pinned-objects (c-string)
+               (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
+                                             :utf-8 'character)))
+         (sb-int:c-string-decoding-error (e)
+           (assert (equalp #(246 0 0 0)
+                           (sb-int:character-decoding-error-octets e)))
+           :multibyte-4))))
+  (assert
+   (eq :multibyte-2
+       (handler-case
+           (let ((c-string (coerce #(70 195 1 182 195 182 0) '(vector (unsigned-byte 8)))))
+             (sb-sys:with-pinned-objects (c-string)
+               (sb-alien::c-string-to-string (sb-sys:vector-sap c-string)
+                                             :utf-8 'character)))
+         (sb-int:c-string-decoding-error (e)
+           (assert (equalp #(195 1)
+                           (sb-int:character-decoding-error-octets e)))
+           :multibyte-2)))))
+
 ;;; success