From 273757631306c5d5c36f3aa7fed496a6d5c5f35e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 18 Oct 2008 14:11:19 +0000 Subject: [PATCH] 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. --- BUGS | 23 +-------- NEWS | 2 + src/code/host-alieneval.lisp | 107 ++++++++++++++++++++++-------------------- tests/alien.impure.lisp | 19 ++++++++ version.lisp-expr | 2 +- 5 files changed, 80 insertions(+), 73 deletions(-) diff --git a/BUGS b/BUGS index d1b1169..1a35b01 100644 --- 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 - #. - [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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4