;;; (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
(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)))))
projects / sbcl.git / blobdiff