upgraded-array-element-type.lsp 4 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9 10
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Wed Jan 22 20:43:55 2003
;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE

(in-package :cl-test)

(deftest upgraded-array-element-type.1
  (let ((upgraded-bit (upgraded-array-element-type 'bit)))
    (and (empirical-subtypep 'bit upgraded-bit)
sds's avatar
sds committed
11
         (empirical-subtypep upgraded-bit 'bit)))
pfdietz's avatar
pfdietz committed
12 13 14 15 16
  t)

(deftest upgraded-array-element-type.2
  (let ((upgraded-base-char (upgraded-array-element-type 'base-char)))
    (and (empirical-subtypep 'base-char upgraded-base-char)
sds's avatar
sds committed
17
         (empirical-subtypep upgraded-base-char 'base-char)))
pfdietz's avatar
pfdietz committed
18 19 20 21 22
  t)

(deftest upgraded-array-element-type.3
  (let ((upgraded-character (upgraded-array-element-type 'character)))
    (and (empirical-subtypep 'character upgraded-character)
sds's avatar
sds committed
23
         (empirical-subtypep upgraded-character 'character)))
pfdietz's avatar
pfdietz committed
24 25 26 27 28 29 30
  t)

(defparameter *upgraded-array-types-to-check*
  `(boolean
    base-char
    character
    t
31 32 33
    ,@(loop for i from 0 to 32 collect `(eql ,(ash 1 i)))
    ,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i))))
    (eql -1)
pfdietz's avatar
pfdietz committed
34
    ,@(loop for i from 0 to 32
sds's avatar
sds committed
35
            collect `(integer 0 (,(ash 1 i))))
pfdietz's avatar
pfdietz committed
36 37
    symbol
    ,@(loop for i from 0 to 32
sds's avatar
sds committed
38
            collect `(integer ,(- (ash 1 i)) (,(ash 1 i))))
pfdietz's avatar
pfdietz committed
39
    (integer -10000000000000000000000000000000000
sds's avatar
sds committed
40
             10000000000000000000000000000000000)
pfdietz's avatar
pfdietz committed
41
    float
pfdietz's avatar
pfdietz committed
42
    short-float
pfdietz's avatar
pfdietz committed
43 44 45 46 47 48 49 50 51 52 53 54 55 56
    single-float
    double-float
    complex
    rational
    fixnum
    function
    sequence
    list
    cons
    atom
    symbol))

(deftest upgraded-array-element-type.4
  (loop for type in *upgraded-array-types-to-check*
sds's avatar
sds committed
57 58 59
        for upgraded-type = (upgraded-array-element-type type)
        unless (empirical-subtypep type upgraded-type)
        collect (list type upgraded-type))
60
  nil)
pfdietz's avatar
pfdietz committed
61 62 63 64 65 66

;; Include an environment (NIL, denoting the default null lexical
;; environment)

(deftest upgraded-array-element-type.5
  (loop for type in *upgraded-array-types-to-check*
sds's avatar
sds committed
67 68 69
        for upgraded-type = (upgraded-array-element-type type nil)
        unless (empirical-subtypep type upgraded-type)
        collect (list type upgraded-type))
70
  nil)
71 72 73 74

(deftest upgraded-array-element-type.6
  (macrolet
      ((%foo (&environment env)
sds's avatar
sds committed
75 76 77
             (empirical-subtypep
              'bit
              (upgraded-array-element-type 'bit env))))
78 79
    (%foo))
  t)
80

pfdietz's avatar
pfdietz committed
81 82
(deftest upgraded-array-element-type.7
  (let ((upgraded-types (mapcar #'upgraded-array-element-type
sds's avatar
sds committed
83
                                *upgraded-array-types-to-check*)))
pfdietz's avatar
pfdietz committed
84
    (loop for type in *upgraded-array-types-to-check*
sds's avatar
sds committed
85 86 87 88 89 90 91 92
          for upgraded-type in upgraded-types
          append
          (loop for type2 in *upgraded-array-types-to-check*
                for upgraded-type2 in upgraded-types
                when (and (subtypep type type2)
                          (equal (subtypep* upgraded-type upgraded-type)
                                 '(nil t)))
                collect (list type type2))))
pfdietz's avatar
pfdietz committed
93 94
  nil)

95 96 97 98 99
;;; Tests that if Tx is a subtype of Ty, then UAET(Tx) is a subtype
;;;  of UAET(Ty)  (see section 15.1.2.1, paragraph 3)

(deftest upgraded-array-element-type.8
  (let ((upgraded-types (mapcar #'upgraded-array-element-type
sds's avatar
sds committed
100
                                *upgraded-array-types-to-check*)))
101
    (loop for type1 in *upgraded-array-types-to-check*
sds's avatar
sds committed
102 103 104 105 106 107 108
          for uaet1 in upgraded-types
          append
          (loop for type2 in *upgraded-array-types-to-check*
                for uaet2 in upgraded-types
                when (and (subtypep type1 type2)
                        (not (empirical-subtypep uaet1 uaet2)))
                collect (list type1 type2))))
109 110
  nil)

111 112 113 114
;;; Tests of upgrading NIL (it should be type equivalent to NIL)

(deftest upgraded-array-element-type.nil.1
  (let ((uaet-nil (upgraded-array-element-type nil)))
115
    (check-predicate (typef `(not ,uaet-nil))))
116
  nil)
sds's avatar
sds committed
117

pfdietz's avatar
pfdietz committed
118 119 120
;;; Error tests

(deftest upgraded-array-element-type.error.1
121 122
  (signals-error (upgraded-array-element-type) program-error)
  t)
pfdietz's avatar
pfdietz committed
123 124

(deftest upgraded-array-element-type.error.2
125 126
  (signals-error (upgraded-array-element-type 'bit nil nil) program-error)
  t)