From bcf4dc377026dc5b6f6128f0f73e10a391f319ff Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sun, 15 Oct 2017 13:38:17 +0200 Subject: [PATCH] tests: CHECKED-COMPILE[-AND-ASSERT] in {clos[-1],ctor}.[im]pure.lisp --- tests/clos-1.impure.lisp | 50 ++++++++++-------------- tests/clos.impure.lisp | 99 ++++++++++++++++++++++-------------------------- tests/clos.pure.lisp | 17 ++++----- tests/ctor.impure.lisp | 64 +++++++++++++++---------------- 4 files changed, 106 insertions(+), 124 deletions(-) diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp index f3e9d3385..a6322a761 100644 --- a/tests/clos-1.impure.lisp +++ b/tests/clos-1.impure.lisp @@ -32,7 +32,7 @@ (defmethod c-of ((x foo)) (slot-value x 'c)) -(let ((fun (compile nil '(lambda (x) (slot-value x 'a))))) +(let ((fun (checked-compile '(lambda (x) (slot-value x 'a))))) (dotimes (i 4) ; KLUDGE: get caches warm (assert (= 1 (slot-value *foo* 'a))) (assert (= 1 (a-of *foo*))) @@ -43,7 +43,7 @@ (defclass foo () ((b :initarg :b :initform 3) (a :initarg :a))) -(let ((fun (compile nil '(lambda (x) (slot-value x 'a))))) +(let ((fun (checked-compile '(lambda (x) (slot-value x 'a))))) (dotimes (i 4) ; KLUDGE: get caches warm (assert (= 1 (slot-value *foo* 'a))) (assert (= 1 (a-of *foo*))) @@ -56,7 +56,7 @@ (b :initarg :b :initform 3) (a :initarg :a))) -(let ((fun (compile nil '(lambda (x) (slot-value x 'a))))) +(let ((fun (checked-compile '(lambda (x) (slot-value x 'a))))) (dotimes (i 4) ; KLUDGE: get caches warm (assert (= 1 (slot-value *foo* 'a))) (assert (= 1 (a-of *foo*))) @@ -69,7 +69,7 @@ (b :initarg :b :initform 3) (c :initarg :c :initform t))) -(let ((fun (compile nil '(lambda (x) (slot-value x 'a))))) +(let ((fun (checked-compile '(lambda (x) (slot-value x 'a))))) (dotimes (i 4) ; KLUDGE: get caches warm (assert (= 1 (slot-value *foo* 'a))) (assert (= 1 (a-of *foo*))) @@ -80,7 +80,7 @@ (defclass foo () ((b :initarg :b :initform 3))) -(let ((fun (compile nil '(lambda (x) (slot-value x 'a))))) +(let ((fun (checked-compile '(lambda (x) (slot-value x 'a))))) (dotimes (i 4) ; KLUDGE: get caches warm (assert-error (slot-value *foo* 'a)) (assert-error (a-of *foo*)) @@ -125,26 +125,21 @@ ;;; Tests the compiler's incremental rejiggering of GF types. (fmakunbound 'foo) (with-test (:name :keywords-supplied-in-methods-ok-1) - (assert - (null - (nth-value - 1 - (progn - (defgeneric foo (x &key)) - (defmethod foo ((x integer) &key bar) (list x bar)) - (compile nil '(lambda () (foo (read) :bar 10)))))))) + (defgeneric foo (x &key)) + (defmethod foo ((x integer) &key bar) (list x bar)) + (checked-compile '(lambda () (foo (read) :bar 10)))) (fmakunbound 'foo) (with-test (:name :keywords-supplied-in-methods-ok-2) - (assert - (nth-value - 1 - (progn - (defgeneric foo (x &key)) - (defmethod foo ((x integer) &key bar) (list x bar)) - ;; On second thought... - (remove-method #'foo (find-method #'foo () '(integer))) - (compile nil '(lambda () (foo (read) :bar 10))))))) + (defgeneric foo (x &key)) + (defmethod foo ((x integer) &key bar) (list x bar)) + ;; On second thought... + (remove-method #'foo (find-method #'foo () '(integer))) + (multiple-value-bind (fun failure-p warnings style-warnings) + (checked-compile '(lambda () (foo (read) :bar 10)) + :allow-style-warnings t) + (declare (ignore fun failure-p warnings)) + (assert (= (length style-warnings) 1)))) ;; If the GF has &REST with no &KEY, not all methods are required to ;; parse the tail of the arglist as keywords, so we don't treat the @@ -154,8 +149,7 @@ (defgeneric foo (x &rest y)) (defmethod foo ((i integer) &key w) (list i w)) ;; 1.0.20.30 failed here. - (assert - (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15)))))) + (checked-compile '(lambda () (foo 5 :w 10 :foo 15))) (assert (not (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo))))) @@ -173,10 +167,8 @@ (sb-kernel:fun-type-keywords (sb-int:proclaimed-ftype 'foo))) '(:y :z))) - (assert - (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15)))))) - (assert - (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15)))))) + (checked-compile '(lambda () (foo 5 :z 10 :y 15))) + (checked-compile '(lambda () (foo 5 :z 10 :foo 15))) (assert (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo))) (assert @@ -188,7 +180,7 @@ (with-test (:name :method-allow-other-keys) (defgeneric foo (x &key)) (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y)) - (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20)))))) + (checked-compile '(lambda () (foo 10 :foo 20))) (assert (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo))) (assert (sb-kernel::args-type-allowp (sb-int:proclaimed-ftype 'foo)))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index baee3540b..232cb0b83 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1133,7 +1133,7 @@ finally (eval `(defclass ,class-name () (,@slot-descs) (:default-initargs ,@default-initargs)))) - (let ((f (compile nil `(lambda () (make-instance ',class-name))))) + (let ((f (checked-compile `(lambda () (make-instance ',class-name))))) (assert (typep (funcall f) class-name)))) ;;; bug 262: DEFMETHOD failed on a generic function without a lambda @@ -1145,20 +1145,19 @@ ;;; salex on #lisp 2003-10-13 reported that type declarations inside ;;; WITH-SLOTS are too hairy to be checked -(defun ensure-no-notes (form) - (handler-case (compile nil `(lambda () ,form)) - (sb-ext:compiler-note (c) - ;; FIXME: it would be better to check specifically for the "type - ;; is too hairy" note - (error c)))) (defvar *x*) -(ensure-no-notes '(with-slots (a) *x* - (declare (integer a)) - a)) -(ensure-no-notes '(with-slots (a) *x* - (declare (integer a)) - (declare (notinline slot-value)) - a)) +(with-test (:name (with-slots declare :note :hairy)) + (flet ((ensure-no-notes (form) + ;; FIXME: it would be better to check specifically for the "type + ;; is too hairy" note + (checked-compile `(lambda () ,form) :allow-notes nil))) + (ensure-no-notes '(with-slots (a) *x* + (declare (integer a)) + a)) + (ensure-no-notes '(with-slots (a) *x* + (declare (integer a)) + (declare (notinline slot-value)) + a)))) ;;; from CLHS 7.6.5.1 (defclass character-class () ((char :initarg :char))) @@ -1347,20 +1346,17 @@ ;;; Bug reported by Zach Beane; incorrect return of (function ;;; ',fun-name) in defgeneric -(assert - (typep (funcall (compile nil - '(lambda () (flet ((nonsense () nil)) - (declare (ignorable #'nonsense)) - (defgeneric nonsense ()))))) - 'generic-function)) - -(assert - (typep (funcall (compile nil - '(lambda () (flet ((nonsense-2 () nil)) - (declare (ignorable #'nonsense-2)) - (defgeneric nonsense-2 () - (:method () t)))))) - 'generic-function)) +(with-test (:name (defgeneric :return type)) + (flet ((test (form) + (let ((fun (checked-compile form))) + (assert (typep (funcall fun) 'generic-function))))) + (test '(lambda () (flet ((nonsense () nil)) + (declare (ignorable #'nonsense)) + (defgeneric nonsense ())))) + (test '(lambda () (flet ((nonsense-2 () nil)) + (declare (ignorable #'nonsense-2)) + (defgeneric nonsense-2 () + (:method () t))))))) ;;; bug reported by Bruno Haible: (setf find-class) using a ;;; forward-referenced class @@ -1655,9 +1651,9 @@ (eval `(defmethod class-as-specializer-test1 ((x ,(find-class 'class-as-specializer-test))) 'foo)) (assert (eq 'foo (class-as-specializer-test1 (make-instance 'class-as-specializer-test)))) -(funcall (compile nil `(lambda () - (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test))) - 'bar)))) +(funcall (checked-compile `(lambda () + (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test))) + 'bar)))) (assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test)))) ;;; CHANGE-CLASS and tricky allocation. @@ -2388,7 +2384,9 @@ ;; Now compile a lambda containing MAKE-INSTANCE to exercise the ;; fallback constructor generator. Call the resulting compiled ;; function to trigger the bug. - (funcall (compile nil '(lambda () (make-instance 'bug-1179858 :foo t))))) + (checked-compile-and-assert () + '(lambda () (make-instance 'bug-1179858 :foo t)) + (() nil :test (constantly t)))) ;;; Other brokenness, found while investigating: fallback-generator ;;; handling of non-keyword initialization arguments @@ -2401,9 +2399,9 @@ (with-test (:name (make-instance :fallback-generator-non-keyword-initarg :bug-1179858)) (flet ((foo= (n i) (= (bug-1179858b-foo i) n))) (assert - (foo= 14 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b)))))) + (foo= 14 (funcall (checked-compile '(lambda () (make-instance 'bug-1179858b)))))) (assert - (foo= 15 (funcall (compile nil '(lambda () (make-instance 'bug-1179858b 'foo 15)))))))) + (foo= 15 (funcall (checked-compile '(lambda () (make-instance 'bug-1179858b 'foo 15)))))))) (with-test (:name (:cpl-violation-setup :bug-309076)) (assert-error @@ -2424,17 +2422,13 @@ (defmacro macro () (let ((a 20)) (declare (special a)) - (assert - (= - (funcall - (compile nil - (sb-mop:make-method-lambda - #'b - (find-method #'b () ()) - '(lambda () (declare (special a)) a) - nil)) - '(1) ()) - 20)))) + (checked-compile-and-assert () + (sb-mop:make-method-lambda + #'b + (find-method #'b () ()) + '(lambda () (declare (special a)) a) + nil) + (('(1) ()) 20)))) (with-test (:name :make-method-lambda-leakage) ;; lambda list of X leaks into the invocation of make-method-lambda @@ -2562,10 +2556,9 @@ (with-test (:name (allocate-instance :on symbol)) (let ((class (gensym "CLASS-"))) (eval `(defclass ,class () ())) - (assert-error - (funcall (checked-compile `(lambda () - (allocate-instance ',class)))) - sb-pcl::no-applicable-method-error))) + (checked-compile-and-assert () + `(lambda () (allocate-instance ',class)) + (() (condition sb-pcl::no-applicable-method-error))))) (defclass unbound-slot-after-allocation=class () ((abc :allocation :class) @@ -2584,7 +2577,7 @@ (declare (ignore condition)) (error "Timeout")))) (sb-ext:with-timeout 0.1 - (assert-error (funcall (checked-compile `(lambda () - (defmethod foo ((bar keyword)))) - :allow-warnings t)) - sb-pcl:class-not-found-error)))) + (checked-compile-and-assert (:allow-warnings t) + `(lambda () + (defmethod foo ((bar keyword)))) + (() (condition sb-pcl:class-not-found-error)))))) diff --git a/tests/clos.pure.lisp b/tests/clos.pure.lisp index 25cc42117..0042e22a4 100644 --- a/tests/clos.pure.lisp +++ b/tests/clos.pure.lisp @@ -77,12 +77,10 @@ (assert (null result))))) ;; No compiler-notes for non-constant slot-names in default policy. -(handler-case - (compile nil '(lambda (x y z) - (setf (slot-value x z) - (slot-value y z)))) - (sb-ext:compiler-note (e) - (error e))) +(with-test (:name (slot-value :no sb-ext:compiler-note)) + (checked-compile '(lambda (x y z) + (setf (slot-value x z) (slot-value y z))) + :allow-notes nil)) (with-test (:name :slot-table-of-symbol-works) (assert (eq :win @@ -102,6 +100,7 @@ 42))) (with-test (:name (typep :literal-class)) - (assert (funcall (checked-compile `(lambda (x) - (typep x #.(find-class 'symbol)))) - 'x))) + (checked-compile-and-assert () + `(lambda (x) + (typep x #.(find-class 'symbol))) + (('x) t))) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index 1a326bfeb..b73102c32 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -123,33 +123,33 @@ (setf (sb-int:info :function :source-transform 'make-instance) wrapper) (with-test (:name (make-instance :non-constant-class)) (assert (= 0 opt)) - (let ((f (compile nil `(lambda (class) - (make-instance class :b t))))) + (let ((f (checked-compile `(lambda (class) + (make-instance class :b t))))) (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))))) + (let ((f (checked-compile `(lambda () + (make-instance ,(find-class 'one-slot-subclass) :b t))))) (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)))))) + (let ((f (checked-compile `(lambda () + (make-instance ,(find-class 'structure-object)))))) (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))))) + (let ((f (checked-compile `(lambda () + (make-instance 'structure-object))))) (assert (not (find-ctor-caches f))) (assert (= 4 opt)) (assert (typep (funcall f) 'structure-object))))) (setf (sb-int:info :function :source-transform 'make-instance) transform)))) (with-test (:name (make-instance :ctor-inline-cache-resize)) - (let* ((f (compile nil `(lambda (name) (make-instance name)))) + (let* ((f (checked-compile `(lambda (name) (make-instance name)))) (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+) collect (class-name (eval `(defclass ,(gentemp) () ()))))) (count 0) @@ -186,7 +186,7 @@ (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))))) + (let ((fun (checked-compile `(lambda () (make-instance 'some-class))))) (assert (aroundp (funcall fun))) ;; make sure we tested what we think we tested... (let ((ctors (find-anonymous-callees fun :type 'sb-pcl::ctor))) @@ -213,7 +213,7 @@ (assert (= 0 *some-counter*)) (assert (aroundp (eval `(make-instance 'some-class2)))) (assert (= 1 *some-counter*)) - (let ((fun (compile nil `(lambda () (make-instance 'some-class2))))) + (let ((fun (checked-compile `(lambda () (make-instance 'some-class2))))) (assert (= 1 *some-counter*)) (assert (aroundp (funcall fun))) (assert (= 2 *some-counter*)) @@ -228,9 +228,9 @@ (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))))) + (let ((fun (checked-compile `(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)))) @@ -239,21 +239,20 @@ (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)))) + (checked-compile-and-assert () + `(lambda (x) (make-instance "FOO" :quux x)) + ((14) '(:no-applicable-method "FOO" :quux 14))) + (checked-compile-and-assert () + `(lambda (x y) (make-instance ''abc 'zot x 'bar y)) + ((1 2) '(:no-applicable-method 'abc zot 1 bar 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)))) + (checked-compile-and-assert () + `(lambda (c x) (make-instance c :quux x)) + (("FOO" 14) '(:no-applicable-method "FOO" :quux 14))) + (checked-compile-and-assert () + `(lambda (c x y) (make-instance c 'zot x 'bar y)) + ((''abc 1 2) '(:no-applicable-method 'abc zot 1 bar 2)))) (defclass sneaky-class (standard-class) ()) @@ -279,10 +278,10 @@ (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))))) + (let ((fun (checked-compile `(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))) @@ -398,4 +397,3 @@ (destructuring-bind (f-6-e-c f-6-e-1 f-6-e-2) (mapcar #'make `(,constant-name-2 1 2)) (check f-6-e-c 1 f-6-e-1 1 f-6-e-2 2)))))) - -- 2.11.4.GIT