X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=593e45e1bcf0783b35edee3de00a00f8fa351753;hb=aa8c8cd473f1d487fa2c1a7490c78a59b9955bbe;hp=557b327becb86480b1473ab76cb26bf81815e0bb;hpb=508bf17fa9e609c523a2795d84a3bc908db1b302;p=sbcl.git diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 557b327..593e45e 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -4,7 +4,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -14,18 +14,18 @@ (locally (declare (notinline mapcar)) (mapcar (lambda (args) - (destructuring-bind (obj type-spec result) args - (flet ((matches-result? (x) - (eq (if x t nil) result))) - (assert (matches-result? (typep obj type-spec))) - (assert (matches-result? (sb-kernel:ctypep - obj - (sb-kernel:specifier-type - type-spec))))))) - '((nil (or null vector) t) - (nil (or number vector) nil) - (12 (or null vector) nil) - (12 (and (or number vector) real) t)))) + (destructuring-bind (obj type-spec result) args + (flet ((matches-result? (x) + (eq (if x t nil) result))) + (assert (matches-result? (typep obj type-spec))) + (assert (matches-result? (sb-kernel:ctypep + obj + (sb-kernel:specifier-type + type-spec))))))) + '((nil (or null vector) t) + (nil (or number vector) nil) + (12 (or null vector) nil) + (12 (and (or number vector) real) t)))) ;;; This test is motivated by bug #195, which previously had (THE REAL @@ -36,113 +36,104 @@ ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can ;;; unparse to NIL, since there are no EXTENDED-CHARs currently). (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the - ;; CLHS. - arithmetic-error - function - simple-condition - array - generic-function - simple-error - ;; so it might seem easy to change the HAIRY - ;; :UNPARSE method to recognize that (NOT - ;; CONS) should unparse as ATOM. However, we - ;; then lose the nice (SUBTYPEP '(NOT ATOM) - ;; 'CONS) => T,T behaviour that we get from - ;; simplifying (NOT ATOM) -> (NOT (NOT CONS)) - ;; -> CONS. So, for now, we leave this - ;; commented out. - ;; - ;; atom - hash-table - simple-string - base-char - integer - simple-type-error - base-string - keyword - simple-vector - bignum - list - simple-warning - bit - logical-pathname - single-float - bit-vector - long-float - standard-char - broadcast-stream - method - standard-class - built-in-class - method-combination - standard-generic-function - cell-error - nil - standard-method - character - null - standard-object - class - number - storage-condition - compiled-function - package - stream - complex - package-error - stream-error - concatenated-stream - parse-error - string - condition - pathname - string-stream - cons - print-not-readable - structure-class - control-error - program-error - structure-object - division-by-zero - random-state - style-warning - double-float - ratio - symbol - echo-stream - rational - synonym-stream - end-of-file - reader-error - t - error - readtable - two-way-stream - extended-char - real - type-error - file-error - restart - unbound-slot - file-stream - sequence - unbound-variable - fixnum - serious-condition - undefined-function - float - short-float - unsigned-byte - floating-point-inexact - signed-byte - vector - floating-point-invalid-operation - simple-array - warning - floating-point-overflow - simple-base-string - floating-point-underflow - simple-bit-vector))) + ;; CLHS. + arithmetic-error + function + simple-condition + array + generic-function + simple-error + atom + hash-table + simple-string + base-char + integer + simple-type-error + base-string + keyword + simple-vector + bignum + list + simple-warning + bit + logical-pathname + single-float + bit-vector + long-float + standard-char + broadcast-stream + method + standard-class + built-in-class + method-combination + standard-generic-function + cell-error + nil + standard-method + character + null + standard-object + class + number + storage-condition + compiled-function + package + stream + complex + package-error + stream-error + concatenated-stream + parse-error + string + condition + pathname + string-stream + cons + print-not-readable + structure-class + control-error + program-error + structure-object + division-by-zero + random-state + style-warning + double-float + ratio + symbol + echo-stream + rational + synonym-stream + end-of-file + reader-error + t + error + readtable + two-way-stream + extended-char + real + type-error + file-error + restart + unbound-slot + file-stream + sequence + unbound-variable + fixnum + serious-condition + undefined-function + float + short-float + unsigned-byte + floating-point-inexact + signed-byte + vector + floating-point-invalid-operation + simple-array + warning + floating-point-overflow + simple-base-string + floating-point-underflow + simple-bit-vector))) (dolist (type standard-types) (format t "~&~S~%" type) (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type)))) @@ -151,7 +142,7 @@ ;;; a bug underlying the reported bug #221: The SB-KERNEL type code ;;; signalled an error on this expression. (subtypep '(function (fixnum) (values package boolean)) - '(function (t) (values package boolean))) + '(function (t) (values package boolean))) ;;; bug reported by Valtteri Vuorik (compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=))) @@ -169,7 +160,6 @@ (subtypep '(function) '(function (t &rest t)))) '(nil t))) -#+nil (assert (and (subtypep 'function '(function)) (subtypep '(function) 'function))) @@ -186,20 +176,160 @@ (assert (subtypep t '(or real (not real)))) (assert (subtypep t '(or keyword (not keyword)))) (assert (subtypep '(and cons (not (cons symbol integer))) - '(or (cons (not symbol) *) (cons * (not integer))))) + '(or (cons (not symbol) *) (cons * (not integer))))) (assert (subtypep '(or (cons (not symbol) *) (cons * (not integer))) - '(and cons (not (cons symbol integer))))) + '(and cons (not (cons symbol integer))))) (assert (subtypep '(or (eql 0) (rational (0) 10)) - '(rational 0 10))) + '(rational 0 10))) (assert (subtypep '(rational 0 10) - '(or (eql 0) (rational (0) 10)))) + '(or (eql 0) (rational (0) 10)))) ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the ;;; same type gave exceedingly wrong results (assert (null (subtypep '(or (cons fixnum single-float) - (cons bignum single-float)) - '(cons single-float single-float)))) + (cons bignum single-float)) + '(cons single-float single-float)))) (assert (subtypep '(cons integer single-float) - '(or (cons fixnum single-float) (cons bignum single-float)))) + '(or (cons fixnum single-float) (cons bignum single-float)))) (assert (not (nth-value 1 (subtypep '(and null some-unknown-type) 'another-unknown-type)))) + +;;; bug 46c +(dolist (fun '(and if)) + (assert (raises-error? (coerce fun 'function) type-error))) + +(dotimes (i 100) + (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i))))) + (eval `(typep ,x (class-of ,x))))) + +(assert (not (typep #c(1 2) '(member #c(2 1))))) +(assert (typep #c(1 2) '(member #c(1 2)))) +(assert (subtypep 'nil '(complex nil))) +(assert (subtypep '(complex nil) 'nil)) +(assert (subtypep 'nil '(complex (eql 0)))) +(assert (subtypep '(complex (eql 0)) 'nil)) +(assert (subtypep 'nil '(complex (integer 0 0)))) +(assert (subtypep '(complex (integer 0 0)) 'nil)) +(assert (subtypep 'nil '(complex (rational 0 0)))) +(assert (subtypep '(complex (rational 0 0)) 'nil)) +(assert (subtypep 'complex '(complex real))) +(assert (subtypep '(complex real) 'complex)) +(assert (subtypep '(complex (eql 1)) '(complex (member 1 2)))) +(assert (subtypep '(complex ratio) '(complex rational))) +(assert (subtypep '(complex ratio) 'complex)) +(assert (equal (multiple-value-list + (subtypep '(complex (integer 1 2)) + '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2)))) + '(nil t))) + +(assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000)))) +(assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000)) + '(real #.(ash -1 10000) #.(ash 1 10000)))) +(assert (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000))) + '(real #.(ash -1 1000) #.(ash 1 1000)))) + +;;; Bug, found by Paul F. Dietz +(let* ((x (eval #c(-1 1/2))) + (type (type-of x))) + (assert (subtypep type '(complex rational))) + (assert (typep x type))) + +;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments. +;;; +;;; Fear the Loop of Doom! +(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) + (find-package :sb-c)))) + (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))))))))))))) + +;;; 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 +;;; disguise. +(multiple-value-bind (yes win) + (subtypep '(and function stream) 'nil) + (multiple-value-bind (cyes cwin) + (subtypep '(cons (and function stream) t) + '(cons nil t)) + (assert (eq yes cyes)) + (assert (eq win cwin)))) + +;;; CONS type subtypep could be too enthusiastic about thinking it was +;;; certain +(multiple-value-bind (yes win) + (subtypep '(satisfies foo) '(satisfies bar)) + (assert (null yes)) + (assert (null win)) + (multiple-value-bind (cyes cwin) + (subtypep '(cons (satisfies foo) t) + '(cons (satisfies bar) t)) + (assert (null cyes)) + (assert (null cwin)))) + +(multiple-value-bind (yes win) + (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. +(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 (typep #p"" 'sb-kernel:instance)) +(assert (subtypep '(member #p"") 'sb-kernel:instance))