upgraded-complex-part-type.lsp 3.98 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Nov 27 21:15:46 2004
;;;; Contains: Tests of UPGRADE-COMPLEX-PART-TYPE

6

7

8

9 10 11 12

(defmacro def-ucpt-test (name types)
  `(deftest ,name
     (loop for type in (remove-duplicates ,types)
sds's avatar
sds committed
13 14 15 16 17 18 19 20 21 22
           for upgraded-type = (upgraded-complex-part-type type)
           for result = (append (check-all-subtypep type upgraded-type)
                                (check-all-subtypep type 'real)
                                (check-all-subtypep `(complex ,type) 'complex)
                                (check-all-subtypep `(complex ,upgraded-type)
                                                    'complex)
                                (check-all-subtypep `(complex ,type)
                                                    `(complex ,upgraded-type)))
           when result
           collect result)
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
     nil))

(def-ucpt-test upgraded-complex-part-type.1
  '(real integer rational ratio float short-float single-float
    double-float long-float fixnum bignum bit unsigned-byte signed-byte))

(def-ucpt-test upgraded-complex-part-type.2
  (mapcar #'find-class '(real float integer rational ratio)))

(def-ucpt-test upgraded-complex-part-type.3
  (mapcar #'class-of '(1.0s0 1.0f0 1.0d0 1.0l0)))

(def-ucpt-test upgraded-complex-part-type.4
  (loop for i from 1 to 100 collect `(unsigned-byte ,i)))

(def-ucpt-test upgraded-complex-part-type.5
  (loop for i from 1 to 100 collect `(signed-byte ,i)))

(def-ucpt-test upgraded-complex-part-type.6
  (loop for i = 1 then (* i 2)
sds's avatar
sds committed
43 44
        repeat 100
        collect (class-of i)))
45 46 47 48 49

;;; environment argument

(deftest upgraded-complex-part-type.7
  (loop for type in '(real integer rational float short-float
sds's avatar
sds committed
50 51 52 53 54 55
                      single-float double-float long-float fixnum
                      bignum bit unsigned-byte signed-byte)
        for ut1 = (upgraded-complex-part-type type)
        for ut2 = (upgraded-complex-part-type type nil)
        unless (equal ut1 ut2)
        collect (list type ut1 ut2))
56 57 58 59
  nil)

(deftest upgraded-complex-part-type.8
  (loop for type in '(real integer rational float short-float
sds's avatar
sds committed
60 61 62 63 64 65 66 67 68
                      single-float double-float long-float fixnum
                      bignum bit unsigned-byte signed-byte)
        for ut1 = (upgraded-complex-part-type type)
        for ut2 = (eval `(macrolet ((%m (&environment env)
                                        (list 'quote
                                              (upgraded-complex-part-type ',type env))))
                           (%m)))
        unless (equal ut1 ut2)
        collect (list type ut1 ut2))
69 70
  nil)

71 72 73 74
;;; Subtype constraint

(deftest upgraded-complex-part-type.9
  (let* ((types `(nil integer fixnum bignum float
sds's avatar
sds committed
75 76 77 78 79 80 81 82 83 84
                     short-float single-float double-float long-float
                     rational #-sbcl ratio real
                     ,@(remove-duplicates
                        (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000)))
                     ,@(mapcar #'(lambda (x) `(eql ,x))
                               (remove-duplicates
                                '(0.0s0 0.0f0 0.0d0 0.0l0 0
                                  1.0s0 1.0f0 1.0d0 1.0l0 1
                                  100000000000000000)))))
         (utypes (mapcar #'upgraded-complex-part-type types)))
85
    (loop for sublist on types
sds's avatar
sds committed
86 87 88 89 90 91 92 93 94 95 96
          for usublist on utypes
          for tp1 = (car sublist)
          for utp1 = (car usublist)
          nconc (loop for tp2 in (cdr sublist)
                      for utp2 in (cdr usublist)
                      nconc
                      (and (subtypep tp1 tp2)
                           (let ((result (check-all-subtypep utp1 utp2)))
                             (and result
                                  (list (list tp1 tp2 result))))))))
  nil)
97

98 99 100 101 102 103 104 105 106
;;; Error tests

(deftest upgraded-complex-part-type.error.1
  (signals-error (upgraded-complex-part-type) program-error)
  t)

(deftest upgraded-complex-part-type.error.2
  (signals-error (upgraded-complex-part-type 'real nil nil) program-error)
  t)