tests/type.pure.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 (in-package "CL-USER")
  13
  14 (locally
  15   (declare (notinline mapcar))
  16   (mapcar (lambda (args)
  17             (destructuring-bind (obj type-spec result) args
  18               (flet ((matches-result? (x)
  19                        (eq (if x t nil) result)))
  20                 (assert (matches-result? (typep obj type-spec)))
  21                 (assert (matches-result? (sb-kernel:ctypep
  22                                           obj
  23                                           (sb-kernel:specifier-type
  24                                            type-spec)))))))
  25           '((nil (or null vector)              t)
  26             (nil (or number vector)            nil)
  27             (12  (or null vector)              nil)
  28             (12  (and (or number vector) real) t))))
  29
  30
  31 ;;; This test is motivated by bug #195, which previously had (THE REAL
  32 ;;; #(1 2 3)) give an error which prints as "This is not a (OR
  33 ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)".  We ideally want all of the
  34 ;;; defined-by-ANSI types to unparse as themselves or at least
  35 ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
  36 ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
  37 ;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
  38 (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
  39                         ;; CLHS.
  40                         arithmetic-error
  41                         function
  42                         simple-condition
  43                         array
  44                         generic-function
  45                         simple-error
  46                         atom
  47                         hash-table
  48                         simple-string
  49                         base-char
  50                         integer
  51                         simple-type-error
  52                         base-string
  53                         keyword
  54                         simple-vector
  55                         bignum
  56                         list
  57                         simple-warning
  58                         bit
  59                         logical-pathname
  60                         single-float
  61                         bit-vector
  62                         long-float
  63                         standard-char
  64                         broadcast-stream
  65                         method
  66                         standard-class
  67                         built-in-class
  68                         method-combination
  69                         standard-generic-function
  70                         cell-error
  71                         nil
  72                         standard-method
  73                         character
  74                         null
  75                         standard-object
  76                         class
  77                         number
  78                         storage-condition
  79                         compiled-function
  80                         package
  81                         stream
  82                         complex
  83                         package-error
  84                         stream-error
  85                         concatenated-stream
  86                         parse-error
  87                         string
  88                         condition
  89                         pathname
  90                         string-stream
  91                         cons
  92                         print-not-readable
  93                         structure-class
  94                         control-error
  95                         program-error
  96                         structure-object
  97                         division-by-zero
  98                         random-state
  99                         style-warning
 100                         double-float
 101                         ratio
 102                         symbol
 103                         echo-stream
 104                         rational
 105                         synonym-stream
 106                         end-of-file
 107                         reader-error
 108                         t
 109                         error
 110                         readtable
 111                         two-way-stream
 112                         extended-char
 113                         real
 114                         type-error
 115                         file-error
 116                         restart
 117                         unbound-slot
 118                         file-stream
 119                         sequence
 120                         unbound-variable
 121                         fixnum
 122                         serious-condition
 123                         undefined-function
 124                         float
 125                         short-float
 126                         unsigned-byte
 127                         floating-point-inexact
 128                         signed-byte
 129                         vector
 130                         floating-point-invalid-operation
 131                         simple-array
 132                         warning
 133                         floating-point-overflow
 134                         simple-base-string
 135                         floating-point-underflow
 136                         simple-bit-vector)))
 137   (dolist (type standard-types)
 138     (format t "~&~S~%" type)
 139     (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type))))
 140     (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 141
 142 ;;; a bug underlying the reported bug #221: The SB-KERNEL type code
 143 ;;; signalled an error on this expression.
 144 (subtypep '(function (fixnum) (values package boolean))
 145           '(function (t) (values package boolean)))
 146
 147 ;;; bug reported by Valtteri Vuorik
 148 (compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
 149 (assert (not (equal (multiple-value-list
 150                      (subtypep '(function ()) '(function (&rest t))))
 151                     '(nil t))))
 152
 153 (assert (not (equal (multiple-value-list
 154                      (subtypep '(function (&rest t)) '(function ())))
 155                     '(t t))))
 156
 157 (assert (subtypep '(function)
 158                   '(function (&optional * &rest t))))
 159 (assert (equal (multiple-value-list
 160                 (subtypep '(function)
 161                           '(function (t &rest t))))
 162                '(nil t)))
 163 (assert (and (subtypep 'function '(function))
 164              (subtypep '(function) 'function)))
 165
 166 ;;; Absent any exciting generalizations of |R, the type RATIONAL is
 167 ;;; partitioned by RATIO and INTEGER.  Ensure that the type system
 168 ;;; knows about this.  [ the type system is permitted to return NIL,
 169 ;;; NIL for these, so if future maintenance breaks these tests that
 170 ;;; way, that's fine.  What the SUBTYPEP calls are _not_ allowed to
 171 ;;; return is NIL, T, because that's completely wrong. ]
 172 (assert (subtypep '(or integer ratio) 'rational))
 173 (assert (subtypep 'rational '(or integer ratio)))
 174 ;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
 175 ;;; return NIL, T:
 176 (assert (subtypep t '(or real (not real))))
 177 (assert (subtypep t '(or keyword (not keyword))))
 178 (assert (subtypep '(and cons (not (cons symbol integer)))
 179                   '(or (cons (not symbol) *) (cons * (not integer)))))
 180 (assert (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
 181                   '(and cons (not (cons symbol integer)))))
 182 (assert (subtypep '(or (eql 0) (rational (0) 10))
 183                   '(rational 0 10)))
 184 (assert (subtypep '(rational 0 10)
 185                   '(or (eql 0) (rational (0) 10))))
 186 ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
 187 ;;; same type gave exceedingly wrong results
 188 (assert (null (subtypep '(or (cons fixnum single-float)
 189                              (cons bignum single-float))
 190                         '(cons single-float single-float))))
 191 (assert (subtypep '(cons integer single-float)
 192                   '(or (cons fixnum single-float) (cons bignum single-float))))
 193
 194 (assert (not (nth-value 1 (subtypep '(and null some-unknown-type)
 195                                     'another-unknown-type))))
 196
 197 ;;; bug 46c
 198 (with-test (:name :coerce-function-on-macro)
 199   (dolist (fun '(and if))
 200     (assert-error (coerce fun 'function))))
 201
 202 (dotimes (i 100)
 203   (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
 204     (eval `(typep ,x (class-of ,x)))))
 205
 206 (assert (not (typep #c(1 2) '(member #c(2 1)))))
 207 (assert (typep #c(1 2) '(member #c(1 2))))
 208 (assert (subtypep 'nil '(complex nil)))
 209 (assert (subtypep '(complex nil) 'nil))
 210 (assert (subtypep 'nil '(complex (eql 0))))
 211 (assert (subtypep '(complex (eql 0)) 'nil))
 212 (assert (subtypep 'nil '(complex (integer 0 0))))
 213 (assert (subtypep '(complex (integer 0 0)) 'nil))
 214 (assert (subtypep 'nil '(complex (rational 0 0))))
 215 (assert (subtypep '(complex (rational 0 0)) 'nil))
 216 (assert (subtypep 'complex '(complex real)))
 217 (assert (subtypep '(complex real) 'complex))
 218 (assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
 219 (assert (subtypep '(complex ratio) '(complex rational)))
 220 (assert (subtypep '(complex ratio) 'complex))
 221 (assert (equal (multiple-value-list
 222                 (subtypep '(complex (integer 1 2))
 223                           '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
 224                '(nil t)))
 225
 226 (assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000))))
 227 (assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000))
 228                   '(real #.(ash -1 10000) #.(ash 1 10000))))
 229 (assert (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000)))
 230                   '(real #.(ash -1 1000) #.(ash 1 1000))))
 231
 232 ;;; Bug, found by Paul F. Dietz
 233 (let* ((x (eval #c(-1 1/2)))
 234        (type (type-of x)))
 235   (assert (subtypep type '(complex rational)))
 236   (assert (typep x type)))
 237
 238 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
 239 ;;;
 240 ;;; Fear the Loop of Doom!
 241 ;;;
 242 ;;; (In fact, this is such a fearsome loop that executing it with the
 243 ;;; evaluator would take ages... Disable it under those circumstances.)
 244 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 245 (with-test (:name (:type-derivation :logical-operations :correctness))
 246   (let* ((n-bits 5)
 247          (size (ash 1 n-bits)))
 248     (labels ((brute-force (a b c d op)
 249                (loop with min = (ash 1 n-bits)
 250                      with max = 0
 251                      for i from a upto b do
 252                      (loop for j from c upto d do
 253                            (let ((x (funcall op i j)))
 254                              (setf min (min min x)
 255                                    max (max max x))))
 256                      finally (return (values min max))))
 257              (test (a b c d op deriver)
 258                (multiple-value-bind (brute-low brute-high)
 259                    (brute-force a b c d op)
 260                  (multiple-value-bind (test-low test-high)
 261                      (funcall deriver
 262                               (sb-c::specifier-type `(integer ,a ,b))
 263                               (sb-c::specifier-type `(integer ,c ,d)))
 264                    (unless (and (= brute-low test-low)
 265                                 (= brute-high test-high))
 266                      (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
 267                              op a b c d
 268                              brute-low brute-high test-low test-high)
 269                      (assert (and (= brute-low test-low)
 270                                   (= brute-high test-high))))))))
 271       (dolist (op '(logand logior logxor))
 272         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
 273                                (find-package :sb-c))))
 274           (format t "testing type derivation: ~A~%" deriver)
 275           (loop for a from 0 below size do
 276                 (loop for b from a below size do
 277                       (loop for c from 0 below size do
 278                             (loop for d from c below size do
 279                                   (test a b c d op deriver))))))))))
 280
 281 (with-test (:name (:type-derivation :logical-operations :scaling))
 282   (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
 283                                                  ,(expt 2 10000))))
 284         (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
 285                                                  ,(expt 2 100000))))
 286         (type-y (sb-c::specifier-type '(integer 0 1))))
 287     (dolist (op '(logand logior logxor))
 288       (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
 289                               (find-package :sb-c)))
 290              (scale (/ (runtime (funcall deriver type-x2 type-y))
 291                        (runtime (funcall deriver type-x1 type-y)))))
 292         ;; Linear scaling is good, quadratical bad. Draw the line
 293         ;; near the geometric mean of the corresponding SCALEs.
 294         (when (> scale 32)
 295           (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
 296                  deriver scale))))))
 297
 298 ;;; subtypep on CONS types wasn't taking account of the fact that a
 299 ;;; CONS type could be the empty type (but no other non-CONS type) in
 300 ;;; disguise.
 301 (multiple-value-bind (yes win)
 302     (subtypep '(and function stream) 'nil)
 303   (multiple-value-bind (cyes cwin)
 304       (subtypep '(cons (and function stream) t)
 305                 '(cons nil t))
 306     (assert (eq yes cyes))
 307     (assert (eq win cwin))))
 308
 309 ;;; CONS type subtypep could be too enthusiastic about thinking it was
 310 ;;; certain
 311 (multiple-value-bind (yes win)
 312     (subtypep '(satisfies foo) '(satisfies bar))
 313   (assert (null yes))
 314   (assert (null win))
 315   (multiple-value-bind (cyes cwin)
 316       (subtypep '(cons (satisfies foo) t)
 317                 '(cons (satisfies bar) t))
 318     (assert (null cyes))
 319     (assert (null cwin))))
 320
 321 (multiple-value-bind (yes win)
 322     (subtypep 'generic-function 'function)
 323   (assert yes)
 324   (assert win))
 325 ;;; this would be in some internal test suite like type.before-xc.lisp
 326 ;;; except that generic functions don't exist at that stage.
 327 (multiple-value-bind (yes win)
 328     (subtypep 'generic-function 'sb-kernel:funcallable-instance)
 329   (assert yes)
 330   (assert win))
 331
 332 ;;; all sorts of answers are right for this one, but it used to
 333 ;;; trigger an AVER instead.
 334 (subtypep '(function ()) '(and (function ()) (satisfies identity)))
 335
 336 (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type)))
 337
 338 (assert
 339  (sb-kernel:type=
 340   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 341                               (simple-array an-unkown-type)))
 342   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 343                               (simple-array an-unkown-type)))))
 344
 345 (assert
 346  (sb-kernel:type=
 347   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 348   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))
 349
 350 (assert
 351  (not
 352   (sb-kernel:type=
 353    (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 354    (sb-kernel:specifier-type '(array an-unkown-type (*))))))
 355
 356 (assert
 357  (not
 358   (sb-kernel:type=
 359    (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
 360    (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
 361
 362 (assert
 363  (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
 364                    (sb-kernel:specifier-type '(cons single-float single-float))))
 365
 366 (multiple-value-bind (match win)
 367     (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
 368                      (sb-kernel:specifier-type '(cons)))
 369   (assert (and (not match) win)))
 370
 371 (assert (typep #p"" 'sb-kernel:instance))
 372 (assert (subtypep '(member #p"") 'sb-kernel:instance))
 373
 374 (with-test (:name (:typep :character-set :negation))
 375   (flet ((generate-chars ()
 376            (loop repeat 100
 377                  collect (code-char (random char-code-limit)))))
 378     (dotimes (i 1000)
 379       (let* ((chars (generate-chars))
 380              (type `(member ,@chars))
 381              (not-type `(not ,type)))
 382         (dolist (char chars)
 383           (assert (typep char type))
 384           (assert (not (typep char not-type))))
 385         (let ((other-chars (generate-chars)))
 386           (dolist (char other-chars)
 387             (unless (member char chars)
 388               (assert (not (typep char type)))
 389               (assert (typep char not-type)))))))))
 390
 391 (with-test (:name (:check-type :store-value :complex-place))
 392   (let ((a (cons 0.0 2))
 393         (handler-invoked nil))
 394     (handler-bind ((error
 395                     (lambda (c)
 396                       (declare (ignore c))
 397                       (assert (not handler-invoked))
 398                       (setf handler-invoked t)
 399                       (invoke-restart 'store-value 1))))
 400       (check-type (car a) integer))
 401     (assert (eql (car a) 1))))
 402
 403 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
 404 ;;; the first ASSERT below. The second ASSERT takes care that the fix
 405 ;;; doesn't overshoot the mark.
 406 (with-test (:name (:typep :fixnum-if-unsigned-byte))
 407   (let ((f (compile nil
 408                     '(lambda (x)
 409                       (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
 410                       (typep x (quote fixnum))))))
 411     (assert (not (funcall f (1+ most-positive-fixnum))))
 412     (assert (funcall f most-positive-fixnum))))
 413
 414 (with-test (:name (:typep :member-uses-eql))
 415   (assert (eval '(typep 1/3 '(member 1/3 nil))))
 416   (assert (eval '(typep 1.0 '(member 1.0 t))))
 417   (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
 418   (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
 419   (let ((bignum1 (+ 12 most-positive-fixnum))
 420         (bignum2 (- (+ 15 most-positive-fixnum) 3)))
 421     (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
 422
 423 (with-test (:name :opt+rest+key-canonicalization)
 424   (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
 425     (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 426
 427 (with-test (:name :bug-369)
 428   (let ((types (mapcar #'sb-c::values-specifier-type
 429                        '((values (vector package) &optional)
 430                          (values (vector package) &rest t)
 431                          (values (vector hash-table) &rest t)
 432                          (values (vector hash-table) &optional)
 433                          (values t &optional)
 434                          (values t &rest t)
 435                          (values nil &optional)
 436                          (values nil &rest t)
 437                          (values sequence &optional)
 438                          (values sequence &rest t)
 439                          (values list &optional)
 440                          (values list &rest t)))))
 441     (dolist (x types)
 442       (dolist (y types)
 443         (let ((i (sb-c::values-type-intersection x y)))
 444           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
 445           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
 446
 447 (with-test (:name :bug-485972)
 448   (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
 449   (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))
 450
 451 ;; WARNING: this test case would fail by recursing into the stack's guard page.
 452 (with-test (:name :bug-883498)
 453   (sb-kernel:specifier-type
 454    `(or (INTEGER -2 -2)
 455         (AND (SATISFIES FOO) (RATIONAL -3/2 -3/2)))))
 456
 457 ;; The infinite recursion mentioned in the previous test was caused by an
 458 ;; attempt to get the following right.
 459 (with-test (:name :quirky-integer-rational-union)
 460   (assert (subtypep `(or (integer * -1)
 461                          (and (rational * -1/2) (not integer)))
 462                     `(rational * -1/2)))
 463   (assert (subtypep `(rational * -1/2)
 464                     `(or (integer * -1)
 465                          (and (rational * -1/2) (not integer))))))
 466
 467 ;; for the longest time (at least 05525d3a), single-value-type would
 468 ;; return CHARACTER on this.
 469 (with-test (:name :single-value-&optional-type)
 470   (assert (sb-c::type= (sb-c::single-value-type
 471                         (sb-c::values-specifier-type '(values &optional character)))
 472                        (sb-c::specifier-type '(or null character)))))
 473
 474 ;; lp#1317308 - TYPE-OF must not return a type specifier
 475 ;; involving AND,EQL,MEMBER,NOT,OR,SATISFIES,or VALUES.
 476 (with-test (:name :ANSIly-report-hairy-array-type)
 477   (let ((simp-t (make-array 9))
 478         (simp-bit (make-array 16 :element-type 'bit)))
 479     ;; TYPE-OF doesn't have an optimization that returns a constant specifier
 480     ;; from a non-constant array of known type. If it did, we'd probably
 481     ;; want to check that these results are all equal:
 482     ;;  - the runtime-determined type
 483     ;;  - the compile-time-determined constant type
 484     ;;  - the compile-time-determined type of an equivalent object
 485     ;;    that is in fact a compile-time constant
 486     (flet ((our-type-of (x) (sb-kernel:type-specifier (sb-kernel:ctype-of x))))
 487       (let ((hairy-t (make-array 3 :displaced-to simp-t)))
 488         (assert (equal (our-type-of hairy-t)
 489                        '(and (vector t 3) (not simple-array))))
 490         (assert (equal (type-of hairy-t) '(vector t 3))))
 491       (let ((hairy-t (make-array '(3 2) :displaced-to simp-t)))
 492         (assert (equal (our-type-of hairy-t)
 493                        '(and (array t (3 2)) (not simple-array))))
 494         (assert (equal (type-of hairy-t) '(array t (3 2)))))
 495       (let ((hairy-bit
 496              (make-array 5 :displaced-to simp-bit :element-type 'bit)))
 497         (assert (equal (our-type-of hairy-bit)
 498                        '(and (bit-vector 5) (not simple-array))))
 499         (assert (equal (type-of hairy-bit) '(bit-vector 5)))))))
 500
 501 (with-test (:name :bug-309098)
 502   (let ((u `(or ,@(map 'list (lambda (x) `(array ,(sb-vm:saetp-specifier x)))
 503                        sb-vm:*specialized-array-element-type-properties*))))
 504     (assert (equal (multiple-value-list (subtypep 'array u)) '(t t)))))
 505
 506 (with-test (:name :bug-1258716)
 507   (let ((intersection (sb-kernel:type-intersection
 508                        (sb-kernel:specifier-type 'simple-vector)
 509                        (sb-kernel:specifier-type `(vector #:unknown)))))
 510     (assert (sb-kernel:array-type-p intersection))
 511     ;; and not *wild-type*
 512     (assert (sb-kernel:type= (sb-kernel:array-type-specialized-element-type intersection)
 513                              sb-kernel:*universal-type*))))
 514
 515 (with-test (:name :parse-safely)
 516   (dolist (x '(array integer cons))
 517     (assert (handler-case (sb-kernel:specifier-type `(,x . 0))
 518               (type-error () t)
 519               (error (c) (print c) nil)))))
 520
 521 (with-test (:name :unparse-safely)
 522   (let* ((intersection (sb-kernel:type-intersection
 523                         (sb-kernel:specifier-type '(vector (or bit character)))
 524                         (sb-kernel:specifier-type `(vector (or bit symbol)))))
 525          (round-trip (sb-kernel:specifier-type
 526                      (sb-kernel:type-specifier intersection))))
 527     (assert (sb-kernel:type= intersection round-trip))
 528     (assert (sb-kernel:array-type-p intersection))
 529     ;; and not *wild-type*
 530     (assert (sb-kernel:type/= (sb-kernel:array-type-specialized-element-type intersection)
 531                               (sb-kernel:specifier-type 'bit)))))
 532
 533 (in-package "SB-KERNEL")
 534 (test-util:with-test (:name :partition-array-into-simple/hairy)
 535   ;; Some tests that (simple-array | hairy-array) = array
 536   ;; At present this works only for wild element-type.
 537   (multiple-value-bind (eq winp)
 538       (type= (specifier-type '(not (and array (not simple-array))))
 539              (specifier-type '(or (not array) simple-array)))
 540     (assert (and eq winp)))
 541
 542   ;; if X is neither simple-array nor hairy-array, it is not an array
 543   (assert (type= (specifier-type '(and (not simple-array)
 544                                        (not (and array (not simple-array)))))
 545                  (specifier-type '(not array))))
 546
 547   ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc
 548   (flet ((try (unrestricted simple)
 549            (assert (type= (specifier-type simple)
 550                           (type-intersection
 551                            (specifier-type
 552                             '(not (and array (not simple-array))))
 553                            (specifier-type unrestricted))))))
 554     (try 'vector '(simple-array * (*)))
 555     (try '(vector t) 'simple-vector)
 556     (try 'bit-vector 'simple-bit-vector)
 557     (try 'string 'simple-string)
 558     #+sb-unicode(try 'character-string 'simple-character-string)
 559     (try 'base-string 'simple-base-string))
 560
 561   ;; if X is a known string and not an array-header
 562   ;; it must be a SIMPLE-STRING
 563   (assert (type= (type-intersection
 564                   (specifier-type 'string)
 565                   (specifier-type
 566                    '(not (or (and simple-array (not vector))
 567                              (and array (not simple-array))))))
 568                  (specifier-type 'simple-string))))