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 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
 459                        (integer -234496 215373))
 460                  integer))
 461       (t2 '(cons (cons (cons integer integer)
 462                        (integer -234496 215373))
 463                  t)))
 464   (assert (null (values (subtypep `(not ,t2) `(not ,t1))))))
 465 \f
 466 (defstruct misc-629a)
 467 (defclass misc-629b () ())
 468 (defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
 469
 470 (assert (typep (make-misc-629a) 'sb-kernel:instance))
 471 (assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
 472 (assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
 473                         nil))
 474 (let ((misc-629a (make-misc-629a)))
 475   (assert-t-t (subtypep `(member ,misc-629a)
 476                         `(and (member ,misc-629a) sb-kernel:instance)))
 477   (assert-t-t (subtypep `(and (member ,misc-629a)
 478                           sb-kernel:funcallable-instance)
 479                         nil)))
 480
 481 (assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
 482 (assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
 483                       'sb-kernel:instance))
 484 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
 485                           sb-kernel:instance)
 486                         nil))
 487 (let ((misc-629b (make-instance 'misc-629b)))
 488   (assert-t-t (subtypep `(member ,misc-629b)
 489                         `(and (member ,misc-629b) sb-kernel:instance)))
 490   (assert-t-t (subtypep `(and (member ,misc-629b)
 491                           sb-kernel:funcallable-instance)
 492                         nil)))
 493
 494 (assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
 495 (assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
 496                       'sb-kernel:funcallable-instance))
 497 (assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
 498                           sb-kernel:funcallable-instance)
 499                         nil))
 500 (let ((misc-629c (make-instance 'misc-629c)))
 501   (assert-t-t (subtypep `(member ,misc-629c)
 502                         `(and (member ,misc-629c)
 503                           sb-kernel:funcallable-instance)))
 504   (assert-t-t (subtypep `(and (member ,misc-629c)
 505                           sb-kernel:instance)
 506                         nil)))
 507 \f
 508 ;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
 509 ;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
 510 ;;; subclass, so SUBTYPEP must be prepared to deal with
 511 (defclass ansi-tests-defclass1 () ())
 512 (defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
 513 (make-instance 'ansi-tests-defclass1)
 514 (assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
 515 \f
 516 ;;; so was this
 517 (let ((class (eval '(defclass to-be-type-ofed () ()))))
 518   (setf (find-class 'to-be-type-ofed) nil)
 519   (assert (eq (type-of (make-instance class)) class)))
 520 \f
 521 ;;; accuracy of CONS :SIMPLE-TYPE-=
 522 (deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
 523 (deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
 524
 525 (multiple-value-bind (ok win)
 526     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 527                      (sb-kernel:specifier-type '(cons goldbach1 integer)))
 528   (assert ok)
 529   (assert win))
 530
 531 ;; See FIXME in type method for CONS :SIMPLE-TYPE-=
 532 #+nil
 533 (multiple-value-bind (ok win)
 534     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 535                      (sb-kernel:specifier-type '(cons goldbach1 single-float)))
 536   (assert (not ok))
 537   (assert win))
 538
 539 (multiple-value-bind (ok win)
 540     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
 541                      (sb-kernel:specifier-type '(cons goldbach2 single-float)))
 542   (assert (not ok))
 543   (assert (not win)))
 544
 545 ;;; precise unions of array types (was bug 306a)
 546 (defun bug-306-a (x)
 547   (declare (optimize speed)
 548            (type (or (array cons) (array vector)) x))
 549   (elt (aref x 0) 0))
 550 (assert (= 0 (bug-306-a #((0)))))
 551 \f
 552 ;;; FUNCALLABLE-INSTANCE is a subtype of function.
 553 (assert-t-t (subtypep '(and pathname function) nil))
 554 (assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
 555 (assert (not (subtypep '(and stream function) nil)))
 556 (assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
 557 (assert (not (subtypep '(and function standard-object) nil)))
 558 (assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
 559
 560 ;;; also, intersections of classes with INSTANCE should not be too
 561 ;;; general
 562 (assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
 563 (assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
 564 \f
 565 (assert-t-t
 566  (subtypep '(or simple-array simple-string) '(or simple-string simple-array)))
 567 (assert-t-t
 568  (subtypep '(or simple-string simple-array) '(or simple-array simple-string)))
 569 (assert-t-t
 570  (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
 571            '(or fixnum vector end-of-file parse-error fixnum simple-string)))
 572
 573 #+sb-eval
 574 (assert-t-t
 575  (subtypep '(and function (not compiled-function)
 576              (not sb-eval:interpreted-function))
 577            nil))
 578
 579 ;;; weakening of union type checks
 580 (defun weaken-union-1 (x)
 581   (declare (optimize speed))
 582   (car x))
 583 (multiple-value-bind (res err)
 584     (ignore-errors (weaken-union-1 "askdjhasdkj"))
 585   (assert (not res))
 586   (assert (typep err 'type-error)))
 587 (defun weaken-union-2 (x)
 588   (declare (optimize speed)
 589            (type (or cons fixnum) x))
 590   (etypecase x
 591     (fixnum x)
 592     (cons
 593      (setf (car x) 3)
 594      x)))
 595 (multiple-value-bind (res err)
 596     (ignore-errors (weaken-union-2 "asdkahsdkhj"))
 597   (assert (not res))
 598   (assert (typep err 'type-error))
 599   (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
 600               (equal '(or fixnum cons) (type-error-expected-type err)))))
 601
 602 ;;; TYPEXPAND & Co
 603
 604 (deftype a-deftype (arg)
 605   `(cons (eql ,arg) *))
 606
 607 (deftype another-deftype (arg)
 608   `(a-deftype ,arg))
 609
 610 (deftype list-of-length (length &optional element-type)
 611   (assert (not (minusp length)))
 612   (if (zerop length)
 613       'null
 614       `(cons ,element-type (list-of-length ,(1- length) ,element-type))))
 615
 616 (with-test (:name :typexpand-1)
 617   (multiple-value-bind (expansion-1 expandedp-1)
 618       (sb-ext:typexpand-1 '(another-deftype symbol))
 619     (assert expandedp-1)
 620     (assert (equal expansion-1 '(a-deftype symbol)))
 621     (multiple-value-bind (expansion-2 expandedp-2)
 622         (sb-ext:typexpand-1 expansion-1)
 623       (assert expandedp-2)
 624       (assert (equal expansion-2 '(cons (eql symbol) *)))
 625       (multiple-value-bind (expansion-3 expandedp-3)
 626           (sb-ext:typexpand-1 expansion-2)
 627         (assert (not expandedp-3))
 628         (assert (eq expansion-2 expansion-3))))))
 629
 630 (with-test (:name :typexpand.1)
 631   (multiple-value-bind (expansion-1 expandedp-1)
 632       (sb-ext:typexpand '(another-deftype symbol))
 633     (assert expandedp-1)
 634     (assert (equal expansion-1 '(cons (eql symbol) *)))
 635     (multiple-value-bind (expansion-2 expandedp-2)
 636         (sb-ext:typexpand expansion-1)
 637       (assert (not expandedp-2))
 638       (assert (eq expansion-1 expansion-2)))))
 639
 640 (with-test (:name :typexpand.2)
 641   (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum))
 642                  '(cons fixnum (list-of-length 2 fixnum)))))
 643
 644 (with-test (:name :typexpand-all)
 645   (assert (equal (sb-ext:typexpand-all '(list-of-length 3))
 646                  '(cons t (cons t (cons t null)))))
 647   (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum))
 648                  '(cons fixnum (cons fixnum (cons fixnum null))))))
 649
 650 (defclass a-deftype () ())
 651
 652 (with-test (:name (:typexpand-1 :after-type-redefinition-to-class))
 653   (multiple-value-bind (expansion expandedp)
 654       (sb-ext:typexpand-1 '#1=(a-deftype symbol))
 655     (assert (not expandedp))
 656     (assert (eq expansion '#1#))))
 657
 658
 659 (with-test (:name :defined-type-name-p)
 660   (assert (not (sb-ext:defined-type-name-p '#:foo)))
 661   (assert (sb-ext:defined-type-name-p 'a-deftype))
 662   (assert (sb-ext:defined-type-name-p 'structure-foo1))
 663   (assert (sb-ext:defined-type-name-p 'structure-class-foo1))
 664   (assert (sb-ext:defined-type-name-p 'standard-class-foo1))
 665   (assert (sb-ext:defined-type-name-p 'condition-foo1))
 666   (dolist (prim-type '(t nil fixnum cons atom))
 667     (assert (sb-ext:defined-type-name-p prim-type))))
 668
 669
 670 (with-test (:name :valid-type-specifier-p)
 671   (macrolet ((yes (form) `(assert ,form))
 672              (no  (form) `(assert (not ,form))))
 673     (no  (sb-ext:valid-type-specifier-p '(cons #(frob) *)))
 674     (no  (sb-ext:valid-type-specifier-p 'list-of-length))
 675     (no  (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x))))
 676     (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum)))
 677
 678     (yes (sb-ext:valid-type-specifier-p 'structure-foo1))
 679     (no  (sb-ext:valid-type-specifier-p '(structure-foo1 x)))
 680     (yes (sb-ext:valid-type-specifier-p 'condition-foo1))
 681     (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1))
 682     (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1))
 683
 684     (yes (sb-ext:valid-type-specifier-p 'readtable))
 685     (no  (sb-ext:valid-type-specifier-p '(readtable)))
 686     (no  (sb-ext:valid-type-specifier-p '(readtable x)))
 687
 688     (yes (sb-ext:valid-type-specifier-p '(values)))
 689     (no  (sb-ext:valid-type-specifier-p 'values))
 690     (yes (sb-ext:valid-type-specifier-p '(and)))
 691     (no  (sb-ext:valid-type-specifier-p 'and))))
 692
 693 (with-test (:name (:valid-type-specifier-p :introspection-test))
 694   (flet ((map-functions (fn)
 695            (do-all-symbols (s)
 696              (when (and (fboundp s)
 697                         (not (macro-function s))
 698                         (not (special-operator-p s)))
 699                (funcall fn s)))))
 700     (map-functions
 701      #'(lambda (s)
 702          (let* ((fun   (sb-kernel:%fun-fun (fdefinition s)))
 703                 (ftype (sb-kernel:%simple-fun-type fun)))
 704            (unless (sb-ext:valid-type-specifier-p ftype)
 705              (format *error-output*
 706                      "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>"
 707                      'sb-ext:valid-type-specifier-p
 708                      s
 709                      ftype )
 710              (error "FAILURE")))))))
 711
 712 (with-test (:name (:bug-309128 1))
 713   (let* ((s (gensym))
 714          (t1 (sb-kernel:specifier-type s)))
 715     (eval `(defstruct ,s))
 716     (multiple-value-bind (ok sure)
 717         (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
 718       (assert (and ok sure)))))
 719
 720 (with-test (:name (:bug-309128 2))
 721   (let* ((s (gensym))
 722          (t1 (sb-kernel:specifier-type s)))
 723     (eval `(defstruct ,s))
 724     (multiple-value-bind (ok sure)
 725         (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
 726       (assert (and ok sure)))))
 727
 728 (with-test (:name (:bug-309128 3))
 729   (let* ((s (gensym))
 730          (t1 (sb-kernel:specifier-type s))
 731          (s2 (gensym))
 732          (t2 (sb-kernel:specifier-type s2)))
 733     (eval `(deftype ,s2 () ',s))
 734     (eval `(defstruct ,s))
 735     (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
 736       (assert (and ok sure)))))
 737
 738 (with-test (:name :unknown-type-not=-for-sure)
 739   (let* ((type (gensym "FOO"))
 740          (spec1 (sb-kernel:specifier-type `(vector ,type)))
 741          (spec2 (sb-kernel:specifier-type `(vector single-float))))
 742     (eval `(deftype ,type () 'double-float))
 743     (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2)
 744       (assert (not ok))
 745       (assert sure))))
 746
 747 (defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ())
 748 (defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ())
 749 (defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ())
 750 (defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ())
 751 (with-test (:name (:subtypep :forward-referenced-classes))
 752   (flet ((test (c1 c2 b1 b2)
 753            (multiple-value-bind (x1 x2) (subtypep c1 c2)
 754              (unless (and (eq b1 x1) (eq b2 x2))
 755                (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S"
 756                       c1 c2 x1 x2 b1 b2)))))
 757     (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t)
 758     (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t)
 759     (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil)
 760     (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil)
 761
 762     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t)
 763     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t)
 764     (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil)
 765     (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil)
 766
 767     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t)
 768     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t)
 769     (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil)
 770     (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil)
 771
 772     (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil)
 773     (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t)))
 774 \f
 775 ;;; Array type unions have some tricky semantics.
 776
 777 ;; borrowed from 'info.impure.lisp' - FIXME: put in test-util
 778 ;; and make it accept with either lists or vectors.
 779 (defun shuffle (list)
 780   (let ((vector (coerce list 'vector)))
 781     (loop for lim from (1- (length vector)) downto 0
 782           for chosen = (random (1+ lim))
 783           do (rotatef (aref vector chosen) (aref vector lim)))
 784     (coerce vector 'list)))
 785
 786 (macrolet
 787     ((disunity-test (name type-specifier-1 type-specifier-2)
 788        `(with-test (:name ,name)
 789           (let ((type1 (sb-kernel:specifier-type ',type-specifier-1))
 790                 (type2 (sb-kernel:specifier-type ',type-specifier-2)))
 791             (assert (null (sb-kernel::%type-union2 type1 type2)))
 792             (assert (null (sb-kernel::%type-union2 type2 type1))))))
 793      (unity-test (name type-specifier-1 type-specifier-2 result-type-specifier)
 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                  (rtype (sb-kernel:specifier-type ',result-type-specifier))
 798                  (res1 (sb-kernel::%type-union2 type1 type2))
 799                  (res2 (sb-kernel::%type-union2 type2 type1)))
 800             ;; The (ARRAY :SIMPLE-=) type method doesn't always (or
 801             ;; even usually) check the element type, preferring
 802             ;; instead to check the upgraded element type.  Therefore,
 803             ;; check the element types ourselves.
 804             (assert (and (sb-kernel:type= res1 rtype)
 805                          (sb-kernel:type=
 806                           (sb-kernel:array-type-element-type res1)
 807                           (sb-kernel:array-type-element-type rtype))))
 808             (assert (and (sb-kernel:type= res2 rtype)
 809                          (sb-kernel:type=
 810                           (sb-kernel:array-type-element-type res2)
 811                           (sb-kernel:array-type-element-type rtype))))))))
 812
 813   (unity-test (:array-type-union :basic)
 814               array
 815               array
 816               array)
 817
 818   (unity-test (:array-type-union :dimensional-compatability :wild)
 819               (array * *)
 820               (array * (* * *))
 821               (array * *))
 822
 823   (disunity-test (:array-type-union :dimensional-compatability :incompatible 1)
 824                  (array * (* *))
 825                  (array * (* * *)))
 826
 827   (disunity-test (:array-type-union :dimensional-compatability :incompatible 2)
 828                  (array * (* 1 *))
 829                  (array * (* 2 *)))
 830
 831   (disunity-test (:array-type-union :dimensional-unity :only-one-dimension-per-union)
 832               (array * (2 *))
 833               (array * (* 3)))
 834
 835   (unity-test (:array-type-union :complexp-unity :moves-towards-maybe)
 836               simple-array
 837               (and array (not simple-array))
 838               array)
 839
 840   (disunity-test (:array-type-union :complexp-and-dimensions-dont-unite 1)
 841                  (simple-array * (* *))
 842                  (and (array * (* 3)) (not simple-array)))
 843
 844   (disunity-test (:array-type-union :complexp-and-dimensions-dont-unite 2)
 845               (simple-array * (* *))
 846               (array * (* 3)))
 847
 848   (unity-test (:array-type-union :element-subtypes :unite-within-saetp)
 849               (array (integer 15 27))
 850               (array (integer 15 26))
 851               (array (integer 15 27)))
 852
 853   (disunity-test (:array-type-union :element-subtypes :dont-unite-across-saetp)
 854                  (array (unsigned-byte 7))
 855                  (array (unsigned-byte 3)))
 856
 857   (disunity-test (:array-type-union :disjoint-element-types :dont-unite)
 858                  (array (integer 15 27))
 859                  (array (integer 17 30)))
 860
 861   (unity-test (:array-type-union :wild-element-type :unites)
 862               array
 863               (array (unsigned-byte 8))
 864               array)
 865
 866   (disunity-test (:array-type-union :element-type-and-dimensions-dont-unite)
 867                  (array (unsigned-byte 8))
 868                  (array * (* *)))
 869
 870   (disunity-test (:array-type-union :element-type-and-complexp-dont-unite)
 871                  (simple-array (unsigned-byte 8))
 872                  (and array (not simple-array)))
 873
 874   ;; These tests aren't really impure once the SHUFFLE function is provided.
 875   ;; Logically they belong with the above, so here they are.
 876   (with-test (:name :union-of-all-arrays-is-array-of-wild)
 877     (flet ((huge-union (fn)
 878              (mapcar fn sb-kernel::*specialized-array-element-types*)))
 879
 880       (let ((answers '(VECTOR
 881                        (SIMPLE-ARRAY * (*))
 882                        (AND VECTOR (NOT SIMPLE-ARRAY))
 883                        (VECTOR * 400)
 884                        (SIMPLE-ARRAY * (400))
 885                        (AND (VECTOR * 400) (NOT SIMPLE-ARRAY)))))
 886         (dolist (dim '(() (400)))
 887           (dolist (simpleness '(() (simple-array) ((not simple-array))))
 888             (assert
 889              (equal
 890               (sb-kernel:type-specifier
 891                (sb-kernel:specifier-type
 892                 `(or ,@(huge-union
 893                         (lambda (x) `(and ,@simpleness (vector ,x ,@dim)))))))
 894               (pop answers))))))
 895
 896       ;; The algorithm is indifferent to non-array types.
 897       (assert
 898        (equal (sb-kernel:type-specifier
 899                (sb-kernel:specifier-type
 900                 `(or list ,@(huge-union (lambda (x) `(array ,x (1 1 1)))))))
 901               '(or cons null (array * (1 1 1)))))
 902
 903       ;; And unions of unions of distinct array types should reduce.
 904       (assert
 905        (equal
 906         (sb-kernel:type-specifier
 907          (sb-kernel:specifier-type
 908           `(or (simple-array bletch (3 2 8))
 909                ,@(huge-union
 910                   (lambda (x) `(and (not simple-array) (array ,x (2 2)))))
 911                function
 912                ,@(huge-union (lambda (x) `(simple-array ,x (10)))))))
 913         '(or (simple-array bletch (3 2 8))
 914              (and (array * (2 2)) (not simple-array))
 915              function
 916              (simple-array * (10)))))
 917
 918       ;; After uniting all simple and non-simple arrays of every specializer
 919       ;; the result is just ARRAY.
 920       (flet ((u (rank)
 921                (shuffle ; should be insensitive to ordering
 922                 (nconc (huge-union
 923                         (lambda (x) `(and (not simple-array) (array ,x ,rank))))
 924                        (huge-union
 925                         (lambda (x) `(and (simple-array) (array ,x ,rank))))))))
 926         (assert
 927          (equal (sb-kernel:type-specifier
 928                  (sb-kernel:specifier-type `(or bit-vector ,@(u 2))))
 929                 '(or bit-vector (array * (* *)))))
 930         (assert
 931          (equal (sb-kernel:type-specifier
 932                  (sb-kernel:specifier-type `(or bit-vector ,@(u 1))))
 933                 'vector))))))
 934
 935 (with-test (:name :source-transform-union-of-arrays-typep)
 936   ;; Ensure we don't pessimize rank 1 specialized array.
 937   ;; (SIMPLE unboxed vector is done differently)
 938   (let* ((hair (sb-kernel:specifier-type '(sb-kernel:unboxed-array 1)))
 939          (xform (sb-c::source-transform-union-typep 'myobj hair))
 940          (g (caar (cadr xform)))) ; (LET ((#:g MYOBJ)) ...)
 941     (assert (equal xform
 942                    `(let ((,g myobj))
 943                       (or (typep ,g '(and vector (not (array t)))))))))
 944
 945   ;; Exclude one subtype at a time and make sure they all work.
 946   (dotimes (i (length sb-vm:*specialized-array-element-type-properties*))
 947     (let* ((excluded-type
 948             (sb-vm:saetp-specifier
 949              (aref sb-vm:*specialized-array-element-type-properties* i)))
 950            (hair
 951             (loop for x across sb-vm:*specialized-array-element-type-properties*
 952                   for j from 0
 953                   unless (eql i j)
 954                   collect `(array ,(sb-vm:saetp-specifier x))))
 955            (xform
 956             (sb-c::source-transform-union-typep 'myobj
 957              (sb-kernel:specifier-type `(or ,@(shuffle hair) fixnum))))
 958            (g (caar (cadr xform)))) ; (LET ((#:g MYOBJ)) ...)
 959       (assert (equal xform
 960                      `(let ((,g myobj))
 961                         (or (typep ,g '(and array (not (array ,excluded-type))))
 962                             (typep ,g 'fixnum))))))))
 963
 964 (with-test (:name :interned-type-specifiers)
 965   ;; In general specifiers can repeatedly parse the same due to
 966   ;; the caching in VALUES-SPECIFIER-TYPE, provided that the entry
 967   ;; was not evicted. Here we want to check a stronger condition,
 968   ;; that they really always parse to the identical object.
 969   (flet ((try (specifier)
 970            (let ((parse1 (sb-kernel:specifier-type specifier)))
 971              (sb-int:drop-all-hash-caches)
 972              (let ((parse2 (sb-kernel:specifier-type specifier)))
 973                (assert (eq parse1 parse2))))))
 974     (mapc #'try
 975           '((satisfies keywordp) ; not the same as KEYWORD
 976             boolean
 977             cons
 978             null
 979             character
 980             integer
 981             bit
 982             ;; one-dimensional arrays of unknown type
 983             (array * (*))
 984             (simple-array * (*))
 985             (and (array * (*)) (not simple-array))
 986             ;; floating-point
 987             single-float
 988             double-float
 989             (complex single-float)
 990             (complex double-float)))
 991     ;; and check all specialized arrays
 992     (dolist (spec sb-kernel::*specialized-array-element-types*)
 993       (try `(array ,spec (*)))
 994       (try `(simple-array ,spec (*)))
 995       (try `(and (not simple-array) (array ,spec (*)))))))
 996
 997 ;;; success