tests/type.impure.lisp

   1 (in-package :cl-user)
   2
   3 (load "assertoid.lisp")
   4
   5 (let ((types '(character
   6                integer fixnum (integer 0 10)
   7                single-float (single-float -1.0 1.0) (single-float 0.1)
   8                (real 4 8) (real -1 7) (real 2 11)
   9                (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3))))
  10   (dolist (i types)
  11     (format t "type I=~S~%" i)
  12     (dolist (j types)
  13       (format t "  type J=~S~%" j)
  14       (assert (subtypep i `(or ,i ,j)))
  15       (assert (subtypep i `(or ,j ,i)))
  16       (assert (subtypep i `(or ,i ,i ,j)))
  17       (assert (subtypep i `(or ,j ,i))))))
  18
  19 (defun type-evidently-= (x y)
  20   (and (subtypep x y)
  21        (subtypep y x)))
  22
  23 (assert (subtypep 'single-float 'float))
  24
  25 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
  26
  27 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
  28 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
  29 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
  30 (assert (eql (upgraded-array-element-type t) t))
  31 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
  32 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
  33
  34 ;;; Do reasonable things with undefined types, and with compound types
  35 ;;; built from undefined types.
  36 ;;;
  37 ;;; part I: TYPEP
  38 (assert (typep #(11) '(simple-array t 1)))
  39 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
  40 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  41 (assert (not (typep 11 '(simple-array undef-type 1))))
  42 ;;; part II: SUBTYPEP
  43 (assert (subtypep '(vector some-undef-type) 'vector))
  44 (assert (not (subtypep '(vector some-undef-type) 'integer)))
  45 (macrolet ((nilnil (expr)
  46              `(assert (equal '(nil nil) (multiple-value-list ,expr)))))
  47   (nilnil (subtypep 'utype-1 'utype-2))
  48   (nilnil (subtypep '(vector utype-1) '(vector utype-2)))
  49   (nilnil (subtypep '(vector utype-1) '(vector t)))
  50   (nilnil (subtypep '(vector t) '(vector utype-2))))
  51
  52 ;;; success
  53 (quit :unix-status 104)