X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=31a7edd8546661dd9cbe670ece411a77c6a4ae57;hb=062283b901155792f65775491aea51481c56faaa;hp=12af6999bf31de151a35ae744966f3534e3ed12a;hpb=b4dcc81361b084a1ed9e3212ae4abbb174720780;p=sbcl.git

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 12af699..31a7edd 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,15 +14,458 @@
 (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
+;;; #(1 2 3)) give an error which prints as "This is not a (OR
+;;; 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, 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
+                        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))))
+    (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
+
+;;; 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)))
+
+;;; 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!
+;;;
+;;; (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))
+(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
+                                  (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
+;;; 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
+ (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))))
+
+(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)))))