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.

diff --git a/NEWS b/NEWS
index 6cdd681..8754595 100644 (file)
--- 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 (file)
--- 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))
 \f
@@ -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 (file)
--- 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 (file)
--- 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 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -406,5 +406,28 @@
          :direct-superclasses (list (find-class 'standard-object)))
         'class))
 \f
+;;; 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))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 0fde2a5..25c65ff 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".)
-"0.9.1.13"
+"0.9.1.14"