;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; 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.

(enable-test-parallelism)

(with-test (:name :make-eql-type)
  (assert (not (sb-kernel:member-type-p (sb-kernel:make-eql-type #\z))))
  (assert (not (sb-kernel:member-type-p (sb-kernel:make-eql-type 1.0))))
  (assert (eql (sb-kernel:numeric-type-low (sb-kernel:make-eql-type -0f0)) -0f0))
  (assert (eql (sb-kernel:numeric-type-high (sb-kernel:make-eql-type -0d0)) -0d0)))

(with-test (:name (typexpand-1 typexpand typexpand-all :check-lexenv))
  (flet ((try (f) (assert-error (funcall f 'hash-table 3))))
    (mapc #'try '(typexpand-1 typexpand typexpand-all))))

(with-test (:name :no-*-as-t) ; lp#1860919
  (assert-signal (sb-kernel:specifier-type '(function (*) t)) warning)
  (dolist (f '((lambda (x) (the * x))
               (lambda (x) (declare (* x)) x)
               (lambda (x) (declare (type * x)) x)))
    (multiple-value-bind (f warn err)
        (let ((*error-output* (make-broadcast-stream))) (compile nil f))
      (declare (ignore f))
      (assert (and warn err)))))

(with-test (:name (typep sb-kernel:ctypep))
  (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)))))


;;; 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).
(with-test (:name :standard-types)
  (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)
      #+nil (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.
(with-test (:name (subtypep function values :bug-221))
  (subtypep '(function (fixnum) (values package boolean))
            '(function (t) (values package boolean))))

;;; bug reported by Valtteri Vuorik
(with-test (:name (subtypep function &rest))
  (checked-compile '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
  (assert-tri-eq t   t (subtypep '(function ()) '(function (&rest t))))
  (assert-tri-eq nil t (subtypep '(function (&rest t)) '(function ())))
  (assert-tri-eq t   t (subtypep '(function)
                                 '(function (&optional t &rest t))))
  (assert-tri-eq nil t (subtypep '(function) '(function (t &rest t))))
  (assert-tri-eq t   t (subtypep 'function '(function)))
  (assert-tri-eq t   t (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. ]
(with-test (:name (subtypep integer ratio rational))
  (assert-tri-eq t t (subtypep '(or integer ratio) 'rational))
  (assert-tri-eq t t (subtypep 'rational '(or integer ratio))))

;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
;;; return NIL, T:
(with-test (:name (subtypep or and not))
  (assert-tri-eq t t (subtypep t '(or real (not real))))
  (assert-tri-eq t t (subtypep t '(or keyword (not keyword))))
  (assert-tri-eq t t (subtypep '(and cons (not (cons symbol integer)))
                               '(or (cons (not symbol) *) (cons * (not integer)))))
  (assert-tri-eq t t (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
                               '(and cons (not (cons symbol integer)))))
  (assert-tri-eq t t (subtypep '(or (eql 0) (rational (0) 10))
                               '(rational 0 10)))
  (assert-tri-eq t t (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
(with-test (:name (subtypep cons :same-cdr))
  (let ((a '(or (cons fixnum single-float) (cons bignum single-float)))
        (b '(cons single-float single-float))
        (c '(cons integer single-float)))
    (assert-tri-eq nil t (subtypep a b))
    (assert-tri-eq t   t (subtypep c a))))

(with-test (:name (subtypep :unknown-type))
  (checked-compile-and-assert (:allow-style-warnings t)
      '(lambda ()
         (subtypep '(and null some-unknown-type) 'another-unknown-type))
    (() (values nil nil) :allow-conditions 'sb-kernel:parse-unknown-type)))

;;; bug 46c
(with-test (:name (coerce function :on :macro))
  (dolist (fun '(and if))
    (assert-error (coerce fun 'function))))

(with-test (:name (typep array class-of))
  (dotimes (i 100)
    (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
      (eval `(typep ,x (class-of ,x))))))

(with-test (:name (typep complex member))
  (assert (not (typep #c(1 2) '(member #c(2 1)))))
  (assert (typep #c(1 2) '(member #c(1 2)))))

(with-test (:name (subtypep complex))
  (assert-tri-eq t   t (subtypep 'nil '(complex nil)))
  (assert-tri-eq t   t (subtypep '(complex nil) 'nil))
  (assert-tri-eq t   t (subtypep 'nil '(complex (eql 0))))
  (assert-tri-eq t   t (subtypep '(complex (eql 0)) 'nil))
  (assert-tri-eq t   t (subtypep 'nil '(complex (integer 0 0))))
  (assert-tri-eq t   t (subtypep '(complex (integer 0 0)) 'nil))
  (assert-tri-eq t   t (subtypep 'nil '(complex (rational 0 0))))
  (assert-tri-eq t   t (subtypep '(complex (rational 0 0)) 'nil))
  (assert-tri-eq t   t (subtypep 'complex '(complex real)))
  (assert-tri-eq t   t (subtypep '(complex real) 'complex))
  (assert-tri-eq t   t (subtypep '(complex (eql 1)) '(complex (member 1 2))))
  (assert-tri-eq t   t (subtypep '(complex ratio) '(complex rational)))
  (assert-tri-eq t   t (subtypep '(complex ratio) 'complex))
  (assert-tri-eq nil t (subtypep '(complex (integer 1 2))
                                 '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
  (assert-tri-eq t   t (subtypep '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))
                                 '(complex (integer 1 2)))))

(with-test (:name (typep real))
  (assert (typep 0 `(real ,(ash -1 10000) ,(ash 1 10000)))))

(with-test (:name (subtypep real))
  (assert-tri-eq t t (subtypep `(real ,(ash -1 1000) ,(ash 1 1000))
                               `(real ,(ash -1 10000) ,(ash 1 10000))))
  (assert-tri-eq t t (subtypep `(real (,(ash -1 1000)) (,(ash 1 1000)))
                               `(real ,(ash -1 1000) ,(ash 1 1000)))))

;;; Bug, found by Paul F. Dietz
(with-test (:name (typep subtypep complex rational))
  (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) :slow t)
  (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))))
          #+(or) (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)
            :broken-on :mark-region-gc
            :slow t)
  (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 40)
          (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
(with-test (:name (subtypep cons :empty))
  (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)))))

(with-test (:name :intelligent-satisfies)
  (assert (sb-kernel:type= (sb-kernel:specifier-type '(satisfies realp))
                           (sb-kernel:specifier-type 'real)))
  ;; Part of an example in https://bugs.launchpad.net/sbcl/+bug/309455
  (multiple-value-bind (answer certain)
      (subtypep 'complex '(and number (satisfies realp)))
    (assert (not answer))
    (assert certain)))

;;; CONS type SUBTYPEP could be too enthusiastic about thinking it was
;;; certain
(with-test (:name (subtypep cons satisfies))
  (assert-tri-eq nil nil (subtypep '(satisfies foo) '(satisfies bar)))
  (assert-tri-eq nil nil (subtypep '(cons (satisfies foo) t)
                                   '(cons (satisfies bar) t))))

(with-test (:name (subtypep generic-function function))
  (assert-tri-eq t t (subtypep 'generic-function 'function)))

;;; this would be in some internal test suite like type.before-xc.lisp
;;; except that generic functions don't exist at that stage.
(with-test (:name (subtypep generic-function sb-kernel:funcallable-instance))
  (assert-tri-eq t t (subtypep 'generic-function
                               'sb-kernel:funcallable-instance)))

;;; all sorts of answers are right for this one, but it used to
;;; trigger an AVER instead.
(with-test (:name (subtypep function satisfies :smoke))
  (subtypep '(function ()) '(and (function ()) (satisfies identity))))

(with-test (:name (sb-kernel:specifier-type :unknown-type))
  (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type))))

(with-test (:name (sb-kernel:type= array))
  (assert-tri-eq t   t (ctype= '(or (simple-array an-unkown-type (*))
                                    (simple-array an-unkown-type))
                               '(or (simple-array an-unkown-type (*))
                                    (simple-array an-unkown-type))))
  (assert-tri-eq t   t (ctype= '(simple-array an-unkown-type (*))
                               '(simple-array an-unkown-type (*))))
  (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (*))
                               '(array an-unkown-type (*))))
  (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (7))
                               '(simple-array an-unkown-type (8)))))

(with-test (:name (sb-kernel:type= cons))
  (assert-tri-eq nil t (ctype= 'cons '(cons single-float single-float)))
  (assert-tri-eq nil t (ctype= '(cons integer) '(cons))))

(with-test (:name (typep subtypep sb-kernel:instance))
  (assert (typep #p"" 'sb-kernel:instance))
  (assert-tri-eq t t (subtypep '(member #p"") 'sb-kernel:instance)))

(with-test (:name (sb-kernel:type= :simd-pack))
  (dolist (x '(single-float double-float))
    (let ((spec `(simd-pack ,x)))
      (assert (equal (multiple-value-list (ctype= spec spec)) '(t t))))))

(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))
  (checked-compile-and-assert ()
      '(lambda (x)
        (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
        (typep x (quote fixnum)))
    (((1+ most-positive-fixnum)) nil)
    ((most-positive-fixnum)      t)))

(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 (subtypep keyword symbol :bug-485972))
  (assert-tri-eq nil t (subtypep 'symbol 'keyword))
  (assert-tri-eq t   t (subtypep 'keyword 'symbol)))

;; WARNING: this test case would fail by recursing into the stack's guard page.
(with-test (:name (sb-kernel:specifier-type or and satisfies :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-tri-eq t t (subtypep '(or (integer * -1)
                                    (and (rational * -1/2) (not integer)))
                               '(rational * -1/2)))
  (assert-tri-eq t t (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)))))

;; lp#1317308 - TYPE-OF must not return a type specifier
;; involving AND,EQL,MEMBER,NOT,OR,SATISFIES,or VALUES.
(with-test (:name :ANSIly-report-hairy-array-type)
  (let ((simp-t (make-array 9))
        (simp-bit (make-array 16 :element-type 'bit)))
    ;; TYPE-OF doesn't have an optimization that returns a constant specifier
    ;; from a non-constant array of known type. If it did, we'd probably
    ;; want to check that these results are all equal:
    ;;  - the runtime-determined type
    ;;  - the compile-time-determined constant type
    ;;  - the compile-time-determined type of an equivalent object
    ;;    that is in fact a compile-time constant
    (flet ((our-type-of (x) (sb-kernel:type-specifier (sb-kernel:ctype-of x))))
      (let ((hairy-t (make-array 3 :displaced-to simp-t)))
        (assert (equal (our-type-of hairy-t)
                       '(vector t)))
        (assert (equal (type-of hairy-t) '(vector t 3))))
      (let ((hairy-t (make-array '(3 2) :displaced-to simp-t)))
        (assert (equal (our-type-of hairy-t)
                       '(array t (* *))))
        (assert (equal (type-of hairy-t) '(array t (3 2)))))
      (let ((hairy-bit
              (make-array 5 :displaced-to simp-bit :element-type 'bit)))
        (assert (equal (our-type-of hairy-bit)
                       'bit-vector))
        (assert (equal (type-of hairy-bit) '(bit-vector 5)))))))

(with-test (:name (subtypep array :bug-309098))
  (let ((u `(or ,@(map 'list (lambda (x) `(array ,(sb-vm:saetp-specifier x)))
                       sb-vm:*specialized-array-element-type-properties*))))
    (assert-tri-eq t t (subtypep 'array u))))

(with-test (:name :parse-safely)
  (dolist (x '(array integer cons))
    (assert (handler-case (sb-kernel:specifier-type `(,x . 0))
              (sb-kernel::arg-count-error () t)
              (error (c) (print c) nil)))))

(with-test (:name :unparse-safely)
  (let* ((intersection (sb-kernel:type-intersection
                        (sb-kernel:specifier-type '(vector (or bit character)))
                        (sb-kernel:specifier-type `(vector (or bit symbol)))))
         (round-trip (sb-kernel:specifier-type
                     (sb-kernel:type-specifier intersection))))
    (assert (sb-kernel:type= intersection round-trip))
    (assert (sb-kernel:array-type-p intersection))
    ;; and not *wild-type*
    (assert (sb-kernel:type/= (sb-kernel:array-type-specialized-element-type intersection)
                              (sb-kernel:specifier-type 'bit)))))

;; lp#1333731
(with-test (:name (adjust-array :changes type-of))
  ;; I think adjusting an array to enlarge it must read all the old data,
  ;; which would be undefined behavior if you hadn't initialized the array.
  (let ((a (make-array 10 :adjustable t :initial-element 0)))
    (assert (equal (type-of a) '(vector t 10)))
    (adjust-array a 20)
    (assert (equal (type-of a) '(vector t 20)))))

(with-test (:name :unknown-type-strongly-uncacheable)
  ;; VALUES-SPECIFIER-TYPE should not cache a specifier any part of which
  ;; is unknown. This leads to consistent results when parsing unknown
  ;; types. Previously it was indeterminate whether a condition would
  ;; be signaled for (OR UNKNOWN KNOWN) depending on whether that expression
  ;; had ever been parsed and whether it had been evicted from the cache.
  (assert-signal (progn (sb-kernel:specifier-type '(or weeble ratio))
                        (sb-kernel:specifier-type '(or weeble ratio)))
                 sb-kernel:parse-unknown-type 2) ; expect 2 signals
  (assert-signal (progn (sb-kernel:specifier-type '(and potrzebie real))
                        (sb-kernel:specifier-type '(and potrzebie real)))
                 sb-kernel:parse-unknown-type 2) ; expect 2 signals
  (assert-signal (progn (sb-kernel:specifier-type '(array strudel))
                        (sb-kernel:specifier-type '(array strudel)))
                 sb-kernel:parse-unknown-type 2) ; expect 2 signals
  (assert-signal (progn (sb-kernel:specifier-type '(not bad))
                        (sb-kernel:specifier-type '(not bad)))
                 sb-kernel:parse-unknown-type 2)) ; expect 2 signals

(with-test (:name :typep-satisfies-boolean)
  (assert (eq (eval '(typep 1 '(satisfies eval))) t)))

(import '(sb-kernel:specifier-type
          sb-kernel:type-specifier
          sb-kernel:type-intersection
          #+sb-unicode sb-kernel::character-string
          sb-kernel:simple-character-string
          sb-kernel:type=
          sb-kernel:find-classoid
          sb-kernel:make-numeric-type
          sb-kernel:types-equal-or-intersect
          sb-kernel:*empty-type*))

(with-test (:name :partition-array-into-simple/hairy)
  ;; Some tests that (simple-array | hairy-array) = array
  ;; At present this works only for wild element-type.
  (assert-tri-eq
   t t (type= (specifier-type '(not (and array (not simple-array))))
              (specifier-type '(or (not array) simple-array))))

  ;; if X is neither simple-array nor hairy-array, it is not an array
  (assert (type= (specifier-type '(and (not simple-array)
                                       (not (and array (not simple-array)))))
                 (specifier-type '(not array))))

  ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc
  (flet ((try (unrestricted simple)
           (assert (type= (specifier-type simple)
                          (type-intersection
                           (specifier-type
                            '(not (and array (not simple-array))))
                           (specifier-type unrestricted))))))
    (try 'vector '(simple-array * (*)))
    (try '(vector t) 'simple-vector)
    (try 'bit-vector 'simple-bit-vector)
    (try 'string 'simple-string)
    #+sb-unicode(try 'character-string 'simple-character-string)
    (try 'base-string 'simple-base-string))

  ;; if X is a known string and not an array-header
  ;; it must be a SIMPLE-STRING
  (assert (type= (type-intersection
                  (specifier-type 'string)
                  (specifier-type
                   '(not (or (and simple-array (not vector))
                             (and array (not simple-array))))))
                 (specifier-type 'simple-string))))

(with-test (:name :values-*-illegal)
  (dolist (x '((values *)
               (values *)
               (values * bit)
               (values bit *)
               (values bit &optional *)
               (values bit &rest *)
               (values bit &rest *)))
    (assert-signal (sb-kernel:values-specifier-type x) warning)))

(with-test (:name :classoids-as-type-specifiers)
  (dolist (classoid (list (find-classoid 'integer)
                          (find-class 'integer)))
    ;; Classoids and classes should work as type specifiers
    ;; in the atom form, not as lists.
    ;; Their legality or lack thereof is equivalent in all cases.
    (checked-compile `(lambda (x) (declare (,classoid x)) x))
    (checked-compile `(lambda (x) (declare (type ,classoid x)) x))
    ;; Negative tests come in two flavors:
    ;; In the case of (DECLARE (TYPE ...)), parsing the following thing
    ;; as a type should fail. But when 'TYPE is implied, "canonization"
    ;; should do nothing, because the following form is not a type,
    ;; so we get an error about an unrecognized declaration instead.
    (flet ((expect-lose (type)
             (assert (nth-value 1 (checked-compile
                                   `(lambda (x) (declare (,type x)) x)
                                   :allow-warnings t)))
             (assert (nth-value 1 (checked-compile
                                   `(lambda (x) (declare (,type x)) x)
                                   :allow-warnings t)))))
      (expect-lose `(,classoid))
      (expect-lose `(,classoid 1 100)))))

(with-test (:name :classoid-type-kind)
  (do-all-symbols (s)
    (let ((c (sb-kernel:find-classoid s nil)))
      ;; No classoid can have a :TYPE :KIND that is :DEFINED.
      (when c
        (if (typep c 'sb-kernel:built-in-classoid)
            (assert (eq (sb-int:info :type :kind s) :primitive))
            (assert (eq (sb-int:info :type :kind s) :instance)))))))

(with-test (:name (make-numeric-type :smoke))
  (assert (eq (make-numeric-type :class 'integer :low '(4) :high '(5))
              *empty-type*)))

(with-test (:name (make-numeric-type :union))
  (assert (equal (type-specifier (make-numeric-type :low '(-79106810381456307)))
                 `(or (rational (-79106810381456307))
                      (single-float (-7.910681e16))
                      (double-float (-7.91068103814563d16))))))

(with-test (:name (make-numeric-type :infinities))
  ;; Without class
  (assert (equal (type-specifier
                  (make-numeric-type :low sb-ext:single-float-negative-infinity
                                     :high sb-ext:single-float-negative-infinity))
                 `(or (single-float ,sb-ext:single-float-negative-infinity
                                    ,sb-ext:single-float-negative-infinity)
                      (double-float ,sb-ext:double-float-negative-infinity
                                    ,sb-ext:double-float-negative-infinity))))
  (assert (equal (type-specifier
                  (make-numeric-type :low sb-ext:single-float-negative-infinity))
                 'real))
  ;; With FLOAT class
  (assert (equal (type-specifier
                  (make-numeric-type :class 'float
                                     :low sb-ext:single-float-negative-infinity
                                     :high sb-ext:single-float-negative-infinity))
                 `(or (single-float ,sb-ext:single-float-negative-infinity
                                    ,sb-ext:single-float-negative-infinity)
                      (double-float ,sb-ext:double-float-negative-infinity
                                    ,sb-ext:double-float-negative-infinity))))
  (assert (equal (type-specifier
                  (make-numeric-type :class 'float
                                     :low sb-ext:single-float-negative-infinity))
                 `float)))

(with-test (:name :prettier-union-types :skipped-on (not :sb-unicode))
  ;; (OR STRING BIGNUM) used to unparse as
  ;; (OR (VECTOR CHARACTER) BASE-STRING (INTEGER * -4611686018427387905)
  ;;     (INTEGER 4611686018427387904)) etc
  (dolist (other '(float real bignum))
    (let* ((spec `(or string ,other))
           (parse (sb-kernel:specifier-type spec))
           (unparse (sb-kernel:type-specifier parse)))
      (assert (or (equal unparse `(or string ,other))
                  (equal unparse `(or ,other string)))))))

(with-test (:name :unparse-string)
  (assert (equal (type-specifier (specifier-type '(string 10)))
                 '(#+sb-unicode string #-sb-unicode base-string 10)))
  (assert (equal (type-specifier (specifier-type '(simple-string 10)))
                 '(#+sb-unicode simple-string #-sb-unicode simple-base-string 10))))

(with-test (:name :numeric-types-adjacent)
  (dolist (x '(-0s0 0s0))
    (dolist (y '(-0s0 0s0))
      (let ((a (specifier-type `(single-float -10s0 ,x)))
            (b (specifier-type `(single-float ,y 20s0))))
        (assert (types-equal-or-intersect a b)))
      (let ((a (specifier-type `(single-float -10s0 (,x))))
            (b (specifier-type `(single-float ,y 20s0))))
        (assert (not (types-equal-or-intersect a b))))
      (let ((a (specifier-type `(single-float -10s0 ,x)))
            (b (specifier-type `(single-float (,y) 20s0))))
        (assert (not (types-equal-or-intersect a b)))))))

(with-test (:name :ctypep-function)
  (assert (not (sb-kernel:ctypep #'+ (eval '(sb-kernel:specifier-type '(function (list))))))))

(with-test (:name :cons-union-loop)
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(or (cons (or fixnum vector (member a "b")))
                 (cons (or (and (not vector) array) (and (not integer) number)) number))))
   ((10) nil)
   (((cons 1 2)) t)))

(with-test (:name :pathnamep-flag-bit)
  (let ((f (compile nil '(lambda (x) (pathnamep x)))))
    (assert (not (ctu:find-code-constants f)))))

(with-test (:name :structure-is-a)
  (dolist (what '(sb-int:sset-element sb-c::leaf sb-c::functional
                  sb-c::optional-dispatch))
    (assert (eval `(sb-c::%structure-is-a ,(sb-kernel:find-layout 'sb-c::optional-dispatch)
                                          ,(sb-kernel:find-layout what))))))

(with-test (:name :type-of-empty-instance)
  (assert (eq (type-of (test-util::make-funcallable-instance 6))
              'sb-kernel:funcallable-instance))
  (assert (eq (type-of (eval '(sb-kernel:%make-instance 12)))
              'sb-kernel:instance)))

(with-test (:name (:cons-union :lp1912863))
  (let ((c (cons 2 4)))
    (assert (not (typep c '(or (cons (integer 0 8) (integer 5 15))
                            (cons (integer 3 15) (integer 4 14))))))))

(with-test (:name (:rational-union :equivalent-to-t))
  (let ((type '(or (integer * -1) (rational -1/2 1/2) (integer 1) (not integer))))
    (assert-tri-eq t t (subtypep t type))))

(with-test (:name (:rational-union :wider-equivalent-to-t))
  (let ((type '(or (integer * -2) (rational -3/2 3/2) (integer 2) (not integer))))
    (assert-tri-eq t t (subtypep t type))))

(with-test (:name (:rational-union :no-integers-in-rational))
  (let ((type '(or (integer 1 1) (rational 1/2 1/2))))
    (assert-tri-eq t t (subtypep type 'rational))
    (assert-tri-eq nil t (subtypep 'rational type))
    (assert-tri-eq nil t (subtypep type 'integer))
    (assert-tri-eq nil t (subtypep 'integer type))
    (assert (typep 1 type))
    (assert (typep 1/2 type))
    (assert (not (typep 3/4 type)))))

(with-test (:name (:rational-union :open-bounds-closed))
  (let ((t1 '(rational -1 1))
        (t2 '(or (integer -1 1) (rational (-1) (1)))))
    (assert-tri-eq t t (subtypep t1 t2))
    (assert-tri-eq t t (subtypep t2 t1))))

(with-test (:name (:rational-union :lp1912863 :bug039))
  (flet ((bug039 ()
           (let ((t1 'cons)
                 (t2 '(or (not (cons t (real -1 1)))
                       (not (cons sequence (eql 2))))))
             (assert-tri-eq t t (subtypep t1 t2))
             (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1))))))
    (bug039)))

(with-test (:name (:rational-union :lp1912863 :bug041))
  (flet ((bug041 ()
           (let ((t1 '(not (cons t integer)))
                 (t2 '(not (cons (array nil) (eql 0))))
                 (t3 '(cons simple-array t)))
             (assert-tri-eq t t (subtypep t1 t2))
             (assert-tri-eq t t (subtypep `(not (or ,t2 ,t3)) `(not ,t1)))
             (assert-tri-eq t t (subtypep `(and (not ,t2) (not ,t3)) `(not ,t1))))))
    (bug041)))

(with-test (:name (:lp1916040 :answer))
  (let* ((t1 '(cons sequence short-float))
         (t2 '(or (cons t atom) (cons function t)))
         (answer (multiple-value-list (subtypep t1 t2))))
    (assert (member answer '((nil nil) (t t)) :test 'equal))))

(with-test (:name (:lp1916233))
  (assert-tri-eq t t (subtypep '(cons (or (simple-array ratio) simple-array) nil) nil))
  (assert-tri-eq t t (subtypep '(or (array ratio) sequence) t)))

(defun my-widetag-of (x)
  (sb-sys:sap-ref-8 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address x))
                    (- sb-vm:other-pointer-lowtag)))
;;; I'll bet that nothing anywhere tests this
(with-test (:name :nil-has-symbol-widetag
            :skipped-on (:or :ppc64 :big-endian))
  (assert (= (my-widetag-of nil) (my-widetag-of t))))

(with-test (:name :array-rank-deriver-negation)
  (assert
   (ctype= (caddr
            (sb-kernel:%simple-fun-type
             (checked-compile
              `(lambda (a) (array-rank (the (not (array t)) a))))))
           `(values (mod 129) &optional))))

(with-test (:name (:rational-intersection :lp1998008))
  (flet ((bug101 ()
           (let ((t1 '(or (not (real 1 3)) (eql 2))))
             (assert-tri-eq t t (subtypep `(not (not ,t1)) t1))
             (assert-tri-eq t t (subtypep t1 `(not (not ,t1)))))))
    (bug101)))

(with-test (:name (:rational-intersection :integer-bounds))
  (let ((t1 '(and (not integer) (rational 3 5)))
        (t2 '(and (not integer) (rational (3) (5)))))
    (assert-tri-eq t t (subtypep t1 t2))
    (assert-tri-eq t t (subtypep t2 t1))
    (assert-tri-eq t t (subtypep `(not ,t1) `(not ,t2)))
    (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1)))))

(with-test (:name (:cons-union :lp1999352))
  (let* ((v (list :a))
         (type1 `(cons (or atom (eql ,v))))
         (type2 `(cons (or (member :a 2) cons) list)))
    (let ((bug103 (compile nil
                           `(lambda (val)
                              (declare (type ,type1 val))
                              (the ,type2 val)))))
      (assert (equal (funcall bug103 (list v)) '((:a)))))))

(with-test (:name :union-type-checks)
  (assert (not (find 'integerp
                     (ctu:ir1-named-calls `(lambda (x)
                                             (declare ((or list fixnum) x))
                                             (typep x 'integer))
                                          nil)))))

(with-test (:name :union-intersection-simplification)
  (checked-compile-and-assert
   ()
   `(lambda (a)
      (typep a '(or
                 (and symbol (not null))
                 (and array (not string)))))
   ((#()) t)
   (("") nil)
   ((t) t)
   ((nil) nil)))

(with-test (:name :union-integer-complex)
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(or (integer 36757953510256822604)
                 (complex fixnum))))
   ((-1) nil)
   ((36757953510256822603) nil)
   ((36757953510256822604) t)
   ((36757953510256822605) t)
   ((#C(1d0 1d0)) nil)
   ((#C(1 1)) t)
   ((#C(1 #.(expt 2 300))) t)))

#+(or arm64 x86-64)
(with-test (:name :structure-typep-fold)
  (assert-type
   (lambda (a b)
     (declare (character a))
       (sb-c::structure-typep a b))
   null)
  (assert-type
   (lambda (a)
     (declare (hash-table a))
     (sb-c::structure-typep a #.(sb-kernel:find-layout 'condition)))
   null)
  (assert-type
   (lambda (a)
     (declare (pathname a))
     (sb-c::structure-typep a #.(sb-kernel:find-layout 'pathname)))
   (eql t)))

(with-test (:name :typep-vector-folding)
  (assert-type
   (lambda (p)
     (declare (integer p))
     (typep p '(vector t 1)))
   null))

(with-test (:name :non-null-symbol-load-widetag)
  (checked-compile-and-assert
   ()
   `(lambda (p)
     (declare ((or symbol array) p))
     (typecase  p
       ((and symbol (not null)) 1)
       (simple-array 2)))
   ((nil) nil)
   ((t) 1)
   ((:a) 1)
   (("") 2)
   (((make-array 10 :adjustable t)) nil)))

(with-test (:name :other-pointer-subtypes)
  (assert-type
   (lambda (j)
     (sb-kernel:%other-pointer-p (the (and sequence (not vector)) j)))
   null))

(with-test (:name :non-simple-arrays)
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(and (vector t) (not simple-array))))
   ((#()) nil)
   (((make-array 10 :adjustable t)) t))
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(and (array t) (not simple-array))))
   ((#()) nil)
   ((#2A()) nil)
   (((make-array '(10 10) :adjustable t)) t))
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(and (vector t 10) (not simple-array))))
   ((#10(t)) nil)
   (((make-array 10 :adjustable t)) t)
   (((make-array '(2 5) :adjustable t)) nil))
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (typep x '(and (array t 2) (not simple-array))))
   ((#2A()) nil)
   (((make-array '(2 2) :adjustable t)) t)
   (((make-array 2 :adjustable t)) nil)))

(with-test (:name :member-hairy-type-intersection)
  (assert
   (sb-kernel:type=
    (sb-kernel:type-intersection  (sb-kernel:specifier-type '(member #1=(m) a))
                                  (sb-kernel:specifier-type '(cons (satisfies eval))))
    (sb-kernel:specifier-type '(and (cons (satisfies eval) t) (member #1#))))))

(with-test (:name :subtype-array-union)
  (assert (subtypep (opaque-identity '(array t))
                    (opaque-identity '(or simple-array (array unsigned-byte)))))
  (assert (subtypep (opaque-identity '(vector character))
                    (opaque-identity '(or (and string (not simple-array))
                                       simple-array))))
  (assert (subtypep (opaque-identity '(vector unknown))
                    (opaque-identity 'sequence))))

(deftype subtype-equal-type (&rest args) `(or fixnum (member ,@args)))

(with-test (:name :subtypep-equal-member)
  (multiple-value-bind (answer certain)
      ;; Verify that the SUBTYPEP fast path is taken
      (subtypep (opaque-identity '((invalid)))
                (opaque-identity '((invalid))))
    (assert (and answer certain)))
  (multiple-value-bind (answer certain)
      (subtypep (opaque-identity '(eql (list 1)))
                (opaque-identity '(eql (list 1))))
    (assert (and (not answer) certain)))
  (multiple-value-bind (answer certain)
      (subtypep (opaque-identity '(subtype-equal-type 1 (list 2) 3))
                (opaque-identity '(subtype-equal-type 1 (list 2) 3)))
    (assert (and (not answer) certain)))
  (assert (not (subtypep (opaque-identity '(function (&key (member t))))
                         (opaque-identity '(function (&key (eql t))))))))

(with-test (:name :typep-rational-ratio)
  (checked-compile-and-assert
      ()
      `(lambda (p)
         (typep p '(and (rational 1) (not integer))))
    ((4/3) t)
    ((-4/3) nil)
    ((1) nil)
    ((2) nil)))

(with-test (:name :complex-type-of)
  (assert (equal (type-of (opaque-identity #c(1 2)))
                 '(complex rational))))

(with-test (:name :complex-sub-real)
  (assert (equal (sb-ext:typexpand-all '(or (complex rational) (complex single-float)))
                 (sb-ext:typexpand-all '(complex (or rational single-float))))))


(with-test (:name :typep-evaluate)
  (checked-compile-and-assert
   ()
   `(lambda (x)
      (block nil
        (typep (return x) 't)))
   ((10) 10)))

(with-test (:name :function-simple-union/intersection)
  (let ((type (sb-kernel:specifier-type
               '(function (sequence &key (start integer) (end integer)) sequence))))
    (assert (eq type
                (sb-kernel::function-simple-union2-type-method type type)))
    (assert (eq type
                (sb-kernel::function-simple-intersection2-type-method type type)))))

(with-test (:name :array-canonical-difference)
  (assert (eql
           (specifier-type '(and (simple-array * (10)) (not string)))
           (specifier-type '(and (simple-array * (10)) (not (simple-string 10))))))
  (assert (type= (specifier-type '(or (simple-array fixnum) (not simple-array)))
                 (specifier-type '(or (array fixnum) (not simple-array)))))
  (assert (type= (specifier-type '(or (simple-array (mod 3)) (not simple-array)))
                 (specifier-type '(or (array (mod 3)) (not simple-array)))))
  (assert (subtypep '(or (array (mod 3)) (not simple-array))
                    '(or (simple-array (mod 3)) (not simple-array))))
  (assert (subtypep '(not (or (not simple-array) simple-string)) '(not string)))
  (assert (subtypep '(and (array symbol) (not (and (array t) (not simple-array))))
                    '(simple-array symbol)))
  (assert (subtypep '(array t)
                    '(or (and (array t) (not simple-array)) (simple-array integer))))
  (assert (subtypep '(array (integer 15 27))
                    '(or (and (array (integer 15 27)) (not simple-array))
                      (simple-array (integer 17 30)))))
  (assert (eql (specifier-type '(and (not (simple-array t)) (not (and (array t) (not simple-array)))))
               (specifier-type '(not (array t)))))
  (assert (subtypep '(and (not simple-array) (not (and (array t) (not simple-array))))
                    '(and (not simple-array) (not (array t)))))
  (assert (eql (specifier-type '(not simple-array))
               (specifier-type '(or (not array) (and array (not simple-array))))))
  (assert (eql (specifier-type '(or (and array (not (array t))) (and (array t) (not simple-array))))
               (specifier-type '(and array (not (simple-array t))))))
  (assert (eql (specifier-type '(or (not (vector * 10)) (and vector (not simple-array))))
               (specifier-type '(not (simple-array * (10))))))
  (assert (not (subtypep '(not (simple-array t))
                         '(or (not array) (and (array t) (not simple-array))))))
  (assert (eql (specifier-type '(or (not vector) (not (array t))))
               (specifier-type '(not (vector t)))))
  (assert (eql (specifier-type '(or (not simple-array) (not (array t))))
               (specifier-type '(not (simple-array t)))))
  (assert (eql (specifier-type '(or (and (not integer) (not vector) (not (array t))) vector (array t)))
               (specifier-type '(not integer))))
  (assert (eql (specifier-type '(or (and (not integer) (not vector) (not (array t))) vector))
               (specifier-type '(or (and (not integer) (not (array t))) vector))))
  (assert (not (subtypep '(not simple-bit-vector)
                         '(or (not (array bit)) (and bit-vector (not simple-array))))))
  (assert (eql (specifier-type '(not (and (array t) (not simple-array))))
               (specifier-type '(or (not (array t)) simple-array))))
  (assert (eql (specifier-type '(not (and base-string (not simple-array))))
               (specifier-type '(or (not base-string) simple-base-string))))
  (assert (eql (specifier-type '(and (array cons) (array number)))
               (specifier-type '(array t))))
  (assert (sb-kernel:intersection-type-p (specifier-type '(and (vector unknown) bit-vector)))))

(with-test (:name :intersection-not-numeric)
  (assert (eql
           (specifier-type '(and (not (eql 1)) (not (eql 0))))
           (specifier-type '(not bit))))
  (assert (eql (specifier-type '(or (not integer) (not (rational 1 10))))
               (specifier-type '(not (integer 1 10))))))

(with-test (:name :class-canonical-difference)
  (assert (eql
           (specifier-type '(or (and stream standard-object) (and (not stream) standard-object)))
           (specifier-type 'standard-object)))
  (assert (eql
           (specifier-type '(or (and stream standard-object) (not standard-object)))
           (specifier-type '(or stream (not standard-object)))))
  (assert (eql (specifier-type '(or (and standard-object sb-kernel:extended-sequence)
                                 (and standard-object (not sb-kernel:extended-sequence))))
               (specifier-type 'standard-object)))
  (assert (eql (specifier-type '(or (and atom (not stream)) (and stream standard-object)))
               (specifier-type '(or (and atom (not stream)) standard-object)))))

(with-test (:name :cons-intersection)
  (assert (eql (specifier-type '(and (cons (not array) atom) (cons (not integer) (not integer))))
               (specifier-type '(cons (and (not array) (not integer)) (and atom (not integer))))))
  (assert (eql (specifier-type '(or (and (not integer) (not stream) (not standard-object)) (and (not stream) standard-object)))
               (specifier-type '(and (not integer) (not stream))))))

(with-test (:name :float-zero-typep)
  (checked-compile-and-assert
      ()
      `(lambda (x)
         (typep x '(single-float * (0.0))))
    ((0.0) nil)
    ((-0.0) nil)
    ((1.0) nil)
    ((-1.0) t))
  (checked-compile-and-assert
      ()
      `(lambda (x)
         (typep x '(or (member 0.0) (single-float (0.0) 1.0))))
    ((0.0) t)
    ((1.0) t)
    ((2.0) nil)
    ((-0.0) nil)
    ((-1.0) nil)
    ((-2.0) nil)))
