X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fctor.impure.lisp;h=f40e27b496257b8d9d1641b64fea2c8a220939a2;hb=d7875c296a4988e9f27e2776237884deb1984c62;hp=0fda4ebce40f89ce461bea3bebad3b90de4eba1a;hpb=386e90a63e7f9587f7c4d6b9206da72b16dc1361;p=sbcl.git

diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp
index 0fda4eb..f40e27b 100644
--- a/tests/ctor.impure.lisp
+++ b/tests/ctor.impure.lisp
@@ -12,9 +12,10 @@
 ;;;; more information.
 
 (load "test-util.lisp")
+(load "compiler-test-util.lisp")
 
 (defpackage "CTOR-TEST"
-  (:use "CL" "TEST-UTIL"))
+  (:use "CL" "TEST-UTIL" "COMPILER-TEST-UTIL"))
 
 (in-package "CTOR-TEST")
 
@@ -87,27 +88,10 @@
 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4))
 
 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
-(defun find-ctor-cache (f)
-  (let ((code (sb-kernel:fun-code-header f)))
-    (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
-          for c = (sb-kernel:code-header-ref code i)
-          do (when (= sb-vm::value-cell-header-widetag (sb-kernel:widetag-of c))
-               (let ((c (sb-vm::value-cell-ref c)))
-                 (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c)))
-                   (return c)))))))
-
-;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this
-;;; as well.
-(defun find-callee (f &key (type t) (name nil namep))
-  (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun f))))
-    (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
-          for c = (sb-kernel:code-header-ref code i)
-          do (when (typep c 'sb-impl::fdefn)
-               (let ((fun (sb-impl::fdefn-fun c)))
-                 (when (and (typep fun type)
-                            (or (not namep)
-                                (equal name (sb-impl::fdefn-name c))))
-                   (return fun)))))))
+(defun find-ctor-caches (fun)
+  (remove-if-not (lambda (value)
+                   (and (consp value) (eq 'sb-pcl::ctor-cache (car value))))
+                 (find-value-cell-values fun)))
 
 (let* ((cmacro (compiler-macro-function 'make-instance))
         (opt 0)
@@ -124,25 +108,25 @@
               (assert (= 0 opt))
               (let ((f (compile nil `(lambda (class)
                                        (make-instance class :b t)))))
-                (assert (find-ctor-cache f))
+                (assert (= 1 (length (find-ctor-caches f))))
                 (assert (= 1 opt))
                 (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass))))
             (with-test (:name (make-instance :constant-class-object))
               (let ((f (compile nil `(lambda ()
                                        (make-instance ,(find-class 'one-slot-subclass) :b t)))))
-                (assert (not (find-ctor-cache f)))
+                (assert (not (find-ctor-caches f)))
                 (assert (= 2 opt))
                 (assert (typep (funcall f) 'one-slot-subclass))))
             (with-test (:name (make-instance :constant-non-std-class-object))
               (let ((f (compile nil `(lambda ()
                                        (make-instance ,(find-class 'structure-object))))))
-                (assert (not (find-ctor-cache f)))
+                (assert (not (find-ctor-caches f)))
                 (assert (= 3 opt))
                 (assert (typep (funcall f) 'structure-object))))
             (with-test (:name (make-instance :constant-non-std-class-name))
               (let ((f (compile nil `(lambda ()
                                        (make-instance 'structure-object)))))
-                (assert (not (find-ctor-cache f)))
+                (assert (not (find-ctor-caches f)))
                 (assert (= 4 opt))
                 (assert (typep (funcall f) 'structure-object)))))
        (setf (compiler-macro-function 'make-instance) cmacro))))
@@ -152,8 +136,10 @@
          (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+)
                         collect (class-name (eval `(defclass ,(gentemp) () ())))))
          (count 0)
-         (cache (find-ctor-cache f)))
+         (caches (find-ctor-caches f))
+         (cache (pop caches)))
     (assert cache)
+    (assert (not caches))
     (assert (not (cdr cache)))
     (dolist (class classes)
       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
@@ -172,19 +158,148 @@
 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
 (defclass some-class ()
   ((aroundp :initform nil :reader aroundp))
-  (:default-initargs :x :success?))
-(defmethod initialize-instance :around ((some-class some-class) &key (x :fail?))
-  (unless (eq x :success?)
+  (:default-initargs :x :success1))
+
+(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)
   (when (next-method-p)
     (call-next-method)))
-(with-test (:name (make-instance :ctor-default-initargs))
+
+(with-test (:name (make-instance :ctor-default-initargs-1))
   (assert (aroundp (eval `(make-instance 'some-class))))
   (let ((fun (compile nil `(lambda () (make-instance 'some-class)))))
     (assert (aroundp (funcall fun)))
     ;; make sure we tested what we think we tested...
-    (let ((ctor (find-callee fun :type 'sb-pcl::ctor)))
-      (assert (find-callee ctor :name 'sb-pcl::fast-make-instance)))))
+    (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor)))
+      (assert ctors)
+      (assert (not (cdr ctors)))
+      (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
+
+;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
+;;; in more interesting cases as well...
+(defparameter *some-counter* 0)
+(let* ((x 'success2))
+  (defclass some-class2 ()
+    ((aroundp :initform nil :reader aroundp))
+    (:default-initargs :x (progn (incf *some-counter*) x))))
+
+(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)
+  (when (next-method-p)
+    (call-next-method)))
+
+(with-test (:name (make-instance :ctor-default-initargs-2))
+  (assert (= 0 *some-counter*))
+  (assert (aroundp (eval `(make-instance 'some-class2))))
+  (assert (= 1 *some-counter*))
+  (let ((fun (compile nil `(lambda () (make-instance 'some-class2)))))
+    (assert (= 1 *some-counter*))
+    (assert (aroundp (funcall fun)))
+    (assert (= 2 *some-counter*))
+    ;; make sure we tested what we think we tested...
+    (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor)))
+      (assert ctors)
+      (assert (not (cdr ctors)))
+      (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
+
+;;; No compiler notes, please
+(locally (declare (optimize safety))
+  (defclass type-check-thing ()
+    ((slot :type (integer 0) :initarg :slot))))
+(with-test (:name (make-instance :no-compile-note-at-runtime))
+  (let ((fun (compile nil `(lambda (x)
+                             (declare (optimize safety))
+                             (make-instance 'type-check-thing :slot x)))))
+    (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