source: trunk/source/tests/ansi-tests/subtypep-complex.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Jan 23 07:12:38 2005
4;;;; Contains: Tests of SUBTYPEP on complex types
5
6(in-package :cl-test)
7
8(compile-and-load "types-aux.lsp")
9
10(deftest subtypep-complex.1
11  (subtypep* 'complex 'number)
12  t t)
13
14(deftest subtypep-complex.2
15  (subtypep* 'number 'complex)
16  nil t)
17
18(defun check-not-complex-type (type)
19  (let ((result1 (multiple-value-list (subtypep* type 'complex)))
20        (result2 (multiple-value-list (subtypep* 'complex type))))
21    (if (and (equal result1 '(nil t))
22             (equal result2 '(nil t)))
23        nil
24      (list (list type result1 result2)))))
25
26(deftest subtypep-complex.3
27  (mapcan #'check-not-complex-type
28          '(bit unsigned-byte integer rational ratio real float short-float
29                single-float double-float long-float fixnum bignum))
30  nil)
31
32(deftest subtypep-complex.4
33  (loop for i from 1 to 100
34        nconc (check-not-complex-type `(unsigned-byte ,i)))
35  nil)
36       
37(deftest subtypep-complex.5
38  (loop for i from 1 to 100
39        nconc (check-not-complex-type `(signed-byte ,i)))
40  nil)
41
42(deftest subtypep-complex.7
43  (let ((types '(complex (complex) (complex *))))
44    (loop for tp1 in types
45          nconc (loop for tp2 in types
46                      for result = (multiple-value-list (subtypep* tp1 tp2))
47                      unless (equal result '(t t))
48                      collect (list tp1 tp2 result))))
49  nil)
50
51(defun check-complex-upgrading (t1 t2)
52  (let* ((ucpt1 (upgraded-complex-part-type t1))
53         (ucpt2 (upgraded-complex-part-type t2))
54         (result (multiple-value-list
55                  (subtypep* `(complex ,t1) `(complex ,t2)))))
56    (cond
57     ((or (equal ucpt1 ucpt2)
58          (subtypep t1 t2))
59      (unless (equal result '(t t))
60        (list (list :case1 t1 t2 ucpt1 ucpt2 result))))
61     (t
62      (multiple-value-bind
63          (ucpt-sub1? good1?)
64          (subtypep* ucpt1 ucpt2)
65        (multiple-value-bind
66            (ucpt-sub2? good2?)
67            (subtypep* ucpt2 ucpt1)
68          (cond
69           ;; the second is not a subtype of the first
70           ((and good2? ucpt-sub1? (not ucpt-sub2?))
71            (assert good1?)
72            (unless (equal result '(nil t))
73              (list (list :case2 t1 t2 ucpt1 ucpt2 result))))
74           ;; the first is not a subtype of the second
75           ((and good1? (not ucpt-sub1?) ucpt-sub2?)
76            (assert good2?)
77            (unless (equal result '(nil t))
78              (list (list :case3 t1 t2 ucpt1 ucpt2 result))))
79           ;; they are both subtypes of each other, and so represent
80           ;; the same set of objects
81           ((and ucpt-sub1? ucpt-sub2?)
82            (assert good1?)
83            (assert good2?)
84            (unless (equal result '(t t))
85              (list (list :case4 t1 t2 ucpt1 ucpt2 result)))))))))))
86
87(deftest subtypep-complex.8
88  (let ((types (reverse
89                '(bit fixnum bignum integer unsigned-byte rational ratio
90                      short-float single-float double-float long-float
91                      float real)))
92        (float-types
93         (remove-duplicates '(short-float single-float double-float long-float)
94                            :test #'(lambda (t1 t2)
95                                      (eql (coerce 0 t1) (coerce 0 t2))))))
96    (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64)
97          do (push `(unsigned-byte ,i) types)
98          do (push `(signed-byte ,i) types)
99          do (loop for ftp in float-types
100                   do (push `(,ftp ,(coerce 0 ftp)
101                                   ,(coerce i ftp))
102                            types)
103                   do (push `(,ftp (,(coerce (- i) ftp))
104                                   ,(coerce i ftp))
105                            types))
106          do (push `(float ,(coerce 0 'single-float)
107                           ,(coerce i 'single-float))
108                   types))
109    (setq types (reverse types))
110    (let ((results
111           (mapcan #'(lambda (t1)
112                       (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2))
113                               types))
114                   types)))
115      (subseq results 0 (min 100 (length results)))))
116  nil)
Note: See TracBrowser for help on using the repository browser.