X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fctor.impure.lisp;h=f40e27b496257b8d9d1641b64fea2c8a220939a2;hb=587c903b0601dfd6763b5acc05778f793172c915;hp=08a41c660c15d743037aa7174b08eaf7b961bdf7;hpb=f09f67b4233004079affc70de2ef2d49f27ca91a;p=sbcl.git

diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp
index 08a41c6..f40e27b 100644
--- a/tests/ctor.impure.lisp
+++ b/tests/ctor.impure.lisp
@@ -160,7 +160,7 @@
   ((aroundp :initform nil :reader aroundp))
   (:default-initargs :x :success1))
 
-(defmethod initialize-instance :around ((some-class some-class) &key (x :fail?))
+(defmethod shared-initialize :around ((some-class some-class) slots &key (x :fail?))
   (unless (eq x :success1)
     (error "Default initarg lossage"))
   (setf (slot-value some-class 'aroundp) t)
@@ -185,7 +185,7 @@
     ((aroundp :initform nil :reader aroundp))
     (:default-initargs :x (progn (incf *some-counter*) x))))
 
-(defmethod initialize-instance :around ((some-class some-class2) &key (x :fail2?))
+(defmethod shared-initialize :around ((some-class some-class2) slots &key (x :fail2?))
   (unless (eq x 'success2)
     (error "Default initarg lossage"))
   (setf (slot-value some-class 'aroundp) t)
@@ -217,5 +217,89 @@
     (handler-bind ((sb-ext:compiler-note #'error))
       (funcall fun 41)
       (funcall fun 13))))
+
+;;; NO-APPLICABLE-METHOD called
+(defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args)
+  (cons :no-applicable-method args))
+(with-test (:name :constant-invalid-class-arg)
+  (assert (equal
+           '(:no-applicable-method "FOO" :quux 14)
+           (funcall (compile nil `(lambda (x) (make-instance "FOO" :quux x))) 14)))
+  (assert (equal
+           '(:no-applicable-method 'abc zot 1 bar 2)
+           (funcall (compile nil `(lambda (x y) (make-instance ''abc 'zot x 'bar y)))
+                    1 2))))
+(with-test (:name :variable-invalid-class-arg)
+  (assert (equal
+           '(:no-applicable-method "FOO" :quux 14)
+           (funcall (compile nil `(lambda (c x) (make-instance c :quux x))) "FOO" 14)))
+  (assert (equal
+           '(:no-applicable-method 'abc zot 1 bar 2)
+           (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y)))
+                    ''abc 1 2))))
+
+(defclass sneaky-class (standard-class)
+  ())
+
+(defmethod sb-mop:validate-superclass ((class sneaky-class) (super standard-class))
+  t)
+
+(defclass sneaky ()
+  ((dirty :initform nil :accessor dirty-slots)
+   (a :initarg :a :reader sneaky-a)
+   (b :initform "b" :reader sneaky-b)
+   (c :accessor sneaky-c))
+  (:metaclass sneaky-class))
+
+(defvar *supervising* nil)
+
+(defmethod (setf sb-mop:slot-value-using-class)
+    :before (value (class sneaky-class) (instance sneaky) slotd)
+  (unless *supervising*
+    (let ((name (sb-mop:slot-definition-name slotd))
+          (*supervising* t))
+      (when (slot-boundp instance 'dirty)
+        (pushnew name (dirty-slots instance))))))
+
+(with-test (:name (make-instance :setf-slot-value-using-class-hits-other-slots))
+  (let ((fun (compile nil `(lambda (a c)
+                             (let ((i (make-instance 'sneaky :a a)))
+                               (setf (sneaky-c i) c)
+                               i)))))
+    (loop repeat 3
+          do (let ((i (funcall fun "a" "c")))
+               (assert (equal '(c b a) (dirty-slots i)))
+               (assert (equal "a" (sneaky-a i)))
+               (assert (equal "b" (sneaky-b i)))
+               (assert (equal "c" (sneaky-c i)))))))
+
+(defclass bug-728650-base ()
+  ((value
+    :initarg :value
+    :initform nil)))
+
+(defmethod initialize-instance :after ((instance bug-728650-base) &key)
+  (with-slots (value) instance
+    (unless value
+      (error "Impossible! Value slot not initialized in ~S" instance))))
+
+(defclass bug-728650-child-1 (bug-728650-base)
+  ())
+
+(defmethod initialize-instance :around ((instance bug-728650-child-1) &rest initargs &key)
+  (apply #'call-next-method instance :value 'provided-by-child-1 initargs))
+
+(defclass bug-728650-child-2 (bug-728650-base)
+  ())
+
+(defmethod initialize-instance :around ((instance bug-728650-child-2) &rest initargs &key)
+  (let ((foo (make-instance 'bug-728650-child-1)))
+    (apply #'call-next-method instance :value foo initargs)))
+
+(with-test (:name :bug-728650)
+  (let ((child1 (slot-value (make-instance 'bug-728650-child-2) 'value)))
+    (assert (typep child1 'bug-728650-child-1))
+    (assert (eq 'provided-by-child-1 (slot-value child1 'value)))))
+
 
 ;;;; success