X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=07ad60d76917469590c8aa80eb9f8b8b3d034230;hb=055ce77ed25e387a4061653709fe1e03c193eb92;hp=05e7a30e4278de95834743b9178ed006d913cce3;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 05e7a30..07ad60d 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -237,6 +237,10 @@ ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments. ;;; ;;; Fear the Loop of Doom! +;;; +;;; (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) @@ -253,6 +257,7 @@ (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND" op minimize) (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 @@ -294,9 +299,91 @@ ACTUAL ~D DERIVED ~D~%" (subtypep 'generic-function 'function) (assert yes) (assert win)) -;; this would be in some internal test suite like type.before-xc.lisp -;; except that generic functions don't exist at that stage. +;;; this would be in some internal test suite like type.before-xc.lisp +;;; except that generic functions don't exist at that stage. (multiple-value-bind (yes win) (subtypep 'generic-function 'sb-kernel:funcallable-instance) (assert yes) (assert win)) + +;;; all sorts of answers are right for this one, but it used to +;;; trigger an AVER instead. +(subtypep '(function ()) '(and (function ()) (satisfies identity))) + +(assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type))) + +(assert + (sb-kernel:type= + (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*)) + (simple-array an-unkown-type))) + (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*)) + (simple-array an-unkown-type))))) + +(assert + (sb-kernel:type= + (sb-kernel:specifier-type '(simple-array an-unkown-type (*))) + (sb-kernel:specifier-type '(simple-array an-unkown-type (*))))) + +(assert + (not + (sb-kernel:type= + (sb-kernel:specifier-type '(simple-array an-unkown-type (*))) + (sb-kernel:specifier-type '(array an-unkown-type (*)))))) + +(assert + (not + (sb-kernel:type= + (sb-kernel:specifier-type '(simple-array an-unkown-type (7))) + (sb-kernel:specifier-type '(simple-array an-unkown-type (8)))))) + +(assert + (sb-kernel:type/= (sb-kernel:specifier-type 'cons) + (sb-kernel:specifier-type '(cons single-float single-float)))) + +(multiple-value-bind (match win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons integer)) + (sb-kernel:specifier-type '(cons))) + (assert (and (not match) win))) + +(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))))