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