Commit c3ca13d2 authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

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...
parent 0d74ed47

NEWS

+2 −0
Original line number Diff line number Diff line
@@ -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

src/code/host-alieneval.lisp

+6 −4
Original line number Diff line number Diff line
@@ -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))))



;;;; the ARRAY type

tests/foreign.test.sh

+15 −0
Original line number Diff line number Diff line
@@ -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

version.lisp-expr

+1 −1
Original line number Diff line number Diff line
@@ -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"