X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.pure.lisp;h=31a7edd8546661dd9cbe670ece411a77c6a4ae57;hb=d7875c296a4988e9f27e2776237884deb1984c62;hp=f472f249ab05f94f109b882670cd49d368b15642;hpb=669eaea6857ab6211bfd6c00c7d227f3263200b9;p=sbcl.git

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index f472f24..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,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,104 +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
-			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))))
@@ -142,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=)))
@@ -176,20 +176,20 @@
 (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))))
@@ -218,12 +218,254 @@
 (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)))
+                (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)))))