Fix problems with SHARED-INITIALIZE

(Olof-Joachim Frahm)

Merges <>.
parent 6a866834
......@@ -3694,12 +3694,12 @@ or T when any keyword is acceptable due to presence of
(multiple-value-bind (init-key init-value foundp)
(get-properties all-keys (slot-definition-initargs slot))
(if foundp
(setf (std-slot-value instance slot-name) init-value)
(unless (std-slot-boundp instance slot-name)
(setf (slot-value instance slot-name) init-value)
(unless (slot-boundp instance slot-name)
(let ((initfunction (slot-definition-initfunction slot)))
(when (and initfunction (or (eq slot-names t)
(memq slot-name slot-names)))
(setf (std-slot-value instance slot-name)
(setf (slot-value instance slot-name)
(funcall initfunction)))))))))
......@@ -80,3 +80,28 @@
(defun find-quux (&rest specializers)
(find-method #'mop-test.quux nil
(mapcar #'find-class specializers)))
(defclass foo-meta-class (standard-class)
(defclass foo-direct-slot-definition (mop:standard-direct-slot-definition)
(defclass foo-effective-slot-definition (mop:standard-effective-slot-definition)
(defmethod mop:direct-slot-definition-class ((class foo-meta-class) &rest initargs)
(find-class 'foo-direct-slot-definition))
(defmethod mop:effective-slot-definition ((class foo-meta-class) &rest initargs)
(find-class 'foo-effective-slot-definition))
(defmethod mop:compute-effective-slot-definition ((class foo-meta-class) name direct-slots)
(car direct-slots))
(defclass bar-class ()
((x :initform T))
(:metaclass foo-meta-class))
(defmethod mop:slot-boundp-using-class ((class foo-meta-class) object slot)
(error "foo"))
......@@ -302,4 +302,10 @@
#'mop-test.quux (find-classes 'fixnum 'simple-base-string)))
;; creating the instance should already call our meta class methods
(deftest shared-initialize.1
(block NIL
(handler-case (make-instance 'bar-class)
(error (error)
(return (equal (princ-to-string error) "foo")))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment