X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=6a0351a527fedf6e6543ba2347a2cd426ace33be;hb=4a96ec6005851c044a36028c051e8beae82a7155;hp=fcda6d6fe4a072c274e2889c50d1a27697cfe445;hpb=f3b213e5fea9992b3a9a1f2a6c482239a1aff3c1;p=sbcl.git diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index fcda6d6..6a0351a 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -33,7 +33,8 @@ ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)". We ideally want all of the ;;; defined-by-ANSI types to unparse as themselves or at least ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since -;;; the types are equivalent in current SBCL). +;;; 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 @@ -42,16 +43,7 @@ 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 + atom hash-table simple-string base-char @@ -117,17 +109,7 @@ error readtable two-way-stream - ;; This one's hard: (AND BASE-CHAR (NOT BASE-CHAR)) - ;; - ;; This is because it looks like - ;; (AND CHARACTER (NOT BASE-CHAR)) - ;; but CHARACTER is equivalent to - ;; BASE-CHAR. So if we fix intersection of - ;; obviously disjoint types and then do (the - ;; extended-char foo), we'll get back FOO is - ;; not a NIL. -- CSR, 2002-09-16. - ;; - ;; extended-char + extended-char real type-error file-error @@ -161,3 +143,126 @@ ;;; signalled an error on this expression. (subtypep '(function (fixnum) (values package boolean)) '(function (t) (values package boolean))) + +;;; bug reported by Valtteri Vuorik +(compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=))) +(assert (not (equal (multiple-value-list + (subtypep '(function ()) '(function (&rest t)))) + '(nil t)))) + +(assert (not (equal (multiple-value-list + (subtypep '(function (&rest t)) '(function ()))) + '(t t)))) + +(assert (subtypep '(function) + '(function (&optional * &rest t)))) +(assert (equal (multiple-value-list + (subtypep '(function) + '(function (t &rest t)))) + '(nil t))) +(assert (and (subtypep 'function '(function)) + (subtypep '(function) 'function))) + +;;; Absent any exciting generalizations of |R, the type RATIONAL is +;;; partitioned by RATIO and INTEGER. Ensure that the type system +;;; knows about this. [ the type system is permitted to return NIL, +;;; NIL for these, so if future maintenance breaks these tests that +;;; way, that's fine. What the SUBTYPEP calls are _not_ allowed to +;;; return is NIL, T, because that's completely wrong. ] +(assert (subtypep '(or integer ratio) 'rational)) +(assert (subtypep 'rational '(or integer ratio))) +;;; Likewise, these are allowed to return NIL, NIL, but shouldn't +;;; return NIL, T: +(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))))) +(assert (subtypep '(or (cons (not symbol) *) (cons * (not integer))) + '(and cons (not (cons symbol integer))))) +(assert (subtypep '(or (eql 0) (rational (0) 10)) + '(rational 0 10))) +(assert (subtypep '(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)))) +(assert (subtypep '(cons integer 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)))))))))))))