;;;; 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")
\f
(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)))))))
+(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)
(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))))
(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))
(dolist (class classes)
(assert (typep (funcall f (if (oddp count) class (find-class class))) class))
(incf count))))
+
+;;; 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 :success1))
+
+(defmethod initialize-instance :around ((some-class some-class) &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-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 ((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 initialize-instance :around ((some-class some-class2) &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))))
\f
;;;; success