From: Christophe Rhodes Date: Fri, 31 Dec 2004 11:50:54 +0000 (+0000) Subject: 0.8.18.4: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=683e2bd6292cffb08f6033e3197971782f7e39ff;p=sbcl.git 0.8.18.4: Pass defaulted initargs, not just present initargs, to methods on SHARED-INITIALIZE and INITIALIZE-INSTANCE in ctor.lisp ... test, both for constant and variable initforms; ... I wish I could remember who reported this bug where. --- diff --git a/NEWS b/NEWS index 601d7bd..4922f52 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,10 @@ changes in sbcl-0.8.19 relative to sbcl-0.8.18: * enhancement: saving cores with foreign code loaded is now supported on ppc/Darwin in addition to the previously supported platforms. + * bug fix: invalid :DEFAULT-INITARGS are detected in compiled calls + to MAKE-INSTANCE. + * bug fix: defaulted initargs are passed to INITIALIZE-INSTANCE and + SHARED-INITIALIZE methods from compiled calls to MAKE-INSTANCE. changes in sbcl-0.8.18 relative to sbcl-0.8.17: * new feature: reloading changed shared object files with diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 9e09462..e783253 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -421,25 +421,28 @@ (standard-sort-methods si-methods) (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) - (let ((initargs (ctor-initargs ctor)) - (slot-inits (slot-init-forms ctor (or ii-before si-before)))) + (let ((initargs (ctor-initargs ctor))) + (multiple-value-bind (bindings vars defaulting-initargs body) + (slot-init-forms ctor (or ii-before si-before)) (values - `(let (,@(when (or ii-before ii-after) - `((.ii-args. - (list .instance. ,@(quote-plist-keys initargs))))) - ,@(when (or si-before si-after) - `((.si-args. - (list .instance. t ,@(quote-plist-keys initargs)))))) + `(let ,bindings + (declare (ignorable ,@vars)) + (let (,@(when (or ii-before ii-after) + `((.ii-args. + (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs)))) + ,@(when (or si-before si-after) + `((.si-args. + (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs))))) ,@(loop for method in ii-before collect `(invoke-method ,method .ii-args.)) ,@(loop for method in si-before collect `(invoke-method ,method .si-args.)) - ,slot-inits + ,@body ,@(loop for method in si-after collect `(invoke-method ,method .si-args.)) ,@(loop for method in ii-after - collect `(invoke-method ,method .ii-args.))) - (or ii-before si-before)))))) + collect `(invoke-method ,method .ii-args.)))) + (or ii-before si-before))))))) ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after @@ -475,6 +478,7 @@ :initial-element nil)) (class-inits ()) (default-inits ()) + (defaulting-initargs ()) (default-initargs (class-default-initargs class)) (initarg-locations (compute-initarg-locations @@ -524,6 +528,13 @@ unless (member key initkeys :test #'eq) do (let* ((type (if (constantp initform) 'constant 'var)) (init (if (eq type 'var) initfn initform))) + (ecase type + (constant + (push key defaulting-initargs) + (push initform defaulting-initargs)) + (var + (push key defaulting-initargs) + (push (default-init-var-name i) defaulting-initargs))) (when (eq type 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) @@ -587,10 +598,14 @@ collect var into vars collect `(,var (funcall ,initfn)) into bindings finally (return (values vars bindings))) - `(let ,bindings + ;; FIXME: adjust comment above! + (values bindings vars (nreverse defaulting-initargs) + `(,@(delete nil instance-init-forms) + ,@class-init-forms))))))) +#| `(let ,bindings (declare (ignorable ,@vars)) ,@(delete nil instance-init-forms) - ,@class-init-forms)))))) + ,@class-init-forms))))))|# ;;; Return an alist of lists (KEY LOCATION ...) telling, for each ;;; key in INITKEYS, which locations the initarg initializes. diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index e6a4f8b..5b42736 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -129,6 +129,25 @@ (ignore-errors (make-instance 'invalid-default-initargs :foo 1)) (assert (null result)) (assert (typep condition 'program-error))) +;;; :DEFAULT-INITARGS not passed to INITIALIZE-INSTANCE or +;;; SHARED-INITIALIZE :BEFORE methods. +(defclass default-initargs-with-method () + ((foo :initarg :valid-initarg)) + (:default-initargs :valid-initarg 2)) +(defmethod shared-initialize :before ((thing default-initargs-with-method) + slot-names &key valid-initarg) + (assert (= valid-initarg 2))) +(make-instance 'default-initargs-with-method) +;;; and a test with a non-constant initarg +(defvar *d-i-w-m-2* 0) +(defclass default-initargs-with-method2 () + ((foo :initarg :valid-initarg)) + (:default-initargs :valid-initarg (incf *d-i-w-m-2*))) +(defmethod shared-initialize :before ((thing default-initargs-with-method2) + slot-names &key valid-initarg) + (assert (= valid-initarg 1))) +(make-instance 'default-initargs-with-method2) +(assert (= *d-i-w-m-2* 1)) ;;; from Axel Schairer on cmucl-imp 2004-08-05 (defclass class-with-symbol-initarg () diff --git a/version.lisp-expr b/version.lisp-expr index 3a0b01e..60b0206 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.18.3" +"0.8.18.4"