From 7727c77c8b05dcbcf9f8878a26f94cc14ccd5218 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 31 Jan 2008 07:22:16 +0000 Subject: [PATCH] 1.0.14.7: quote non-keyword :default-initargs keys in SLOT-INIT-FORMS * Reported and diagnosed by Matt Marjanovic. --- NEWS | 3 +++ src/pcl/ctor.lisp | 20 ++++++++++---------- tests/clos.impure.lisp | 12 ++++++++++++ version.lisp-expr | 2 +- 4 files changed, 26 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index e3a7516..972c084 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,9 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14: * bug fix: SORT was not interrupt safe. * bug fix: XREF accounts for the last node of each basic-block as well. + * bug fix: MAKE-INSTANCE optimizations interacted badly with + non-keyword :DEFAULT-INITARGS in the presence of :BEFORE/:AFTER + methods on SHARED-INITIALIZE. (thanks to Matt Marjanovic) changes in sbcl-1.0.14 relative to sbcl-1.0.13: * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 712c0ef..0bd3973 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -531,16 +531,16 @@ ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. (loop for (key initform initfn) in default-initargs and i from 0 - unless (member key initkeys :test #'eq) do - (let* ((kind (if (constantp initform) 'constant 'var)) - (init (if (eq kind 'var) initfn initform))) - (ecase kind - (constant - (push key defaulting-initargs) - (push initform defaulting-initargs)) - (var - (push key defaulting-initargs) - (push (default-init-var-name i) defaulting-initargs))) + unless (member key initkeys :test #'eq) + do (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind + (constant + (push (list 'quote key) defaulting-initargs) + (push initform defaulting-initargs)) + (var + (push (list 'quote key) defaulting-initargs) + (push (default-init-var-name i) defaulting-initargs))) (when (eq kind 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 9dbd83f..174e328 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1607,5 +1607,17 @@ (declare (bug-402-d x)) x)))) +;;;; non-keyword :default-initargs + :before method on shared initialize +;;;; interacted badly with CTOR optimizations +(defclass ctor-default-initarg-problem () + ((slot :initarg slotto)) + (:default-initargs slotto 123)) +(defmethod shared-initialize :before ((instance ctor-default-initarg-problem) slot-names &rest initargs) + (format t "~&Rock on: ~A~%" initargs)) +(defun provoke-ctor-default-initarg-problem () + (make-instance 'ctor-default-initarg-problem)) +(handler-bind ((warning #'error)) + (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot)))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 0cacfe1..1f839d8 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.14.6" +"1.0.14.7" -- 1.7.10.4