X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=31a7edd8546661dd9cbe670ece411a77c6a4ae57;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=bac6d51169cce9ba6c4b8d85e4ce6b44c7645f52;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index bac6d51..31a7edd 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -241,35 +241,58 @@ ;;; (In fact, this is such a fearsome loop that executing it with the ;;; evaluator would take ages... Disable it under those circumstances.) #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or)) -(let* ((bits 5) - (size (ash 1 bits))) - (flet ((brute-force (a b c d op minimize) - (loop with extreme = (if minimize (ash 1 bits) 0) - with collector = (if minimize #'min #'max) - for i from a upto b do - (loop for j from c upto d do - (setf extreme (funcall collector - extreme - (funcall op i j)))) - finally (return extreme)))) - (dolist (op '(logand logior logxor)) - (dolist (minimize '(t nil)) - (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND" - op minimize) +(with-test (:name (:type-derivation :logical-operations :correctness)) + (let* ((n-bits 5) + (size (ash 1 n-bits))) + (labels ((brute-force (a b c d op) + (loop with min = (ash 1 n-bits) + with max = 0 + for i from a upto b do + (loop for j from c upto d do + (let ((x (funcall op i j))) + (setf min (min min x) + max (max max x)))) + finally (return (values min max)))) + (test (a b c d op deriver) + (multiple-value-bind (brute-low brute-high) + (brute-force a b c d op) + (multiple-value-bind (test-low test-high) + (funcall deriver + (sb-c::specifier-type `(integer ,a ,b)) + (sb-c::specifier-type `(integer ,c ,d))) + (unless (and (= brute-low test-low) + (= brute-high test-high)) + (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%" + op a b c d + brute-low brute-high test-low test-high) + (assert (and (= brute-low test-low) + (= brute-high test-high)))))))) + (dolist (op '(logand logior logxor)) + (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op) (find-package :sb-c)))) + (format t "testing type derivation: ~A~%" deriver) (loop for a from 0 below size do (loop for b from a below size do (loop for c from 0 below size do (loop for d from c below size do - (let* ((brute (brute-force a b c d op minimize)) - (x-type (sb-c::specifier-type `(integer ,a ,b))) - (y-type (sb-c::specifier-type `(integer ,c ,d))) - (derived (funcall deriver x-type y-type))) - (unless (= brute derived) - (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~% -ACTUAL ~D DERIVED ~D~%" - op a b c d minimize brute derived) - (assert (= brute derived))))))))))))) + (test a b c d op deriver)))))))))) + +(with-test (:name (:type-derivation :logical-operations :scaling)) + (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000) + ,(expt 2 10000)))) + (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000) + ,(expt 2 100000)))) + (type-y (sb-c::specifier-type '(integer 0 1)))) + (dolist (op '(logand logior logxor)) + (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op) + (find-package :sb-c))) + (scale (/ (runtime (funcall deriver type-x2 type-y)) + (runtime (funcall deriver type-x1 type-y))))) + ;; Linear scaling is good, quadratical bad. Draw the line + ;; near the geometric mean of the corresponding SCALEs. + (when (> scale 32) + (error "Bad scaling of ~a: input 10 times but runtime ~a times as large." + deriver scale)))))) ;;; subtypep on CONS types wasn't taking account of the fact that a ;;; CONS type could be the empty type (but no other non-CONS type) in @@ -346,3 +369,103 @@ ACTUAL ~D DERIVED ~D~%" (assert (typep #p"" 'sb-kernel:instance)) (assert (subtypep '(member #p"") 'sb-kernel:instance)) + +(with-test (:name (:typep :character-set :negation)) + (flet ((generate-chars () + (loop repeat 100 + collect (code-char (random char-code-limit))))) + (dotimes (i 1000) + (let* ((chars (generate-chars)) + (type `(member ,@chars)) + (not-type `(not ,type))) + (dolist (char chars) + (assert (typep char type)) + (assert (not (typep char not-type)))) + (let ((other-chars (generate-chars))) + (dolist (char other-chars) + (unless (member char chars) + (assert (not (typep char type))) + (assert (typep char not-type))))))))) + +(with-test (:name (:check-type :store-value :complex-place)) + (let ((a (cons 0.0 2)) + (handler-invoked nil)) + (handler-bind ((error + (lambda (c) + (declare (ignore c)) + (assert (not handler-invoked)) + (setf handler-invoked t) + (invoke-restart 'store-value 1)))) + (check-type (car a) integer)) + (assert (eql (car a) 1)))) + +;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing +;;; the first ASSERT below. The second ASSERT takes care that the fix +;;; doesn't overshoot the mark. +(with-test (:name (:typep :fixnum-if-unsigned-byte)) + (let ((f (compile nil + (lambda (x) + (declare (type (unsigned-byte #.sb-vm:n-word-bits) x)) + (typep x (quote fixnum)))))) + (assert (not (funcall f (1+ most-positive-fixnum)))) + (assert (funcall f most-positive-fixnum)))) + +(with-test (:name (:typep :member-uses-eql)) + (assert (eval '(typep 1/3 '(member 1/3 nil)))) + (assert (eval '(typep 1.0 '(member 1.0 t)))) + (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2))))) + (assert (eval '(typep #c(1 1) '(member #c(1 1))))) + (let ((bignum1 (+ 12 most-positive-fixnum)) + (bignum2 (- (+ 15 most-positive-fixnum) 3))) + (assert (eval `(typep ,bignum1 '(member ,bignum2)))))) + +(with-test (:name :opt+rest+key-canonicalization) + (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *))) + (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type)))))) + +(with-test (:name :bug-369) + (let ((types (mapcar #'sb-c::values-specifier-type + '((values (vector package) &optional) + (values (vector package) &rest t) + (values (vector hash-table) &rest t) + (values (vector hash-table) &optional) + (values t &optional) + (values t &rest t) + (values nil &optional) + (values nil &rest t) + (values sequence &optional) + (values sequence &rest t) + (values list &optional) + (values list &rest t))))) + (dolist (x types) + (dolist (y types) + (let ((i (sb-c::values-type-intersection x y))) + (assert (sb-c::type= i (sb-c::values-type-intersection i x))) + (assert (sb-c::type= i (sb-c::values-type-intersection i y)))))))) + +(with-test (:name :bug-485972) + (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t))) + (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t)))) + +;; WARNING: this test case would fail by recursing into the stack's guard page. +(with-test (:name :bug-883498) + (sb-kernel:specifier-type + `(or (INTEGER -2 -2) + (AND (SATISFIES FOO) (RATIONAL -3/2 -3/2))))) + +;; The infinite recursion mentioned in the previous test was caused by an +;; attempt to get the following right. +(with-test (:name :quirky-integer-rational-union) + (assert (subtypep `(or (integer * -1) + (and (rational * -1/2) (not integer))) + `(rational * -1/2))) + (assert (subtypep `(rational * -1/2) + `(or (integer * -1) + (and (rational * -1/2) (not integer)))))) + +;; for the longest time (at least 05525d3a), single-value-type would +;; return CHARACTER on this. +(with-test (:name :single-value-&optional-type) + (assert (sb-c::type= (sb-c::single-value-type + (sb-c::values-specifier-type '(values &optional character))) + (sb-c::specifier-type '(or null character)))))