1.0.24.23: fix alien struct struct member offset bug

No-one uses struct struct members, right?  Well, academics are
notoriously bad at keeping up to dat with good practice...

diff --git a/NEWS b/NEWS
index 7830d10..a9379b9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@ changes in sbcl-1.0.25 relative to 1.0.24:
   * optimization: CHAR-CODE type derivation has been improved, making
     TYPEP elimination on subtypes of CHARACTER work better. (reported
     by Tobias Rittweiler, patch by Paul Khuong)
+  * bug fix: setting alien structure fields of type struct by value now
+    computes the right offset for the memory copy.
 
 changes in sbcl-1.0.24 relative to 1.0.23:
   * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 29bb28f..920f616 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -869,13 +869,15 @@
 
 (define-alien-type-method (mem-block :extract-gen) (type sap offset)
   (declare (ignore type))
-  `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits)))
+  `(sap+ ,sap (truncate ,offset sb!vm:n-byte-bits)))
 
 (define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
-  (let ((bytes (truncate (alien-mem-block-type-bits type) sb!vm:n-byte-bits)))
-    (unless bytes
+  (let ((bits (alien-mem-block-type-bits type)))
+    (unless bits
       (error "can't deposit aliens of type ~S (unknown size)" type))
-    `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes)))
+    `(sb!kernel:system-area-ub8-copy ,value 0 ,sap
+      (truncate ,offset sb!vm:n-byte-bits)
+      ',(truncate bits sb!vm:n-byte-bits))))
 \f
 ;;;; the ARRAY type
 

diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh
index d34a900..9fff522 100644 (file)
--- a/tests/foreign.test.sh
+++ b/tests/foreign.test.sh
@@ -355,6 +355,21 @@ run_sbcl <<EOF
 EOF
 check_status_maybe_lose "ADDR of a heap-allocated object" $?
 
+run_sbcl <<EOF
+  (define-alien-type inner (struct inner (var (unsigned 32))))
+  (define-alien-type outer (struct outer (one inner) (two inner)))
+
+  (defvar *outer* (make-alien outer))
+  (defvar *inner* (make-alien inner))
+  (setf (slot *inner* 'var) 20)
+  (setf (slot *outer* 'one) *inner*)
+  (assert (= (slot (slot *outer* 'one) 'var) 20))
+  (setf (slot *inner* 'var) 40)
+  (setf (slot *outer* 'two) *inner*)
+  (assert (= (slot (slot *outer* 'two) 'var) 40))
+  (quit :unix-status $EXIT_LISP_WIN)
+EOF
+check_status_maybe_lose "struct offsets" $?
 
 # success convention for script
 exit $EXIT_TEST_WIN

diff --git a/version.lisp-expr b/version.lisp-expr
index 801c999..443f73a 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.22"
+"1.0.24.23"