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-error (upgraded-array-element-type 'some-undef-type))
  84 (assert (eql (upgraded-array-element-type t) t))
  85 (assert-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-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-error (typep 11 'and))
 107 (assert-error (typep 11 'or))
 108 (assert-error (typep 11 'member))
 109 (assert-error (typep 11 'values))
 110 (assert-error (typep 11 'eql))
 111 (assert-error (typep 11 'satisfies))
 112 (assert-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-error (subtypep 'fixnum '(fixnum 1)))
 116 (assert-error (subtypep 'class '(list)))
 117 (assert-error (subtypep 'foo '(ratio 1/2 3/2)))
 118 (assert-error (subtypep 'character '(character 10)))
 119 #+nil ; doesn't yet work on PCL-derived internal types
 120 (assert-error (subtypep 'lisp '(class)))
 121 #+nil
 122 (assert-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
 248 (with-test (:name :member-type-and-numeric)
 249   ;; (MEMBER 0s0 -s0) used to appear to parse correctly,
 250   ;; but it didn't because MAKE-MEMBER-TYPE returned a union type
 251   ;; (OR (MEMBER 0.0) (SINGLE-FLOAT 0.0 0.0)) which was further reduced
 252   ;; to just the numeric type, being a supertype of the singleton.
 253   ;; The parsing problem became evident when any other member was added in,
 254   ;; because in that case the member type is not a subtype of the numeric.
 255   (let* ((x (sb-kernel:specifier-type '(member 0s0 foo -0s0)))
 256          (m (find-if #'sb-kernel:member-type-p (sb-kernel:union-type-types x))))
 257     (assert (equal (sb-kernel:member-type-members m) '(foo)))))
 258
 259 \f
 260 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 261 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 262 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 263 ;;;; They look nice but they're nontrivial enough that it's not
 264 ;;;; obvious from inspection that everything is OK. Let's make sure
 265 ;;;; that things still basically work.
 266
 267 ;; structure type tests setup
 268 (defstruct structure-foo1)
 269 (defstruct (structure-foo2 (:include structure-foo1))
 270   x)
 271 (defstruct (structure-foo3 (:include structure-foo2)))
 272 (defstruct (structure-foo4 (:include structure-foo3))
 273   y z)
 274
 275 ;; structure-class tests setup
 276 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 277 (defclass structure-class-foo2 (structure-class-foo1)
 278   () (:metaclass cl:structure-class))
 279 (defclass structure-class-foo3 (structure-class-foo2)
 280   () (:metaclass cl:structure-class))
 281 (defclass structure-class-foo4 (structure-class-foo3)
 282   () (:metaclass cl:structure-class))
 283
 284 ;; standard-class tests setup
 285 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 286 (defclass standard-class-foo2 (standard-class-foo1)
 287   () (:metaclass cl:standard-class))
 288 (defclass standard-class-foo3 (standard-class-foo2)
 289   () (:metaclass cl:standard-class))
 290 (defclass standard-class-foo4 (standard-class-foo3)
 291   () (:metaclass cl:standard-class))
 292
 293 ;; condition tests setup
 294 (define-condition condition-foo1 (condition) ())
 295 (define-condition condition-foo2 (condition-foo1) ())
 296 (define-condition condition-foo3 (condition-foo2) ())
 297 (define-condition condition-foo4 (condition-foo3) ())
 298
 299 ;;; inline type tests
 300 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 301 (defparameter *tests-of-inline-type-tests*
 302   '(progn
 303
 304      ;; structure type tests
 305      (assert (typep (make-structure-foo3) 'structure-foo2))
 306      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 307      (assert (typep (nth-value 1
 308                                (ignore-errors (structure-foo2-x
 309                                                (make-structure-foo1))))
 310                     'type-error))
 311      (assert (null (ignore-errors
 312                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 313
 314      ;; structure-class tests
 315      (assert (typep (make-instance 'structure-class-foo3)
 316                     'structure-class-foo2))
 317      (assert (not (typep (make-instance 'structure-class-foo1)
 318                          'structure-class-foo4)))
 319      (assert (null (ignore-errors
 320                      (setf (slot-value (make-instance 'structure-class-foo1)
 321                                        'x)
 322                            11))))
 323
 324      ;; standard-class tests
 325      (assert (typep (make-instance 'standard-class-foo3)
 326                     'standard-class-foo2))
 327      (assert (not (typep (make-instance 'standard-class-foo1)
 328                          'standard-class-foo4)))
 329      (assert (null (ignore-errors
 330                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 331                            11))))
 332
 333      ;; condition tests
 334      (assert (typep (make-condition 'condition-foo3)
 335                     'condition-foo2))
 336      (assert (not (typep (make-condition 'condition-foo1)
 337                          'condition-foo4)))
 338      (assert (null (ignore-errors
 339                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 340                            11))))
 341      (assert (subtypep 'error 't))
 342      (assert (subtypep 'simple-condition 'condition))
 343      (assert (subtypep 'simple-error 'simple-condition))
 344      (assert (subtypep 'simple-error 'error))
 345      (assert (not (subtypep 'condition 'simple-condition)))
 346      (assert (not (subtypep 'error 'simple-error)))
 347      (assert (eq (car (sb-pcl:class-direct-superclasses
 348                        (find-class 'simple-condition)))
 349                  (find-class 'condition)))
 350
 351      #+nil ; doesn't look like a good test
 352      (let ((subclasses (mapcar #'find-class
 353                                '(simple-type-error
 354                                  simple-error
 355                                  simple-warning
 356                                  sb-int:simple-file-error
 357                                  sb-int:simple-style-warning))))
 358        (assert (null (set-difference
 359                       (sb-pcl:class-direct-subclasses (find-class
 360                                                        'simple-condition))
 361                       subclasses))))
 362
 363      ;; precedence lists
 364      (assert (equal (sb-pcl:class-precedence-list
 365                      (find-class 'simple-condition))
 366                     (mapcar #'find-class '(simple-condition
 367                                            condition
 368                                            sb-pcl::slot-object
 369                                            t))))
 370
 371      ;; stream classes
 372      (assert (equal (sb-pcl:class-direct-superclasses (find-class
 373                                                        'fundamental-stream))
 374                     (mapcar #'find-class '(standard-object stream))))
 375      (assert (null (set-difference
 376                     (sb-pcl:class-direct-subclasses (find-class
 377                                                      'fundamental-stream))
 378                     (mapcar #'find-class '(fundamental-binary-stream
 379                                            fundamental-character-stream
 380                                            fundamental-output-stream
 381                                            fundamental-input-stream)))))
 382      (assert (equal (sb-pcl:class-precedence-list (find-class
 383                                                    'fundamental-stream))
 384                     (mapcar #'find-class '(fundamental-stream
 385                                            standard-object
 386                                            sb-pcl::slot-object
 387                                            stream
 388                                            t))))
 389      (assert (equal (sb-pcl:class-precedence-list (find-class
 390                                                    'fundamental-stream))
 391                     (mapcar #'find-class '(fundamental-stream
 392                                            standard-object
 393                                            sb-pcl::slot-object stream
 394                                            t))))
 395      (assert (subtypep (find-class 'stream) (find-class t)))
 396      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 397      (assert (not (subtypep 'stream 'fundamental-stream)))))
 398 ;;; Test under the interpreter.
 399 (eval *tests-of-inline-type-tests*)
 400 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 401 ;;; Test under the compiler.
 402 (defun tests-of-inline-type-tests ()
 403   #.*tests-of-inline-type-tests*)
 404 (tests-of-inline-type-tests)
 405 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 406 \f
 407 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 408 (defclass superclass () ())
 409 (defclass maybe-subclass () ())
 410 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 411 (defclass maybe-subclass (superclass) ())
 412 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 413 (defclass maybe-subclass () ())
 414 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 415 \f
 416 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
 417 ;;; specialized on some as-yet-undefined type which would cause this
 418 ;;; program to fail (bugs #123 and #165). Verify that it doesn't.
 419 (defun foo (x)
 420   (declare (type (vector bar) x))
 421   (aref x 1))
 422 (deftype bar () 'single-float)
 423 (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
 424              0.0f0))
 425
 426 ;;; bug 260a
 427 (assert-t-t
 428  (let* ((s (gensym))
 429         (t1 (sb-kernel:specifier-type s)))
 430    (eval `(defstruct ,s))
 431    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
 432
 433 ;;; bug found by PFD's random subtypep tester
 434 (let ((t1 '(cons rational (cons (not rational) (cons integer t))))
 435       (t2 '(not (cons (integer 0 1) (cons single-float long-float)))))
 436   (assert-t-t (subtypep t1 t2))
 437   (assert-nil-t (subtypep t2 t1))
 438   (assert-t-t (subtypep `(not ,t2) `(not ,t1)))
 439   (assert-nil-t (subtypep `(not ,t1) `(not ,t2))))
 440 \f
 441 ;;; not easily visible to user code, but this used to be very
 442 ;;; confusing.
 443 (with-test (:name (:ctor :typep-function))
 444   (assert (eval '(typep (sb-pcl::ensure-ctor
 445                          (list 'sb-pcl::ctor (gensym)) nil nil nil)
 446                         'function))))
 447 (with-test (:name (:ctor :functionp))
 448   (assert (functionp (sb-pcl::ensure-ctor
 449                       (list 'sb-pcl::ctor (gensym)) nil nil nil))))
 450 ;;; some new (2008-10-03) ways of going wrong...
 451 (with-test (:name (:ctor-allocate-instance :typep-function))
 452   (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor))
 453                         'function))))
 454 (with-test (:name (:ctor-allocate-instance :functionp))
 455   (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor)))))
 456 \f
 457 ;;; from PFD ansi-tests
 458 (with-test (:name (:subtypep :complex-cons-type))
 459  (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
 460                    (integer -234496 215373))
 461              integer))
 462        (t2 '(cons (cons (cons integer integer)
 463                    (integer -234496 215373))
 464              t)))
 465    (assert (null (values (subtypep `(not ,t2) `(not ,t1)))))))
 466 \f
 467 (defstruct misc-629a)
 468 (defclass misc-629b () ())
 469 (defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
 470
 471 (assert (typep (make-misc-629a) 'sb-kernel:instance))
 472 (assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
 473 (assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
 474                         nil))
 475 (let ((misc-629a (make-misc-629a)))
 476   (assert-t-t (subtypep `(member ,misc-629a)
 477                         `(and (member ,misc-629a) sb-kernel:instance)))
 478   (assert-t-t (subtypep `(and (member ,misc-629a)
 479                           sb-kernel:funcallable-instance)
 480                         nil)))
 481
 482 (assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
 483 (assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
 484                       'sb-kernel:instance))
 485 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
 486                           sb-kernel:instance)
 487                         nil))
 488 (let ((misc-629b (make-instance 'misc-629b)))
 489   (assert-t-t (subtypep `(member ,misc-629b)
 490                         `(and (member ,misc-629b) sb-kernel:instance)))
 491   (assert-t-t (subtypep `(and (member ,misc-629b)
 492                           sb-kernel:funcallable-instance)
 493                         nil)))
 494
 495 (assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
 496 (assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
 497                       'sb-kernel:funcallable-instance))
 498 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
 499                           sb-kernel:funcallable-instance)
 500                         nil))
 501 (let ((misc-629c (make-instance 'misc-629c)))
 502   (assert-t-t (subtypep `(member ,misc-629c)
 503                         `(and (member ,misc-629c)
 504                           sb-kernel:funcallable-instance)))
 505   (assert-t-t (subtypep `(and (member ,misc-629c)
 506                           sb-kernel:instance)
 507                         nil)))
 508 \f
 509 ;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
 510 ;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
 511 ;;; subclass, so SUBTYPEP must be prepared to deal with
 512 (defclass ansi-tests-defclass1 () ())
 513 (defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
 514 (make-instance 'ansi-tests-defclass1)
 515 (assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
 516 \f
 517 ;;; so was this
 518 (let ((class (eval '(defclass to-be-type-ofed () ()))))
 519   (setf (find-class 'to-be-type-ofed) nil)
 520   (assert (eq (type-of (make-instance class)) class)))
 521 \f
 522 ;;; accuracy of CONS :SIMPLE-TYPE-=
 523 (deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
 524 (deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
 525
 526 (multiple-value-bind (ok win)
 527     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 528                      (sb-kernel:specifier-type '(cons goldbach1 integer)))
 529   (assert ok)
 530   (assert win))
 531
 532 ;; See FIXME in type method for CONS :SIMPLE-TYPE-=
 533 #+nil
 534 (multiple-value-bind (ok win)
 535     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 536                      (sb-kernel:specifier-type '(cons goldbach1 single-float)))
 537   (assert (not ok))
 538   (assert win))
 539
 540 (multiple-value-bind (ok win)
 541     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 542                      (sb-kernel:specifier-type '(cons goldbach2 single-float)))
 543   (assert (not ok))
 544   (assert (not win)))
 545
 546 ;;; precise unions of array types (was bug 306a)
 547 (defun bug-306-a (x)
 548   (declare (optimize speed)
 549            (type (or (array cons) (array vector)) x))
 550   (elt (aref x 0) 0))
 551 (assert (= 0 (bug-306-a #((0)))))
 552 \f
 553 ;;; FUNCALLABLE-INSTANCE is a subtype of function.
 554 (assert-t-t (subtypep '(and pathname function) nil))
 555 (assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
 556 (assert (not (subtypep '(and stream function) nil)))
 557 (assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
 558 (assert (not (subtypep '(and function standard-object) nil)))
 559 (assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
 560
 561 ;;; also, intersections of classes with INSTANCE should not be too
 562 ;;; general
 563 (assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
 564 (assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
 565 \f
 566 (assert-t-t
 567  (subtypep '(or simple-array simple-string) '(or simple-string simple-array)))
 568 (assert-t-t
 569  (subtypep '(or simple-string simple-array) '(or simple-array simple-string)))
 570 (assert-t-t
 571  (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
 572            '(or fixnum vector end-of-file parse-error fixnum simple-string)))
 573
 574 #+sb-eval
 575 (assert-t-t
 576  (subtypep '(and function (not compiled-function)
 577              (not sb-eval:interpreted-function))
 578            nil))
 579 #+sb-fasteval
 580 (assert-t-t
 581  (subtypep '(and function (not compiled-function)
 582              (not sb-interpreter:interpreted-function))
 583            nil))
 584
 585 ;;; weakening of union type checks
 586 (defun weaken-union-1 (x)
 587   (declare (optimize speed))
 588   (car x))
 589 (multiple-value-bind (res err)
 590     (ignore-errors (weaken-union-1 "askdjhasdkj"))
 591   (assert (not res))
 592   (assert (typep err 'type-error)))
 593 (defun weaken-union-2 (x)
 594   (declare (optimize speed)
 595            (type (or cons fixnum) x))
 596   (etypecase x
 597     (fixnum x)
 598     (cons
 599      (setf (car x) 3)
 600      x)))
 601 (multiple-value-bind (res err)
 602     (ignore-errors (weaken-union-2 "asdkahsdkhj"))
 603   (assert (not res))
 604   (assert (typep err 'type-error))
 605   (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
 606               (equal '(or fixnum cons) (type-error-expected-type err)))))
 607
 608 ;;; TYPEXPAND & Co
 609
 610 (deftype a-deftype (arg)
 611   `(cons (eql ,arg) *))
 612
 613 (deftype another-deftype (arg)
 614   `(a-deftype ,arg))
 615
 616 (deftype list-of-length (length &optional element-type)
 617   (assert (not (minusp length)))
 618   (if (zerop length)
 619       'null
 620       `(cons ,element-type (list-of-length ,(1- length) ,element-type))))
 621
 622 (with-test (:name :typexpand-1)
 623   (multiple-value-bind (expansion-1 expandedp-1)
 624       (sb-ext:typexpand-1 '(another-deftype symbol))
 625     (assert expandedp-1)
 626     (assert (equal expansion-1 '(a-deftype symbol)))
 627     (multiple-value-bind (expansion-2 expandedp-2)
 628         (sb-ext:typexpand-1 expansion-1)
 629       (assert expandedp-2)
 630       (assert (equal expansion-2 '(cons (eql symbol) *)))
 631       (multiple-value-bind (expansion-3 expandedp-3)
 632           (sb-ext:typexpand-1 expansion-2)
 633         (assert (not expandedp-3))
 634         (assert (eq expansion-2 expansion-3))))))
 635
 636 (with-test (:name :typexpand.1)
 637   (multiple-value-bind (expansion-1 expandedp-1)
 638       (sb-ext:typexpand '(another-deftype symbol))
 639     (assert expandedp-1)
 640     (assert (equal expansion-1 '(cons (eql symbol) *)))
 641     (multiple-value-bind (expansion-2 expandedp-2)
 642         (sb-ext:typexpand expansion-1)
 643       (assert (not expandedp-2))
 644       (assert (eq expansion-1 expansion-2)))))
 645
 646 (with-test (:name :typexpand.2)
 647   (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum))
 648                  '(cons fixnum (list-of-length 2 fixnum)))))
 649
 650 (with-test (:name :typexpand-all)
 651   (assert (equal (sb-ext:typexpand-all '(list-of-length 3))
 652                  '(cons t (cons t (cons t null)))))
 653   (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum))
 654                  '(cons fixnum (cons fixnum (cons fixnum null))))))
 655
 656 (defclass a-deftype () ())
 657
 658 (with-test (:name (:typexpand-1 :after-type-redefinition-to-class))
 659   (multiple-value-bind (expansion expandedp)
 660       (sb-ext:typexpand-1 '#1=(a-deftype symbol))
 661     (assert (not expandedp))
 662     (assert (eq expansion '#1#))))
 663
 664
 665 (with-test (:name :defined-type-name-p)
 666   (assert (not (sb-ext:defined-type-name-p '#:foo)))
 667   (assert (sb-ext:defined-type-name-p 'a-deftype))
 668   (assert (sb-ext:defined-type-name-p 'structure-foo1))
 669   (assert (sb-ext:defined-type-name-p 'structure-class-foo1))
 670   (assert (sb-ext:defined-type-name-p 'standard-class-foo1))
 671   (assert (sb-ext:defined-type-name-p 'condition-foo1))
 672   (dolist (prim-type '(t nil fixnum cons atom))
 673     (assert (sb-ext:defined-type-name-p prim-type))))
 674
 675
 676 (with-test (:name :valid-type-specifier-p)
 677   (macrolet ((yes (form) `(assert ,form))
 678              (no  (form) `(assert (not ,form))))
 679     (no  (sb-ext:valid-type-specifier-p '(cons #(frob) *)))
 680     (no  (sb-ext:valid-type-specifier-p 'list-of-length))
 681     (no  (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x))))
 682     (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum)))
 683
 684     (yes (sb-ext:valid-type-specifier-p 'structure-foo1))
 685     (no  (sb-ext:valid-type-specifier-p '(structure-foo1 x)))
 686     (yes (sb-ext:valid-type-specifier-p 'condition-foo1))
 687     (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1))
 688     (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1))
 689
 690     (yes (sb-ext:valid-type-specifier-p 'readtable))
 691     (no  (sb-ext:valid-type-specifier-p '(readtable)))
 692     (no  (sb-ext:valid-type-specifier-p '(readtable x)))
 693
 694     (yes (sb-ext:valid-type-specifier-p '(values)))
 695     (no  (sb-ext:valid-type-specifier-p 'values))
 696     (yes (sb-ext:valid-type-specifier-p '(and)))
 697     (no  (sb-ext:valid-type-specifier-p 'and))))
 698
 699 (with-test (:name (:valid-type-specifier-p :introspection-test))
 700   (flet ((map-functions (fn)
 701            (do-all-symbols (s)
 702              (when (and (fboundp s)
 703                         (not (macro-function s))
 704                         (not (special-operator-p s)))
 705                (funcall fn s)))))
 706     (map-functions
 707      #'(lambda (s)
 708          (let* ((fun   (sb-kernel:%fun-fun (fdefinition s)))
 709                 (ftype (sb-kernel:%simple-fun-type fun)))
 710            (unless (sb-ext:valid-type-specifier-p ftype)
 711              (format *error-output*
 712                      "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>"
 713                      'sb-ext:valid-type-specifier-p
 714                      s
 715                      ftype )
 716              (error "FAILURE")))))))
 717
 718 (with-test (:name (:bug-309128 1))
 719   (let* ((s (gensym))
 720          (t1 (sb-kernel:specifier-type s)))
 721     (eval `(defstruct ,s))
 722     (multiple-value-bind (ok sure)
 723         (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
 724       (assert (and ok sure)))))
 725
 726 (with-test (:name (:bug-309128 2))
 727   (let* ((s (gensym))
 728          (t1 (sb-kernel:specifier-type s)))
 729     (eval `(defstruct ,s))
 730     (multiple-value-bind (ok sure)
 731         (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
 732       (assert (and ok sure)))))
 733
 734 (with-test (:name (:bug-309128 3))
 735   (let* ((s (gensym))
 736          (t1 (sb-kernel:specifier-type s))
 737          (s2 (gensym))
 738          (t2 (sb-kernel:specifier-type s2)))
 739     (eval `(deftype ,s2 () ',s))
 740     (eval `(defstruct ,s))
 741     (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
 742       (assert (and ok sure)))))
 743
 744 (with-test (:name :unknown-type-not=-for-sure)
 745   (let* ((type (gensym "FOO"))
 746          (spec1 (sb-kernel:specifier-type `(vector ,type)))
 747          (spec2 (sb-kernel:specifier-type `(vector single-float))))
 748     (eval `(deftype ,type () 'double-float))
 749     (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2)
 750       (assert (not ok))
 751       (assert sure))))
 752
 753 (defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ())
 754 (defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ())
 755 (defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ())
 756 (defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ())
 757 (with-test (:name (:subtypep :forward-referenced-classes))
 758   (flet ((test (c1 c2 b1 b2)
 759            (multiple-value-bind (x1 x2) (subtypep c1 c2)
 760              (unless (and (eq b1 x1) (eq b2 x2))
 761                (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S"
 762                       c1 c2 x1 x2 b1 b2)))))
 763     (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t)
 764     (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t)
 765     (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil)
 766     (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil)
 767
 768     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t)
 769     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t)
 770     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil)
 771     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil)
 772
 773     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t)
 774     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t)
 775     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil)
 776     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil)
 777
 778     (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil)
 779     (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t)))
 780 \f
 781 ;;; Array type unions have some tricky semantics.
 782
 783 ;; borrowed from 'info.impure.lisp' - FIXME: put in test-util
 784 ;; and make it accept with either lists or vectors.
 785 (defun shuffle (list)
 786   (let ((vector (coerce list 'vector)))
 787     (loop for lim from (1- (length vector)) downto 0
 788           for chosen = (random (1+ lim))
 789           do (rotatef (aref vector chosen) (aref vector lim)))
 790     (coerce vector 'list)))
 791
 792 (macrolet
 793     ((disunity-test (name type-specifier-1 type-specifier-2)
 794        `(with-test (:name ,name)
 795           (let ((type1 (sb-kernel:specifier-type ',type-specifier-1))
 796                 (type2 (sb-kernel:specifier-type ',type-specifier-2)))
 797             (assert (null (sb-kernel::%type-union2 type1 type2)))
 798             (assert (null (sb-kernel::%type-union2 type2 type1))))))
 799      (unity-test (name type-specifier-1 type-specifier-2 result-type-specifier)
 800        `(with-test (:name ,name)
 801           (let* ((type1 (sb-kernel:specifier-type ',type-specifier-1))
 802                  (type2 (sb-kernel:specifier-type ',type-specifier-2))
 803                  (rtype (sb-kernel:specifier-type ',result-type-specifier))
 804                  (res1 (sb-kernel::%type-union2 type1 type2))
 805                  (res2 (sb-kernel::%type-union2 type2 type1)))
 806             ;; The (ARRAY :SIMPLE-=) type method doesn't always (or
 807             ;; even usually) check the element type, preferring
 808             ;; instead to check the upgraded element type.  Therefore,
 809             ;; check the element types ourselves.
 810             (assert (and (sb-kernel:type= res1 rtype)
 811                          (sb-kernel:type=
 812                           (sb-kernel:array-type-element-type res1)
 813                           (sb-kernel:array-type-element-type rtype))))
 814             (assert (and (sb-kernel:type= res2 rtype)
 815                          (sb-kernel:type=
 816                           (sb-kernel:array-type-element-type res2)
 817                           (sb-kernel:array-type-element-type rtype))))))))
 818
 819   (unity-test (:array-type-union :basic)
 820               array
 821               array
 822               array)
 823
 824   (unity-test (:array-type-union :dimensional-compatability :wild)
 825               (array * *)
 826               (array * (* * *))
 827               (array * *))
 828
 829   (disunity-test (:array-type-union :dimensional-compatability :incompatible 1)
 830                  (array * (* *))
 831                  (array * (* * *)))
 832
 833   (disunity-test (:array-type-union :dimensional-compatability :incompatible 2)
 834                  (array * (* 1 *))
 835                  (array * (* 2 *)))
 836
 837   (disunity-test (:array-type-union :dimensional-unity :only-one-dimension-per-union)
 838               (array * (2 *))
 839               (array * (* 3)))
 840
 841   (unity-test (:array-type-union :complexp-unity :moves-towards-maybe)
 842               simple-array
 843               (and array (not simple-array))
 844               array)
 845
 846   (disunity-test (:array-type-union :complexp-and-dimensions-dont-unite 1)
 847                  (simple-array * (* *))
 848                  (and (array * (* 3)) (not simple-array)))
 849
 850   (disunity-test (:array-type-union :complexp-and-dimensions-dont-unite 2)
 851               (simple-array * (* *))
 852               (array * (* 3)))
 853
 854   (unity-test (:array-type-union :element-subtypes :unite-within-saetp)
 855               (array (integer 15 27))
 856               (array (integer 15 26))
 857               (array (integer 15 27)))
 858
 859   (disunity-test (:array-type-union :element-subtypes :dont-unite-across-saetp)
 860                  (array (unsigned-byte 7))
 861                  (array (unsigned-byte 3)))
 862
 863   (disunity-test (:array-type-union :disjoint-element-types :dont-unite)
 864                  (array (integer 15 27))
 865                  (array (integer 17 30)))
 866
 867   (unity-test (:array-type-union :wild-element-type :unites)
 868               array
 869               (array (unsigned-byte 8))
 870               array)
 871
 872   (disunity-test (:array-type-union :element-type-and-dimensions-dont-unite)
 873                  (array (unsigned-byte 8))
 874                  (array * (* *)))
 875
 876   (disunity-test (:array-type-union :element-type-and-complexp-dont-unite)
 877                  (simple-array (unsigned-byte 8))
 878                  (and array (not simple-array)))
 879
 880   ;; These tests aren't really impure once the SHUFFLE function is provided.
 881   ;; Logically they belong with the above, so here they are.
 882   (with-test (:name :union-of-all-arrays-is-array-of-wild)
 883     (flet ((huge-union (fn)
 884              (mapcar fn sb-kernel::*specialized-array-element-types*)))
 885
 886       (let ((answers '(VECTOR
 887                        (SIMPLE-ARRAY * (*))
 888                        (AND VECTOR (NOT SIMPLE-ARRAY))
 889                        (VECTOR * 400)
 890                        (SIMPLE-ARRAY * (400))
 891                        (AND (VECTOR * 400) (NOT SIMPLE-ARRAY)))))
 892         (dolist (dim '(() (400)))
 893           (dolist (simpleness '(() (simple-array) ((not simple-array))))
 894             (assert
 895              (equal
 896               (sb-kernel:type-specifier
 897                (sb-kernel:specifier-type
 898                 `(or ,@(huge-union
 899                         (lambda (x) `(and ,@simpleness (vector ,x ,@dim)))))))
 900               (pop answers))))))
 901
 902       ;; The algorithm is indifferent to non-array types.
 903       (assert
 904        (equal (sb-kernel:type-specifier
 905                (sb-kernel:specifier-type
 906                 `(or list ,@(huge-union (lambda (x) `(array ,x (1 1 1)))))))
 907               '(or cons null (array * (1 1 1)))))
 908
 909       ;; And unions of unions of distinct array types should reduce.
 910       (assert
 911        (equal
 912         (sb-kernel:type-specifier
 913          (sb-kernel:specifier-type
 914           `(or (simple-array bletch (3 2 8))
 915                ,@(huge-union
 916                   (lambda (x) `(and (not simple-array) (array ,x (2 2)))))
 917                function
 918                ,@(huge-union (lambda (x) `(simple-array ,x (10)))))))
 919         '(or (simple-array bletch (3 2 8))
 920              (and (array * (2 2)) (not simple-array))
 921              function
 922              (simple-array * (10)))))
 923
 924       ;; After uniting all simple and non-simple arrays of every specializer
 925       ;; the result is just ARRAY.
 926       (flet ((u (rank)
 927                (shuffle ; should be insensitive to ordering
 928                 (nconc (huge-union
 929                         (lambda (x) `(and (not simple-array) (array ,x ,rank))))
 930                        (huge-union
 931                         (lambda (x) `(and (simple-array) (array ,x ,rank))))))))
 932         (assert
 933          (equal (sb-kernel:type-specifier
 934                  (sb-kernel:specifier-type `(or bit-vector ,@(u 2))))
 935                 '(or bit-vector (array * (* *)))))
 936         (assert
 937          (equal (sb-kernel:type-specifier
 938                  (sb-kernel:specifier-type `(or bit-vector ,@(u 1))))
 939                 'vector))))))
 940
 941 (with-test (:name :source-transform-union-of-arrays-typep)
 942   ;; Ensure we don't pessimize rank 1 specialized array.
 943   ;; (SIMPLE unboxed vector is done differently)
 944   (let* ((hair (sb-kernel:specifier-type '(sb-kernel:unboxed-array 1)))
 945          (xform (sb-c::source-transform-union-typep 'myobj hair))
 946          (g (caar (cadr xform)))) ; (LET ((#:g MYOBJ)) ...)
 947     (assert (equal xform
 948                    `(let ((,g myobj))
 949                       (or (typep ,g '(and vector (not (array t)))))))))
 950
 951   ;; Exclude one subtype at a time and make sure they all work.
 952   (dotimes (i (length sb-vm:*specialized-array-element-type-properties*))
 953     (let* ((excluded-type
 954             (sb-vm:saetp-specifier
 955              (aref sb-vm:*specialized-array-element-type-properties* i)))
 956            (hair
 957             (loop for x across sb-vm:*specialized-array-element-type-properties*
 958                   for j from 0
 959                   unless (eql i j)
 960                   collect `(array ,(sb-vm:saetp-specifier x))))
 961            (xform
 962             (sb-c::source-transform-union-typep 'myobj
 963              (sb-kernel:specifier-type `(or ,@(shuffle hair) fixnum))))
 964            (g (caar (cadr xform)))) ; (LET ((#:g MYOBJ)) ...)
 965       (assert (equal xform
 966                      `(let ((,g myobj))
 967                         (or (typep ,g '(and array (not (array ,excluded-type))))
 968                             (typep ,g 'fixnum))))))))
 969
 970 (with-test (:name :interned-type-specifiers)
 971   ;; In general specifiers can repeatedly parse the same due to
 972   ;; the caching in VALUES-SPECIFIER-TYPE, provided that the entry
 973   ;; was not evicted. Here we want to check a stronger condition,
 974   ;; that they really always parse to the identical object.
 975   (flet ((try (specifier)
 976            (let ((parse1 (sb-kernel:specifier-type specifier)))
 977              (sb-int:drop-all-hash-caches)
 978              (let ((parse2 (sb-kernel:specifier-type specifier)))
 979                (assert (eq parse1 parse2))))))
 980     (mapc #'try
 981           '((satisfies keywordp) ; not the same as KEYWORD
 982             boolean
 983             cons
 984             null
 985             character
 986             integer
 987             bit
 988             ;; one-dimensional arrays of unknown type
 989             (array * (*))
 990             (simple-array * (*))
 991             (and (array * (*)) (not simple-array))
 992             ;; floating-point
 993             single-float
 994             double-float
 995             (complex single-float)
 996             (complex double-float)))
 997     ;; and check all specialized arrays
 998     (dolist (spec sb-kernel::*specialized-array-element-types*)
 999       (try `(array ,spec (*)))
1000       (try `(simple-array ,spec (*)))
1001       (try `(and (not simple-array) (array ,spec (*)))))))
1002
1003 ;; The expansion of FRUITBAT is a class itself, not its name.
1004 (deftype fruitbat () (find-class 'hash-table))
1005 (with-test (:name :typexpand-into-classoid)
1006   (assert (eq (sb-kernel:specifier-type 'fruitbat)
1007               (sb-kernel:find-classoid 'hash-table))))
1008
1009 ;;; success