subtypep-complex.lsp 4.11 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Jan 23 07:12:38 2005
;;;; Contains: Tests of SUBTYPEP on complex types

(in-package :cl-test)

(compile-and-load "types-aux.lsp")

(deftest subtypep-complex.1
  (subtypep* 'complex 'number)
  t t)

(deftest subtypep-complex.2
  (subtypep* 'number 'complex)
  nil t)

(defun check-not-complex-type (type)
  (let ((result1 (multiple-value-list (subtypep* type 'complex)))
sds's avatar
sds committed
20
        (result2 (multiple-value-list (subtypep* 'complex type))))
pfdietz's avatar
pfdietz committed
21
    (if (and (equal result1 '(nil t))
sds's avatar
sds committed
22 23
             (equal result2 '(nil t)))
        nil
pfdietz's avatar
pfdietz committed
24 25 26 27
      (list (list type result1 result2)))))

(deftest subtypep-complex.3
  (mapcan #'check-not-complex-type
sds's avatar
sds committed
28 29
          '(bit unsigned-byte integer rational ratio real float short-float
                single-float double-float long-float fixnum bignum))
pfdietz's avatar
pfdietz committed
30 31 32 33
  nil)

(deftest subtypep-complex.4
  (loop for i from 1 to 100
sds's avatar
sds committed
34
        nconc (check-not-complex-type `(unsigned-byte ,i)))
pfdietz's avatar
pfdietz committed
35
  nil)
sds's avatar
sds committed
36

pfdietz's avatar
pfdietz committed
37 38
(deftest subtypep-complex.5
  (loop for i from 1 to 100
sds's avatar
sds committed
39
        nconc (check-not-complex-type `(signed-byte ,i)))
pfdietz's avatar
pfdietz committed
40 41 42 43 44
  nil)

(deftest subtypep-complex.7
  (let ((types '(complex (complex) (complex *))))
    (loop for tp1 in types
sds's avatar
sds committed
45 46 47 48
          nconc (loop for tp2 in types
                      for result = (multiple-value-list (subtypep* tp1 tp2))
                      unless (equal result '(t t))
                      collect (list tp1 tp2 result))))
pfdietz's avatar
pfdietz committed
49 50 51 52
  nil)

(defun check-complex-upgrading (t1 t2)
  (let* ((ucpt1 (upgraded-complex-part-type t1))
sds's avatar
sds committed
53 54 55
         (ucpt2 (upgraded-complex-part-type t2))
         (result (multiple-value-list
                  (subtypep* `(complex ,t1) `(complex ,t2)))))
pfdietz's avatar
pfdietz committed
56 57
    (cond
     ((or (equal ucpt1 ucpt2)
sds's avatar
sds committed
58
          (subtypep t1 t2))
pfdietz's avatar
pfdietz committed
59
      (unless (equal result '(t t))
sds's avatar
sds committed
60
        (list (list :case1 t1 t2 ucpt1 ucpt2 result))))
pfdietz's avatar
pfdietz committed
61 62
     (t
      (multiple-value-bind
sds's avatar
sds committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
          (ucpt-sub1? good1?)
          (subtypep* ucpt1 ucpt2)
        (multiple-value-bind
            (ucpt-sub2? good2?)
            (subtypep* ucpt2 ucpt1)
          (cond
           ;; the second is not a subtype of the first
           ((and good2? ucpt-sub1? (not ucpt-sub2?))
            (assert good1?)
            (unless (equal result '(nil t))
              (list (list :case2 t1 t2 ucpt1 ucpt2 result))))
           ;; the first is not a subtype of the second
           ((and good1? (not ucpt-sub1?) ucpt-sub2?)
            (assert good2?)
            (unless (equal result '(nil t))
              (list (list :case3 t1 t2 ucpt1 ucpt2 result))))
           ;; they are both subtypes of each other, and so represent
           ;; the same set of objects
           ((and ucpt-sub1? ucpt-sub2?)
            (assert good1?)
            (assert good2?)
            (unless (equal result '(t t))
              (list (list :case4 t1 t2 ucpt1 ucpt2 result)))))))))))
pfdietz's avatar
pfdietz committed
86 87 88

(deftest subtypep-complex.8
  (let ((types (reverse
sds's avatar
sds committed
89 90 91 92 93 94 95
                '(bit fixnum bignum integer unsigned-byte rational ratio
                      short-float single-float double-float long-float
                      float real)))
        (float-types
         (remove-duplicates '(short-float single-float double-float long-float)
                            :test #'(lambda (t1 t2)
                                      (eql (coerce 0 t1) (coerce 0 t2))))))
pfdietz's avatar
pfdietz committed
96
    (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64)
sds's avatar
sds committed
97 98 99 100 101 102 103 104 105 106 107 108
          do (push `(unsigned-byte ,i) types)
          do (push `(signed-byte ,i) types)
          do (loop for ftp in float-types
                   do (push `(,ftp ,(coerce 0 ftp)
                                   ,(coerce i ftp))
                            types)
                   do (push `(,ftp (,(coerce (- i) ftp))
                                   ,(coerce i ftp))
                            types))
          do (push `(float ,(coerce 0 'single-float)
                           ,(coerce i 'single-float))
                   types))
pfdietz's avatar
pfdietz committed
109 110
    (setq types (reverse types))
    (let ((results
sds's avatar
sds committed
111 112 113 114
           (mapcan #'(lambda (t1)
                       (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2))
                               types))
                   types)))
pfdietz's avatar
pfdietz committed
115 116
      (subseq results 0 (min 100 (length results)))))
  nil)