X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fctor.impure.lisp;h=12c1f896b0b1384db798a0b692df0082d115aa18;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=0fda4ebce40f89ce461bea3bebad3b90de4eba1a;hpb=386e90a63e7f9587f7c4d6b9206da72b16dc1361;p=sbcl.git diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index 0fda4eb..12c1f89 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,84 @@ ;;; 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?)) + (:default-initargs :x :success1)) + (defmethod initialize-instance :around ((some-class some-class) &key (x :fail?)) - (unless (eq x :success?) + (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 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)))) + +;;; 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)))) ;;;; success