From e29e584efdc110f14698801ad1004f9a34a3b448 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 29 Jul 2004 00:49:10 +0000 Subject: [PATCH] 0.8.13.9: Referendum Alienum * Fixed: mutually referent alien structure definitions. Test for the same. Reported by Rick Taube on sbcl-help sbcl-help 26 Jul 2004. * Fixed: WITH-ALIEN object can now refer to structures locally defined in the same WITH-ALIEN. Test for the same. --- NEWS | 4 +++ src/code/host-alieneval.lisp | 55 ++++++++++++++++++++++++++---------------- tests/alien.impure.lisp | 22 +++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 61 insertions(+), 22 deletions(-) diff --git a/NEWS b/NEWS index e513fd3..bd89023 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,10 @@ changes in sbcl-0.8.14 relative to sbcl-0.8.13: * bug fix: backtraces involving undefined functions or assembly routines are more informative. (thanks to Brian Downing) + * bug fix: mutually referent alien structures now work correctly. + (reported by Rick Taube) + * bug fix: structures defined by WITH-ALIEN can be referred to + within other definitions in the same WITH-ALIEN. changes in sbcl-0.8.13 relative to sbcl-0.8.12: * new feature: SB-PACKAGE-LOCKS. See the "Package Locks" section of diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index cca16ed..7bab89b 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -288,6 +288,15 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) (dolist (info types) + ;; Clear up the type we're about to define from the toplevel + ;; *new-auxiliary-types* (local scopes take care of themselves). + ;; Unless this is done we never actually get back the full type + ;; from INFO, since the *new-auxiliary-types* have precendence. + (setf *new-auxiliary-types* + (remove info *new-auxiliary-types* + :test (lambda (a b) + (and (eq (first a) (first b)) + (eq (second a) (second b)))))) (destructuring-bind (kind name defn) info (macrolet ((frob (kind) `(let ((old (info :alien-type ,kind name))) @@ -910,32 +919,36 @@ (define-alien-type-translator union (name &rest fields &environment env) (parse-alien-record-type :union name fields env)) +;;; FIXME: This is really pretty horrible: we avoid creating new +;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the +;;; system already. This way forwrd-references sans fields get get +;;; "updated" for free to contain the field info. Maybe rename +;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use +;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 (defun parse-alien-record-type (kind name fields env) (declare (type (or sb!kernel:lexenv null) env)) (cond (fields (let* ((old (and name (auxiliary-alien-type kind name env))) (old-fields (and old (alien-record-type-fields old)))) - (cond (old-fields - ;; KLUDGE: We can't easily compare the new fields - ;; against the old fields, since the old fields have - ;; already been parsed into an internal - ;; representation, so we just punt, assuming that - ;; they're consistent. -- WHN 200000505 - #| - (unless (equal fields old-fields) - ;; FIXME: Perhaps this should be a warning, and we - ;; should overwrite the old definition and proceed? - (error "mismatch in fields for ~S~% old ~S~% new ~S" - name old-fields fields)) - |# - old) - (t - (let ((new (make-alien-record-type :name name - :kind kind))) - (when name - (setf (auxiliary-alien-type kind name env) new)) - (parse-alien-record-fields new fields env) - new))))) + ;; KLUDGE: We can't easily compare the new fields + ;; against the old fields, since the old fields have + ;; already been parsed into an internal + ;; representation, so we just punt, assuming that + ;; they're consistent. -- WHN 200000505 + #| + (unless (equal fields old-fields) + ;; FIXME: Perhaps this should be a warning, and we + ;; should overwrite the old definition and proceed? + (error "mismatch in fields for ~S~% old ~S~% new ~S" + name old-fields fields)) + |# + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (parse-alien-record-fields type fields env) + type)))) (name (or (auxiliary-alien-type kind name env) (setf (auxiliary-alien-type kind name env) diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index 3aee388..14784ea 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -46,5 +46,27 @@ (compile nil '(lambda () (ftype-correctness "FOO" "BAR"))) (assert warningsp)) +;;; This used to break due to too eager auxiliary type twiddling in +;;; parse-alien-record-type. +(defparameter *maybe* nil) +(defun with-alien-test-for-struct-plus-funcall () + (with-alien ((x (struct bar (x unsigned) (y unsigned))) + ;; bogus definition, but we just need the symbol + (f (function int (* (struct bar))) :extern "printf")) + (when *maybe* + (alien-funcall f (addr x))))) + +;;; Mutually referent structures +(define-alien-type struct.1 (struct struct.1 (x (* (struct struct.2))) (y int))) +(define-alien-type struct.2 (struct struct.2 (x (* (struct struct.1))) (y int))) +(let ((s1 (make-alien struct.1)) + (s2 (make-alien struct.2))) + (setf (slot s1 'x) s2 + (slot s2 'x) s1 + (slot (slot s1 'x) 'y) 1 + (slot (slot s2 'x) 'y) 2) + (assert (= 1 (slot (slot s1 'x) 'y))) + (assert (= 2 (slot (slot s2 'x) 'y)))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index ce42859..e3a00ac 100644 --- 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".) -"0.8.13.8" +"0.8.13.9" -- 1.7.10.4