tests/type.impure.lisp

   1 (in-package :cl-user)
   2
   3 (load "assertoid.lisp")
   4
   5 (defmacro assert-nil-nil (expr)
   6   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
   7 (defmacro assert-nil-t (expr)
   8   `(assert (equal '(nil t) (multiple-value-list ,expr))))
   9 (defmacro assert-t-t (expr)
  10   `(assert (equal '(t t) (multiple-value-list ,expr))))
  11
  12 (let ((types '(character
  13                integer fixnum (integer 0 10)
  14                single-float (single-float -1.0 1.0) (single-float 0.1)
  15                (real 4 8) (real -1 7) (real 2 11)
  16                (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3))))
  17   (dolist (i types)
  18     (format t "type I=~S~%" i)
  19     (dolist (j types)
  20       (format t "  type J=~S~%" j)
  21       (assert (subtypep i `(or ,i ,j)))
  22       (assert (subtypep i `(or ,j ,i)))
  23       (assert (subtypep i `(or ,i ,i ,j)))
  24       (assert (subtypep i `(or ,j ,i)))
  25       (dolist (k types)
  26         (format t "    type K=~S~%" k)
  27         (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
  28         ;; FIXME: The old code (including original CMU CL code)
  29         ;; fails this test. When this is fixed, we can re-enable it.
  30         #+nil (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
  31
  32 ;;; gotchas that can come up in handling subtypeness as "X is a
  33 ;;; subtype of Y if each of the elements of X is a subtype of Y"
  34 #+nil ; FIXME: suppressed until we can fix old CMU CL big
  35 (let ((subtypep-values (multiple-value-list
  36                         (subtypep '(single-float -1.0 1.0)
  37                                   '(or (real -100.0 0.0)
  38                                        (single-float 0.0 100.0))))))
  39   (assert (member subtypep-values
  40                   '(;; The system isn't expected to
  41                     ;; understand the subtype relationship.
  42                     (nil nil)
  43                     ;; But if it does, that'd be neat.
  44                     (t t)
  45                     ;; (And any other return would be wrong.)
  46                     ))))
  47
  48 (defun type-evidently-= (x y)
  49   (and (subtypep x y)
  50        (subtypep y x)))
  51
  52 (assert (subtypep 'single-float 'float))
  53
  54 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
  55
  56 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
  57 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
  58 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
  59 (assert (eql (upgraded-array-element-type t) t))
  60 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
  61 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
  62
  63 ;;; Do reasonable things with undefined types, and with compound types
  64 ;;; built from undefined types.
  65 ;;;
  66 ;;; part I: TYPEP
  67 (assert (typep #(11) '(simple-array t 1)))
  68 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
  69 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  70 (assert (not (typep 11 '(simple-array undef-type 1))))
  71 ;;; part II: SUBTYPEP
  72 (assert (subtypep '(vector some-undef-type) 'vector))
  73 (assert (not (subtypep '(vector some-undef-type) 'integer)))
  74 (assert-nil-nil (subtypep 'utype-1 'utype-2))
  75 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
  76 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
  77 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
  78
  79 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
  80 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
  81 (assert (raises-error? (typep 11 'and)))
  82 (assert (raises-error? (typep 11 'or)))
  83 |#
  84 ;;; Of course empty lists of subtypes are still OK.
  85 (assert (typep 11 '(and)))
  86 (assert (not (typep 11 '(or))))
  87
  88 ;;; bug 12: type system didn't grok nontrivial intersections
  89 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
  90 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
  91 (assert (subtypep 'keyword 'symbol))
  92 (assert (not (subtypep 'symbol 'keyword)))
  93 (assert (subtypep 'ratio 'real))
  94 (assert (subtypep 'ratio 'number))
  95
  96 ;;; success
  97 (quit :unix-status 104)