tests/type.impure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (load "assertoid.lisp")
  13 (use-package "ASSERTOID")
  14 (use-package "TEST-UTIL")
  15
  16 (defmacro assert-nil-nil (expr)
  17   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
  18 (defmacro assert-nil-t (expr)
  19   `(assert (equal '(nil t) (multiple-value-list ,expr))))
  20 (defmacro assert-t-t (expr)
  21   `(assert (equal '(t t) (multiple-value-list ,expr))))
  22
  23 (defmacro assert-t-t-or-uncertain (expr)
  24   `(assert (let ((list (multiple-value-list ,expr)))
  25              (or (equal '(nil nil) list)
  26                  (equal '(t t) list)))))
  27
  28 (let ((types '(character
  29                integer fixnum (integer 0 10)
  30                single-float (single-float -1.0 1.0) (single-float 0.1)
  31                (real 4 8) (real -1 7) (real 2 11)
  32                null symbol keyword
  33                (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
  34               (member #\a #\c #\d #\f) (integer -1 1)
  35                unsigned-byte
  36                (rational -1 7) (rational -2 4)
  37                ratio
  38                )))
  39   (dolist (i types)
  40     (format t "type I=~S~%" i)
  41     (dolist (j types)
  42       (format t "  type J=~S~%" j)
  43       (assert (subtypep i `(or ,i ,j)))
  44       (assert (subtypep i `(or ,j ,i)))
  45       (assert (subtypep i `(or ,i ,i ,j)))
  46       (assert (subtypep i `(or ,j ,i)))
  47       (dolist (k types)
  48         (format t "    type K=~S~%" k)
  49         (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
  50         (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
  51
  52 ;;; gotchas that can come up in handling subtypeness as "X is a
  53 ;;; subtype of Y if each of the elements of X is a subtype of Y"
  54 (let ((subtypep-values (multiple-value-list
  55                         (subtypep '(single-float -1.0 1.0)
  56                                   '(or (real -100.0 0.0)
  57                                        (single-float 0.0 100.0))))))
  58   (assert (member subtypep-values
  59                   '(;; The system isn't expected to
  60                     ;; understand the subtype relationship.
  61                     (nil nil)
  62                     ;; But if it does, that'd be neat.
  63                     (t t)
  64                     ;; (And any other return would be wrong.)
  65                     )
  66                   :test #'equal)))
  67
  68 (defun type-evidently-= (x y)
  69   (and (subtypep x y)
  70        (subtypep y x)))
  71
  72 (assert (subtypep 'single-float 'float))
  73
  74 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
  75
  76 ;;; Bug 50(c,d): numeric types with empty ranges should be NIL
  77 (assert (type-evidently-= 'nil '(integer (0) (0))))
  78 (assert (type-evidently-= 'nil '(rational (0) (0))))
  79 (assert (type-evidently-= 'nil '(float (0.0) (0.0))))
  80
  81 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
  82 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
  83 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
  84 (assert (eql (upgraded-array-element-type t) t))
  85 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
  86 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
  87
  88 ;;; Do reasonable things with undefined types, and with compound types
  89 ;;; built from undefined types.
  90 ;;;
  91 ;;; part I: TYPEP
  92 (assert (typep #(11) '(simple-array t 1)))
  93 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
  94 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  95 (assert (not (typep 11 '(simple-array undef-type 1))))
  96 ;;; part II: SUBTYPEP
  97
  98 (assert (subtypep '(vector some-undef-type) 'vector))
  99 (assert (not (subtypep '(vector some-undef-type) 'integer)))
 100 (assert-nil-nil (subtypep 'utype-1 'utype-2))
 101 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
 102 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
 103 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
 104
 105 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
 106 (assert (raises-error? (typep 11 'and)))
 107 (assert (raises-error? (typep 11 'or)))
 108 (assert (raises-error? (typep 11 'member)))
 109 (assert (raises-error? (typep 11 'values)))
 110 (assert (raises-error? (typep 11 'eql)))
 111 (assert (raises-error? (typep 11 'satisfies)))
 112 (assert (raises-error? (typep 11 'not)))
 113 ;;; and while it doesn't specifically disallow illegal compound
 114 ;;; specifiers from the CL package, we don't have any.
 115 (assert (raises-error? (subtypep 'fixnum '(fixnum 1))))
 116 (assert (raises-error? (subtypep 'class '(list))))
 117 (assert (raises-error? (subtypep 'foo '(ratio 1/2 3/2))))
 118 (assert (raises-error? (subtypep 'character '(character 10))))
 119 #+nil ; doesn't yet work on PCL-derived internal types
 120 (assert (raises-error? (subtypep 'lisp '(class))))
 121 #+nil
 122 (assert (raises-error? (subtypep 'bar '(method number number))))
 123
 124 ;;; Of course empty lists of subtypes are still OK.
 125 (assert (typep 11 '(and)))
 126 (assert (not (typep 11 '(or))))
 127
 128 ;;; bug 12: type system didn't grok nontrivial intersections
 129 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
 130 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
 131 (assert (subtypep 'keyword 'symbol))
 132 (assert (not (subtypep 'symbol 'keyword)))
 133 (assert (subtypep 'ratio 'real))
 134 (assert (subtypep 'ratio 'number))
 135
 136 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
 137 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
 138 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
 139 ;;; HAIRY domain.
 140 (assert-nil-t (subtypep 'atom 'cons))
 141 (assert-nil-t (subtypep 'cons 'atom))
 142 ;;; These two are desireable but not necessary for ANSI conformance;
 143 ;;; maintenance work on other parts of the system broke them in
 144 ;;; sbcl-0.7.13.11 -- CSR
 145 #+nil
 146 (assert-nil-t (subtypep '(not list) 'cons))
 147 #+nil
 148 (assert-nil-t (subtypep '(not float) 'single-float))
 149 (assert-t-t (subtypep '(not atom) 'cons))
 150 (assert-t-t (subtypep 'cons '(not atom)))
 151 ;;; ANSI requires that SUBTYPEP relationships among built-in primitive
 152 ;;; types never be uncertain, i.e. never return NIL as second value.
 153 ;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
 154 ;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
 155 ;;; CMU CL's HAIRY-TYPE logic punted a lot).
 156 (assert-t-t (subtypep 'integer 'atom))
 157 (assert-t-t (subtypep 'function 'atom))
 158 (assert-nil-t (subtypep 'list 'atom))
 159 (assert-nil-t (subtypep 'atom 'integer))
 160 (assert-nil-t (subtypep 'atom 'function))
 161 (assert-nil-t (subtypep 'atom 'list))
 162 ;;; ATOM is equivalent to (NOT CONS):
 163 (assert-t-t (subtypep 'integer '(not cons)))
 164 (assert-nil-t (subtypep 'list '(not cons)))
 165 (assert-nil-t (subtypep '(not cons) 'integer))
 166 (assert-nil-t (subtypep '(not cons) 'list))
 167 ;;; And we'd better check that all the named types are right. (We also
 168 ;;; do some more tests on ATOM here, since once CSR experimented with
 169 ;;; making it a named type.)
 170 (assert-t-t (subtypep 'nil 'nil))
 171 (assert-t-t (subtypep 'nil 'atom))
 172 (assert-t-t (subtypep 'nil 't))
 173 (assert-nil-t (subtypep 'atom 'nil))
 174 (assert-t-t (subtypep 'atom 'atom))
 175 (assert-t-t (subtypep 'atom 't))
 176 (assert-nil-t (subtypep 't 'nil))
 177 (assert-nil-t (subtypep 't 'atom))
 178 (assert-t-t (subtypep 't 't))
 179 ;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
 180 ;;; recognized as a subtype of ATOM:
 181 (assert-t-t (subtypep '(not list) 'atom))
 182 (assert-nil-t (subtypep 'atom '(not list)))
 183 ;;; These used to fail, because when the two arguments to subtypep are
 184 ;;; of different specifier-type types (e.g. HAIRY and UNION), there
 185 ;;; are two applicable type methods -- in this case
 186 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
 187 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
 188 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 189 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
 190 ;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
 191 ;;; logic in those type methods fixed it.
 192 (assert-nil-t (subtypep '(not cons) 'list))
 193 (assert-nil-t (subtypep '(not single-float) 'float))
 194 ;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
 195 ;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
 196 (assert-t-t (subtypep '(and zilch integer) 'zilch))
 197 (assert-t-t (subtypep '(and integer zilch) 'zilch))
 198
 199 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
 200 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
 201 ;;; corresponding to the NIL type-specifier; we were bogusly returning
 202 ;;; NIL, T (indicating surety) for the following:
 203 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
 204
 205 ;;; It turns out that, as of sbcl-0.7.2, we require to be able to
 206 ;;; detect this to compile src/compiler/node.lisp (and in particular,
 207 ;;; the definition of the component structure). Since it's a sensible
 208 ;;; thing to want anyway, let's test for it here:
 209 (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
 210                       '(or some-undefined-type (member :no-ir2-yet :dead))))
 211 ;;; BUG 158 (failure to compile loops with vector references and
 212 ;;; increments of greater than 1) was a symptom of type system
 213 ;;; uncertainty, to wit:
 214 (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
 215                       '(mod 536870911))) ; aka SB-INT:INDEX.
 216 ;;; floating point types can be tricky.
 217 (assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
 218 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
 219 (assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
 220 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
 221 (assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
 222 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
 223 (assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
 224 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
 225
 226 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
 227 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
 228 (assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
 229 (assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
 230 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
 231 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
 232 (assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
 233 (assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
 234
 235 (assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
 236 (assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
 237 (assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
 238 (assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
 239
 240 (assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
 241 (assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
 242
 243 (assert-t-t (subtypep '(float -0.0) '(float 0.0)))
 244 (assert-t-t (subtypep '(float 0.0) '(float -0.0)))
 245 (assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
 246 (assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))
 247 \f
 248 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 249 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 250 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 251 ;;;; They look nice but they're nontrivial enough that it's not
 252 ;;;; obvious from inspection that everything is OK. Let's make sure
 253 ;;;; that things still basically work.
 254
 255 ;; structure type tests setup
 256 (defstruct structure-foo1)
 257 (defstruct (structure-foo2 (:include structure-foo1))
 258   x)
 259 (defstruct (structure-foo3 (:include structure-foo2)))
 260 (defstruct (structure-foo4 (:include structure-foo3))
 261   y z)
 262
 263 ;; structure-class tests setup
 264 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 265 (defclass structure-class-foo2 (structure-class-foo1)
 266   () (:metaclass cl:structure-class))
 267 (defclass structure-class-foo3 (structure-class-foo2)
 268   () (:metaclass cl:structure-class))
 269 (defclass structure-class-foo4 (structure-class-foo3)
 270   () (:metaclass cl:structure-class))
 271
 272 ;; standard-class tests setup
 273 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 274 (defclass standard-class-foo2 (standard-class-foo1)
 275   () (:metaclass cl:standard-class))
 276 (defclass standard-class-foo3 (standard-class-foo2)
 277   () (:metaclass cl:standard-class))
 278 (defclass standard-class-foo4 (standard-class-foo3)
 279   () (:metaclass cl:standard-class))
 280
 281 ;; condition tests setup
 282 (define-condition condition-foo1 (condition) ())
 283 (define-condition condition-foo2 (condition-foo1) ())
 284 (define-condition condition-foo3 (condition-foo2) ())
 285 (define-condition condition-foo4 (condition-foo3) ())
 286
 287 ;;; inline type tests
 288 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 289 (defparameter *tests-of-inline-type-tests*
 290   '(progn
 291
 292      ;; structure type tests
 293      (assert (typep (make-structure-foo3) 'structure-foo2))
 294      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 295      (assert (typep (nth-value 1
 296                                (ignore-errors (structure-foo2-x
 297                                                (make-structure-foo1))))
 298                     'type-error))
 299      (assert (null (ignore-errors
 300                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 301
 302      ;; structure-class tests
 303      (assert (typep (make-instance 'structure-class-foo3)
 304                     'structure-class-foo2))
 305      (assert (not (typep (make-instance 'structure-class-foo1)
 306                          'structure-class-foo4)))
 307      (assert (null (ignore-errors
 308                      (setf (slot-value (make-instance 'structure-class-foo1)
 309                                        'x)
 310                            11))))
 311
 312      ;; standard-class tests
 313      (assert (typep (make-instance 'standard-class-foo3)
 314                     'standard-class-foo2))
 315      (assert (not (typep (make-instance 'standard-class-foo1)
 316                          'standard-class-foo4)))
 317      (assert (null (ignore-errors
 318                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 319                            11))))
 320
 321      ;; condition tests
 322      (assert (typep (make-condition 'condition-foo3)
 323                     'condition-foo2))
 324      (assert (not (typep (make-condition 'condition-foo1)
 325                          'condition-foo4)))
 326      (assert (null (ignore-errors
 327                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 328                            11))))
 329      (assert (subtypep 'error 't))
 330      (assert (subtypep 'simple-condition 'condition))
 331      (assert (subtypep 'simple-error 'simple-condition))
 332      (assert (subtypep 'simple-error 'error))
 333      (assert (not (subtypep 'condition 'simple-condition)))
 334      (assert (not (subtypep 'error 'simple-error)))
 335      (assert (eq (car (sb-pcl:class-direct-superclasses
 336                        (find-class 'simple-condition)))
 337                  (find-class 'condition)))
 338
 339      #+nil ; doesn't look like a good test
 340      (let ((subclasses (mapcar #'find-class
 341                                '(simple-type-error
 342                                  simple-error
 343                                  simple-warning
 344                                  sb-int:simple-file-error
 345                                  sb-int:simple-style-warning))))
 346        (assert (null (set-difference
 347                       (sb-pcl:class-direct-subclasses (find-class
 348                                                        'simple-condition))
 349                       subclasses))))
 350
 351      ;; precedence lists
 352      (assert (equal (sb-pcl:class-precedence-list
 353                      (find-class 'simple-condition))
 354                     (mapcar #'find-class '(simple-condition
 355                                            condition
 356                                            sb-pcl::slot-object
 357                                            t))))
 358
 359      ;; stream classes
 360      (assert (equal (sb-pcl:class-direct-superclasses (find-class
 361                                                        'fundamental-stream))
 362                     (mapcar #'find-class '(standard-object stream))))
 363      (assert (null (set-difference
 364                     (sb-pcl:class-direct-subclasses (find-class
 365                                                      'fundamental-stream))
 366                     (mapcar #'find-class '(fundamental-binary-stream
 367                                            fundamental-character-stream
 368                                            fundamental-output-stream
 369                                            fundamental-input-stream)))))
 370      (assert (equal (sb-pcl:class-precedence-list (find-class
 371                                                    'fundamental-stream))
 372                     (mapcar #'find-class '(fundamental-stream
 373                                            standard-object
 374                                            sb-pcl::slot-object
 375                                            stream
 376                                            t))))
 377      (assert (equal (sb-pcl:class-precedence-list (find-class
 378                                                    'fundamental-stream))
 379                     (mapcar #'find-class '(fundamental-stream
 380                                            standard-object
 381                                            sb-pcl::slot-object stream
 382                                            t))))
 383      (assert (subtypep (find-class 'stream) (find-class t)))
 384      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 385      (assert (not (subtypep 'stream 'fundamental-stream)))))
 386 ;;; Test under the interpreter.
 387 (eval *tests-of-inline-type-tests*)
 388 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 389 ;;; Test under the compiler.
 390 (defun tests-of-inline-type-tests ()
 391   #.*tests-of-inline-type-tests*)
 392 (tests-of-inline-type-tests)
 393 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 394 \f
 395 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 396 (defclass superclass () ())
 397 (defclass maybe-subclass () ())
 398 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 399 (defclass maybe-subclass (superclass) ())
 400 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 401 (defclass maybe-subclass () ())
 402 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 403 \f
 404 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
 405 ;;; specialized on some as-yet-undefined type which would cause this
 406 ;;; program to fail (bugs #123 and #165). Verify that it doesn't.
 407 (defun foo (x)
 408   (declare (type (vector bar) x))
 409   (aref x 1))
 410 (deftype bar () 'single-float)
 411 (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
 412              0.0f0))
 413
 414 ;;; bug 260a
 415 (assert-t-t
 416  (let* ((s (gensym))
 417         (t1 (sb-kernel:specifier-type s)))
 418    (eval `(defstruct ,s))
 419    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
 420
 421 ;;; bug found by PFD's random subtypep tester
 422 (let ((t1 '(cons rational (cons (not rational) (cons integer t))))
 423       (t2 '(not (cons (integer 0 1) (cons single-float long-float)))))
 424   (assert-t-t (subtypep t1 t2))
 425   (assert-nil-t (subtypep t2 t1))
 426   (assert-t-t (subtypep `(not ,t2) `(not ,t1)))
 427   (assert-nil-t (subtypep `(not ,t1) `(not ,t2))))
 428 \f
 429 ;;; not easily visible to user code, but this used to be very
 430 ;;; confusing.
 431 (with-test (:name (:ctor :typep-function))
 432   (assert (eval '(typep (sb-pcl::ensure-ctor
 433                          (list 'sb-pcl::ctor (gensym)) nil nil nil)
 434                         'function))))
 435 (with-test (:name (:ctor :functionp))
 436   (assert (functionp (sb-pcl::ensure-ctor
 437                       (list 'sb-pcl::ctor (gensym)) nil nil nil))))
 438 ;;; some new (2008-10-03) ways of going wrong...
 439 (with-test (:name (:ctor-allocate-instance :typep-function))
 440   (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor))
 441                         'function))))
 442 (with-test (:name (:ctor-allocate-instance :functionp))
 443   (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor)))))
 444 \f
 445 ;;; from PFD ansi-tests
 446 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
 447                        (integer -234496 215373))
 448                  integer))
 449       (t2 '(cons (cons (cons integer integer)
 450                        (integer -234496 215373))
 451                  t)))
 452   (assert (null (values (subtypep `(not ,t2) `(not ,t1))))))
 453 \f
 454 (defstruct misc-629a)
 455 (defclass misc-629b () ())
 456 (defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
 457
 458 (assert (typep (make-misc-629a) 'sb-kernel:instance))
 459 (assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
 460 (assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
 461                         nil))
 462 (let ((misc-629a (make-misc-629a)))
 463   (assert-t-t (subtypep `(member ,misc-629a)
 464                         `(and (member ,misc-629a) sb-kernel:instance)))
 465   (assert-t-t (subtypep `(and (member ,misc-629a)
 466                           sb-kernel:funcallable-instance)
 467                         nil)))
 468
 469 (assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
 470 (assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
 471                       'sb-kernel:instance))
 472 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
 473                           sb-kernel:instance)
 474                         nil))
 475 (let ((misc-629b (make-instance 'misc-629b)))
 476   (assert-t-t (subtypep `(member ,misc-629b)
 477                         `(and (member ,misc-629b) sb-kernel:instance)))
 478   (assert-t-t (subtypep `(and (member ,misc-629b)
 479                           sb-kernel:funcallable-instance)
 480                         nil)))
 481
 482 (assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
 483 (assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
 484                       'sb-kernel:funcallable-instance))
 485 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
 486                           sb-kernel:funcallable-instance)
 487                         nil))
 488 (let ((misc-629c (make-instance 'misc-629c)))
 489   (assert-t-t (subtypep `(member ,misc-629c)
 490                         `(and (member ,misc-629c)
 491                           sb-kernel:funcallable-instance)))
 492   (assert-t-t (subtypep `(and (member ,misc-629c)
 493                           sb-kernel:instance)
 494                         nil)))
 495 \f
 496 ;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
 497 ;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
 498 ;;; subclass, so SUBTYPEP must be prepared to deal with
 499 (defclass ansi-tests-defclass1 () ())
 500 (defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
 501 (make-instance 'ansi-tests-defclass1)
 502 (assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
 503 \f
 504 ;;; so was this
 505 (let ((class (eval '(defclass to-be-type-ofed () ()))))
 506   (setf (find-class 'to-be-type-ofed) nil)
 507   (assert (eq (type-of (make-instance class)) class)))
 508 \f
 509 ;;; accuracy of CONS :SIMPLE-TYPE-=
 510 (deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
 511 (deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
 512
 513 (multiple-value-bind (ok win)
 514     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 515                      (sb-kernel:specifier-type '(cons goldbach1 integer)))
 516   (assert ok)
 517   (assert win))
 518
 519 ;; See FIXME in type method for CONS :SIMPLE-TYPE-=
 520 #+nil
 521 (multiple-value-bind (ok win)
 522     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 523                      (sb-kernel:specifier-type '(cons goldbach1 single-float)))
 524   (assert (not ok))
 525   (assert win))
 526
 527 (multiple-value-bind (ok win)
 528     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 529                      (sb-kernel:specifier-type '(cons goldbach2 single-float)))
 530   (assert (not ok))
 531   (assert (not win)))
 532
 533 ;;; precise unions of array types (was bug 306a)
 534 (defun bug-306-a (x)
 535   (declare (optimize speed)
 536            (type (or (array cons) (array vector)) x))
 537   (elt (aref x 0) 0))
 538 (assert (= 0 (bug-306-a #((0)))))
 539 \f
 540 ;;; FUNCALLABLE-INSTANCE is a subtype of function.
 541 (assert-t-t (subtypep '(and pathname function) nil))
 542 (assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
 543 (assert (not (subtypep '(and stream function) nil)))
 544 (assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
 545 (assert (not (subtypep '(and function standard-object) nil)))
 546 (assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
 547
 548 ;;; also, intersections of classes with INSTANCE should not be too
 549 ;;; general
 550 (assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
 551 (assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
 552 \f
 553 (assert-t-t
 554  (subtypep '(or simple-array simple-string) '(or simple-string simple-array)))
 555 (assert-t-t
 556  (subtypep '(or simple-string simple-array) '(or simple-array simple-string)))
 557 (assert-t-t
 558  (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
 559            '(or fixnum vector end-of-file parse-error fixnum simple-string)))
 560
 561 #+sb-eval
 562 (assert-t-t
 563  (subtypep '(and function (not compiled-function)
 564              (not sb-eval:interpreted-function))
 565            nil))
 566
 567 ;;; weakening of union type checks
 568 (defun weaken-union-1 (x)
 569   (declare (optimize speed))
 570   (car x))
 571 (multiple-value-bind (res err)
 572     (ignore-errors (weaken-union-1 "askdjhasdkj"))
 573   (assert (not res))
 574   (assert (typep err 'type-error)))
 575 (defun weaken-union-2 (x)
 576   (declare (optimize speed)
 577            (type (or cons fixnum) x))
 578   (etypecase x
 579     (fixnum x)
 580     (cons
 581      (setf (car x) 3)
 582      x)))
 583 (multiple-value-bind (res err)
 584     (ignore-errors (weaken-union-2 "asdkahsdkhj"))
 585   (assert (not res))
 586   (assert (typep err 'type-error))
 587   (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
 588               (equal '(or fixnum cons) (type-error-expected-type err)))))
 589
 590 ;;; TYPEXPAND & Co
 591
 592 (deftype a-deftype (arg)
 593   `(cons (eql ,arg) *))
 594
 595 (deftype another-deftype (arg)
 596   `(a-deftype ,arg))
 597
 598 (deftype list-of-length (length &optional element-type)
 599   (assert (not (minusp length)))
 600   (if (zerop length)
 601       'null
 602       `(cons ,element-type (list-of-length ,(1- length) ,element-type))))
 603
 604 (with-test (:name :typexpand-1)
 605   (multiple-value-bind (expansion-1 expandedp-1)
 606       (sb-ext:typexpand-1 '(another-deftype symbol))
 607     (assert expandedp-1)
 608     (assert (equal expansion-1 '(a-deftype symbol)))
 609     (multiple-value-bind (expansion-2 expandedp-2)
 610         (sb-ext:typexpand-1 expansion-1)
 611       (assert expandedp-2)
 612       (assert (equal expansion-2 '(cons (eql symbol) *)))
 613       (multiple-value-bind (expansion-3 expandedp-3)
 614           (sb-ext:typexpand-1 expansion-2)
 615         (assert (not expandedp-3))
 616         (assert (eq expansion-2 expansion-3))))))
 617
 618 (with-test (:name :typexpand.1)
 619   (multiple-value-bind (expansion-1 expandedp-1)
 620       (sb-ext:typexpand '(another-deftype symbol))
 621     (assert expandedp-1)
 622     (assert (equal expansion-1 '(cons (eql symbol) *)))
 623     (multiple-value-bind (expansion-2 expandedp-2)
 624         (sb-ext:typexpand expansion-1)
 625       (assert (not expandedp-2))
 626       (assert (eq expansion-1 expansion-2)))))
 627
 628 (with-test (:name :typexpand.2)
 629   (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum))
 630                  '(cons fixnum (list-of-length 2 fixnum)))))
 631
 632 (with-test (:name :typexpand-all)
 633   (assert (equal (sb-ext:typexpand-all '(list-of-length 3))
 634                  '(cons t (cons t (cons t null)))))
 635   (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum))
 636                  '(cons fixnum (cons fixnum (cons fixnum null))))))
 637
 638 (defclass a-deftype () ())
 639
 640 (with-test (:name (:typexpand-1 :after-type-redefinition-to-class))
 641   (multiple-value-bind (expansion expandedp)
 642       (sb-ext:typexpand-1 '#1=(a-deftype symbol))
 643     (assert (not expandedp))
 644     (assert (eq expansion '#1#))))
 645
 646
 647 (with-test (:name :defined-type-name-p)
 648   (assert (not (sb-ext:defined-type-name-p '#:foo)))
 649   (assert (sb-ext:defined-type-name-p 'a-deftype))
 650   (assert (sb-ext:defined-type-name-p 'structure-foo1))
 651   (assert (sb-ext:defined-type-name-p 'structure-class-foo1))
 652   (assert (sb-ext:defined-type-name-p 'standard-class-foo1))
 653   (assert (sb-ext:defined-type-name-p 'condition-foo1))
 654   (dolist (prim-type '(t nil fixnum cons atom))
 655     (assert (sb-ext:defined-type-name-p prim-type))))
 656
 657
 658 (with-test (:name :valid-type-specifier-p)
 659   (macrolet ((yes (form) `(assert ,form))
 660              (no  (form) `(assert (not ,form))))
 661     (no  (sb-ext:valid-type-specifier-p '(cons #(frob) *)))
 662     (no  (sb-ext:valid-type-specifier-p 'list-of-length))
 663     (no  (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x))))
 664     (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum)))
 665
 666     (yes (sb-ext:valid-type-specifier-p 'structure-foo1))
 667     (no  (sb-ext:valid-type-specifier-p '(structure-foo1 x)))
 668     (yes (sb-ext:valid-type-specifier-p 'condition-foo1))
 669     (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1))
 670     (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1))
 671
 672     (yes (sb-ext:valid-type-specifier-p 'readtable))
 673     (no  (sb-ext:valid-type-specifier-p '(readtable)))
 674     (no  (sb-ext:valid-type-specifier-p '(readtable x)))
 675
 676     (yes (sb-ext:valid-type-specifier-p '(values)))
 677     (no  (sb-ext:valid-type-specifier-p 'values))
 678     (yes (sb-ext:valid-type-specifier-p '(and)))
 679     (no  (sb-ext:valid-type-specifier-p 'and))))
 680
 681 (with-test (:name (:valid-type-specifier-p :introspection-test))
 682   (flet ((map-functions (fn)
 683            (do-all-symbols (s)
 684              (when (and (fboundp s)
 685                         (not (macro-function s))
 686                         (not (special-operator-p s)))
 687                (funcall fn s)))))
 688     (map-functions
 689      #'(lambda (s)
 690          (let* ((fun   (sb-kernel:%fun-fun (fdefinition s)))
 691                 (ftype (sb-kernel:%simple-fun-type fun)))
 692            (unless (sb-ext:valid-type-specifier-p ftype)
 693              (format *error-output*
 694                      "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>"
 695                      'sb-ext:valid-type-specifier-p
 696                      s
 697                      ftype )
 698              (error "FAILURE")))))))
 699
 700 (with-test (:name (:bug-309128 1))
 701   (let* ((s (gensym))
 702          (t1 (sb-kernel:specifier-type s)))
 703     (eval `(defstruct ,s))
 704     (multiple-value-bind (ok sure)
 705         (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
 706       (assert (and ok sure)))))
 707
 708 (with-test (:name (:bug-309128 2))
 709   (let* ((s (gensym))
 710          (t1 (sb-kernel:specifier-type s)))
 711     (eval `(defstruct ,s))
 712     (multiple-value-bind (ok sure)
 713         (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
 714       (assert (and ok sure)))))
 715
 716 (with-test (:name (:bug-309128 3))
 717   (let* ((s (gensym))
 718          (t1 (sb-kernel:specifier-type s))
 719          (s2 (gensym))
 720          (t2 (sb-kernel:specifier-type s2)))
 721     (eval `(deftype ,s2 () ',s))
 722     (eval `(defstruct ,s))
 723     (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
 724       (assert (and ok sure)))))
 725
 726 (with-test (:name :unknown-type-not=-for-sure)
 727   (let* ((type (gensym "FOO"))
 728          (spec1 (sb-kernel:specifier-type `(vector ,type)))
 729          (spec2 (sb-kernel:specifier-type `(vector single-float))))
 730     (eval `(deftype ,type () 'double-float))
 731     (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2)
 732       (assert (not ok))
 733       (assert sure))))
 734
 735 (defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ())
 736 (defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ())
 737 (defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ())
 738 (defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ())
 739 (with-test (:name (:subtypep :forward-referenced-classes))
 740   (flet ((test (c1 c2 b1 b2)
 741            (multiple-value-bind (x1 x2) (subtypep c1 c2)
 742              (unless (and (eq b1 x1) (eq b2 x2))
 743                (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S"
 744                       c1 c2 x1 x2 b1 b2)))))
 745     (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t)
 746     (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t)
 747     (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil)
 748     (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil)
 749
 750     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t)
 751     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t)
 752     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil)
 753     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil)
 754
 755     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t)
 756     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t)
 757     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil)
 758     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil)
 759
 760     (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil)
 761     (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t)))
 762
 763 ;;; success