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

(in-package :cl-test)

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

(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)

pfdietz's avatar
pfdietz committed
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)))
pfdietz's avatar
pfdietz committed
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)
pfdietz's avatar
pfdietz committed
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)