1.0.21.29: handle alien record type redefinitions (bug 431)

 * Make PARSE-ALIEN-RECORD-FIELD return the parsed values instead of
   frobbing the type object.

 * In PARSE-ALIEN-RECORD-TYPE use that to parse the new fields so that
   we can compare them to the old ones -- signal a continuable error
   if there is a mismatch.

diff --git a/BUGS b/BUGS
index d1b1169..1a35b01 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1920,25 +1920,4 @@ generally try to check returns in safe code, so we should here too.)
  MAKE-FOO).
 
 431: alien strucure redefinition doesn't work as expected
-
-  (define-alien-type nil (struct mystruct (myshort short) (mychar char)))
-
-  (with-alien ((myst (struct mystruct)))
-    (with-alien ((mysh short (slot myst 'myshort)))
-      (integerp mysh)))
-
-  (define-alien-type nil (struct mystruct (myint int) (mychar char)))
-
-  (with-alien ((myst (struct mystruct)))
-    (with-alien ((myin int (slot myst 'myint)))
-      (integerp myin)))
-
-  results in error:
-
-   There is no slot named MYINT in
-     #<SB-ALIEN-INTERNALS:ALIEN-RECORD-TYPE (STRUCT MYSTRUCT
-                                             (MYSHORT (SIGNED 16))
-                                             (MYCHAR (SIGNED 8)))>.
-   [Condition of type SIMPLE-ERROR]
-
-  reported by Neil Haven on sbcl-devel.
+  fixed in 1.0.21.29

diff --git a/NEWS b/NEWS
index a50368b..27ca910 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -42,6 +42,8 @@ changes in sbcl-1.0.22 relative to 1.0.21:
     (SB-C::&OPTIONAL-DISPATCH ...) as their name.
   * bug fix: redefining a function with non-required arguments didn't
     update the system's knowledge about its call signature properly.
+  * bug fix: fixed #431; incompatible alien record type redefinitions
+    are detected and handled. (reported by Neil Haven)
 
 changes in sbcl-1.0.21 relative to 1.0.20:
   * new feature: the compiler is able to track the effective type of a

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 92c529c..29bb28f 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -962,41 +962,45 @@
 ;;; 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))))
-           ;; 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)
-                   (make-alien-record-type :name name :kind kind))))
-        (t
-         (make-alien-record-type :kind kind))))
-
-;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and
-;;; union types. RESULT holds the record type we are paring the fields
-;;; of, and FIELDS is the list of field specifications.
-(defun parse-alien-record-fields (result fields env)
-  (declare (type alien-record-type result)
-           (type list fields))
+  (flet ((frob-type (type new-fields alignment bits)
+           (setf (alien-record-type-fields type) new-fields
+                 (alien-record-type-alignment type) alignment
+                 (alien-record-type-bits type) bits)))
+      (cond (fields
+             (multiple-value-bind (new-fields alignment bits)
+                 (parse-alien-record-fields kind fields env)
+               (let* ((old (and name (auxiliary-alien-type kind name env)))
+                      (old-fields (and old (alien-record-type-fields old))))
+                 (when (and old-fields
+                            (notevery #'record-fields-match-p old-fields new-fields))
+                   (cerror "Continue, clobbering the old definition."
+                           "Incompatible alien record type definition~%Old: ~S~%New: ~S"
+                           (unparse-alien-type old)
+                           `(,(unparse-alien-record-kind kind)
+                              ,name
+                              ,@(mapcar #'unparse-alien-record-field new-fields)))
+                   (frob-type old new-fields alignment bits))
+                 (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))
+                       (frob-type type new-fields alignment bits)
+                       type)))))
+            (name
+             (or (auxiliary-alien-type kind name env)
+                 (setf (auxiliary-alien-type kind name env)
+                       (make-alien-record-type :name name :kind kind))))
+            (t
+             (make-alien-record-type :kind kind)))))
+
+;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union
+;;; types. KIND is the kind we are paring the fields of, and FIELDS is the
+;;; list of field specifications.
+;;;
+;;; Result is a list of field objects, overall alignment, and number of bits
+(defun parse-alien-record-fields (kind fields env)
+  (declare (type list fields))
   (let ((total-bits 0)
         (overall-alignment 1)
         (parsed-fields nil))
@@ -1015,34 +1019,37 @@
           (when (null alignment)
             (error "unknown alignment: ~S" (unparse-alien-type field-type)))
           (setf overall-alignment (max overall-alignment alignment))
-          (ecase (alien-record-type-kind result)
+          (ecase kind
             (:struct
              (let ((offset (align-offset total-bits alignment)))
                (setf (alien-record-field-offset parsed-field) offset)
                (setf total-bits (+ offset bits))))
             (:union
              (setf total-bits (max total-bits bits)))))))
-    (let ((new (nreverse parsed-fields)))
-      (setf (alien-record-type-fields result) new))
-    (setf (alien-record-type-alignment result) overall-alignment)
-    (setf (alien-record-type-bits result)
-          (align-offset total-bits overall-alignment))))
+    (values (nreverse parsed-fields)
+            overall-alignment
+            (align-offset total-bits overall-alignment))))
 
 (define-alien-type-method (record :unparse) (type)
-  `(,(case (alien-record-type-kind type)
-       (:struct 'struct)
-       (:union 'union)
-       (t '???))
+  `(,(unparse-alien-record-kind (alien-record-type-kind type))
     ,(alien-record-type-name type)
     ,@(unless (member type *record-types-already-unparsed* :test #'eq)
         (push type *record-types-already-unparsed*)
-        (mapcar (lambda (field)
-                  `(,(alien-record-field-name field)
-                    ,(%unparse-alien-type (alien-record-field-type field))
-                    ,@(if (alien-record-field-bits field)
-                          (list (alien-record-field-bits field)))))
+        (mapcar #'unparse-alien-record-field
                 (alien-record-type-fields type)))))
 
+(defun unparse-alien-record-kind (kind)
+  (case kind
+    (:struct 'struct)
+    (:union 'union)
+    (t '???)))
+
+(defun unparse-alien-record-field (field)
+  `(,(alien-record-field-name field)
+     ,(%unparse-alien-type (alien-record-field-type field))
+     ,@(when (alien-record-field-bits field)
+             (list (alien-record-field-bits field)))))
+
 ;;; Test the record fields. Keep a hashtable table of already compared
 ;;; types to detect cycles.
 (defun record-fields-match-p (field1 field2)

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index 74da45a..5029774 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -226,4 +226,23 @@
     (loop repeat 1024
           do (try-to-leak-alien-stack t))))
 
+;;; bug 431
+(with-test (:name :alien-struct-redefinition)
+  (eval '(progn
+          (define-alien-type nil (struct mystruct (myshort short) (mychar char)))
+          (with-alien ((myst (struct mystruct)))
+            (with-alien ((mysh short (slot myst 'myshort)))
+              (assert (integerp mysh))))))
+  (let ((restarted 0))
+    (handler-bind ((error (lambda (e)
+                            (let ((cont (find-restart 'continue e)))
+                              (when cont
+                                (incf restarted)
+                                (invoke-restart cont))))))
+      (eval '(define-alien-type nil (struct mystruct (myint int) (mychar char)))))
+    (assert (= 1 restarted)))
+  (eval '(with-alien ((myst (struct mystruct)))
+          (with-alien ((myin int (slot myst 'myint)))
+            (assert (integerp myin))))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 5339d02..3db9bd3 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.21.28"
+"1.0.21.29"