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