From 157e71ec49058247ee490f654072c04231c99486 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 1 Jun 2005 13:19:36 +0000 Subject: [PATCH] 0.9.1.14: Fix the canonicalized default initarg protocol ... (KEY FORM FUN) rather than (KEY FUN FORM). I hope this isn't too painful for anyone out there. --- NEWS | 4 ++++ src/pcl/ctor.lisp | 4 ++-- src/pcl/defclass.lisp | 2 +- src/pcl/init.lisp | 4 ++-- tests/mop.impure.lisp | 23 +++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 33 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index 6cdd681..8754595 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: + * minor incompatible change: we now correctly canonize default + initargs, making them be a list of (INITARG INITFORM INITFUNCTION) + as per the MOP, rather than the historical (INITARG INITFUNCTION + INITFORM). (reported by Bruno Haible) * SB-SPROF now works (more) reliably on non-GENCGC platforms. * fixed some lockups due to gc/thread interaction * dynamic space size on PPC has been increased to 768Mb. (thanks to diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 3a08689..3bb6af4 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -93,7 +93,7 @@ ;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just ;;; collecting the defaulted initargs for the call. (defun ctor-default-initkeys (supplied-initargs class-default-initargs) - (loop for (key nil) in class-default-initargs + (loop for (key) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) collect key)) @@ -516,7 +516,7 @@ ;; initargs are treated as if they were appended to supplied ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. - (loop for (key initfn initform) in default-initargs and i from 0 + (loop for (key initform initfn) in default-initargs and i from 0 unless (member key initkeys :test #'eq) do (let* ((type (if (constantp initform) 'constant 'var)) (init (if (eq type 'var) initfn initform))) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index cf7562a..e4277f9 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -148,7 +148,7 @@ DEFCLASS ~S.~:>" :format-arguments (list key class-name))) (push key arg-names) - (push ``(,',key ,,(make-initfunction val) ,',val) initargs)) + (push ``(,',key ,',val ,,(make-initfunction val)) initargs)) (setf default-initargs t) (push `(:direct-default-initargs (list ,@(nreverse initargs))) canonized-options))) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index a4f5e3a..40a922a 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -52,9 +52,9 @@ (defmethod default-initargs ((class slot-class) supplied-initargs class-default-initargs) - (loop for (key fn) in class-default-initargs + (loop for (key nil fun) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) - append (list key (funcall fn)) into default-initargs + append (list key (funcall fun)) into default-initargs finally (return (append supplied-initargs default-initargs)))) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index f58ff98..3b9aede 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -406,5 +406,28 @@ :direct-superclasses (list (find-class 'standard-object))) 'class)) +;;; COMPUTE-DEFAULT-INITARGS protocol mismatch reported by Bruno +;;; Haible +(defparameter *extra-initarg-value* 'extra) +(defclass custom-default-initargs-class (standard-class) + ()) +(defmethod compute-default-initargs ((class custom-default-initargs-class)) + (let ((original-default-initargs + (remove-duplicates + (reduce #'append + (mapcar #'class-direct-default-initargs + (class-precedence-list class))) + :key #'car + :from-end t))) + (cons (list ':extra '*extra-initarg-value* #'(lambda () *extra-initarg-value*)) + (remove ':extra original-default-initargs :key #'car)))) +(defmethod validate-superclass ((c1 custom-default-initargs-class) + (c2 standard-class)) + t) +(defclass extra-initarg () + ((slot :initarg :extra)) + (:metaclass custom-default-initargs-class)) +(assert (eq (slot-value (make-instance 'extra-initarg) 'slot) 'extra)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 0fde2a5..25c65ff 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.9.1.13" +"0.9.1.14" -- 1.7.10.4