types-and-class.lsp 8.71 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu Mar 19 21:48:39 1998
;;;; Contains: Data for testing type and class inclusions

;; We should check for every type that NIL is a subtype, and T a supertype

(in-package :cl-test)

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

12 13
(declaim (optimize (safety 3)))

14
(deftest boolean-type.1
15
  (notnot-mv (typep nil 'boolean))
16 17
  t)

18
(deftest boolean-type.2
19
  (notnot-mv (typep t 'boolean))
20 21
  t)

22
(deftest boolean-type.3
23
  (check-type-predicate 'is-t-or-nil 'boolean)
24
  nil)
25

26
(deftest types.3
27 28 29 30 31 32 33 34 35 36 37 38 39
  (loop
   for (t1 t2) in *subtype-table*
   for m1 = (check-subtypep t1 t2 t t)
   for m2 = (check-subtypep `(and ,t1 ,t2) t1 t)
   for m3 = (check-subtypep `(and ,t2 ,t1) t1 t)
   for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t)
   for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t)
   when m1 collect m1
   when m2 collect m2
   when m3 collect m3
   when m4 collect m4
   when m5 collect m5)
  nil)
40

pfdietz's avatar
pfdietz committed
41
(declaim (special +float-types+ *subtype-table*))
42 43 44 45 46

;;; This next test is all screwed up.  Basically, it assumes
;;; incorrectly that certain subtype relationships that are
;;; not specified in the spec cannot occur.
#|
47
(defun types.4-body ()
48
  (let ((parent-table (make-hash-table :test #'equal))
sds's avatar
sds committed
49
        (types nil))
50
    (loop
sds's avatar
sds committed
51 52 53 54 55 56 57 58 59 60 61 62 63
        for p in *subtype-table* do
          (let ((tp (first p))
                (parent (second p)))
            (pushnew tp types)
            (pushnew parent types)
            (let ((parents (gethash tp parent-table)))
              (pushnew parent parents)
              ;; (format t "~S ==> ~S~%" tp parent)
              (loop
                  for pp in (gethash parent parent-table) do
                    ;; (format t "~S ==> ~S~%" tp pp)
                    (pushnew pp parents))
              (setf (gethash tp parent-table) parents))))
64 65
    ;; parent-table now contains lists of ancestors
    (loop
sds's avatar
sds committed
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
        for tp in types sum
          (let ((parents (gethash tp parent-table)))
            (loop
                for tp2 in types sum
                  (cond
                   ((and (not (eqt tp tp2))
                         (not (eqt tp2 'standard-object))
                         (not (eqt tp2 'structure-object))
                         (not (member tp2 parents))
                         (subtypep* tp tp2)
                         (not (and (member tp +float-types+)
                                   (member tp2 +float-types+)))
                         (not (and (eqt tp2 'structure-object)
                                   (member 'standard-object parents))))
                    (format t "~%Improper subtype: ~S of ~S"
                            tp tp2)
                    1)
                   (t 0)))))
84 85
    ))

86 87
(deftest types.4
  (types.4-body)
88
  0)
89
|#
90

91 92
(deftest types.6
  (types.6-body)
93
  nil)
94

95
(declaim (special *disjoint-types-list*))
96

pfdietz's avatar
pfdietz committed
97 98
;;; Check that the disjoint types really are disjoint

99
(deftest types.7b
pfdietz's avatar
pfdietz committed
100
  (loop for e on *disjoint-types-list*
sds's avatar
sds committed
101 102 103 104
        for tp1 = (first e)
        append
        (loop for tp2 in (rest e)
              append (classes-are-disjoint tp1 tp2)))
pfdietz's avatar
pfdietz committed
105
  nil)
106

107
(deftest types.7c
108
  (loop for e on *disjoint-types-list2*
sds's avatar
sds committed
109 110 111 112 113 114 115
        for list1 = (first e)
        append
        (loop for tp1 in list1 append
              (loop for list2 in (rest e)
                    append
                    (loop for tp2 in list2 append
                          (classes-are-disjoint tp1 tp2)))))
116
  nil)
pfdietz's avatar
pfdietz committed
117

118
(deftest types.8
pfdietz's avatar
pfdietz committed
119 120 121 122
  (loop
   for tp in *disjoint-types-list* count
   (cond
    ((and (not (eqt tp 'cons))
sds's avatar
sds committed
123
          (not (subtypep* tp 'atom)))
pfdietz's avatar
pfdietz committed
124 125
     (format t "~%Should be atomic, but isn't: ~S" tp)
     t)))
126 127
  0)

128
(declaim (special *type-list* *supertype-table*))
129

130
;;;
131
;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types
132 133 134 135 136
;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM,
;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used
;;; here.)
;;;

137 138
(deftest types.9
  (types.9-body)
139 140
  nil)

141
;;;
142
;;; TYPES.9A takes the supertype relationship computed by test TYPE.9
143 144 145 146 147 148 149
;;; and checks that TYPEP respects it for all elements of *UNIVERSE*.
;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*,
;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2).
;;;
;;; The function prints error messages when this fails, and returns the
;;; number of occurences of failure.
;;;
150
;;; Test TYPES.9 must be run before this test.
151
;;;
152

153 154
(deftest types.9a
  (types.9a-body)
155 156
  0)

157

pfdietz's avatar
pfdietz committed
158 159 160 161 162 163 164 165
;;; All class names in CL denote classes that are subtypep
;;; equivalent to themselves
(deftest all-classes-are-type-equivalent-to-their-names
  (loop for sym being  the external-symbols of "COMMON-LISP"
       for class = (find-class sym nil)
       when class
       append (check-equivalence sym class))
  nil)
166

167 168
(deftest all-classes-are-type-equivalent-to-their-names.2
  (loop for x in *universe*
sds's avatar
sds committed
169 170 171 172
        for cl = (class-of x)
        for name = (class-name cl)
        when name
        append (check-equivalence name cl))
173 174
  nil)

175 176 177 178 179 180
;;; Check that all class names in CL that name standard-classes or
;;; structure-classes are subtypes of standard-object and structure-object,
;;; respectively

(deftest all-standard-classes-are-subtypes-of-standard-object
  (loop for sym being  the external-symbols of "COMMON-LISP"
sds's avatar
sds committed
181 182 183 184 185 186
        for class = (find-class sym nil)
        when (and class
                  (typep class 'standard-class)
                  (or (not (subtypep sym 'standard-object))
                      (not (subtypep class 'standard-object))))
        collect sym)
187 188
  nil)

189 190
(deftest all-standard-classes-are-subtypes-of-standard-object.2
  (loop for x in *universe*
sds's avatar
sds committed
191 192 193 194
        for class = (class-of x)
        when (and (typep class 'standard-class)
                  (not (subtypep class 'standard-object)))
        collect x)
195 196
  nil)

197 198
(deftest all-structure-classes-are-subtypes-of-structure-object
  (loop for sym being the external-symbols of "COMMON-LISP"
sds's avatar
sds committed
199 200 201 202 203 204
        for class = (find-class sym nil)
        when (and class
                  (typep class 'structure-class)
                  (or (not (subtypep sym 'structure-object))
                      (not (subtypep class 'structure-object))))
        collect sym)
205
  nil)
206 207 208

(deftest all-structure-classes-are-subtypes-of-structure-object.2
  (loop for x in *universe*
sds's avatar
sds committed
209 210 211 212
        for cl = (class-of x)
        when (and (typep cl 'structure-class)
                  (not (subtypep cl 'structure-object)))
        collect x)
213
  nil)
sds's avatar
sds committed
214

215 216 217 218 219
;;; Confirm that only the symbols exported from CL that are supposed
;;; to be types are actually classes (see section 11.1.2.1.1)

(deftest all-exported-cl-class-names-are-valid
  (loop for sym being the external-symbols of "COMMON-LISP"
sds's avatar
sds committed
220 221 222
        when (and (find-class sym nil)
                  (not (member sym *cl-all-type-symbols* :test #'eq)))
        collect sym)
223
  nil)
224

225 226 227 228 229
;;; Confirm that all standard generic functions are instances of
;;; the class standard-generic-function.

(deftest all-standard-generic-functions-are-instances-of-that-class
  (loop for sym in *cl-standard-generic-function-symbols*
sds's avatar
sds committed
230 231 232 233
        for fun = (and (fboundp sym) (symbol-function sym))
        unless (and (typep fun 'generic-function)
                    (typep fun 'standard-generic-function))
        collect (list sym fun))
234 235 236
  nil)

;;; Canonical metaobjects are in the right classes
237

238 239 240 241 242 243 244
(deftest structure-object-is-in-structure-class
  (notnot-mv (typep (find-class 'structure-object) 'structure-class))
  t)

(deftest standard-object-is-in-standard-class
  (notnot-mv (typep (find-class 'standard-object) 'standard-class))
  t)
245

246

247 248
;; This should be greatly expanded

249 250 251 252 253 254 255
(defparameter *type-and-class-fns*
  '(coerce subtypep type-of typep type-error-datum type-error-expected-type))

(deftest type-and-class-fns
  (remove-if #'fboundp *type-and-class-fns*)
  nil)

256 257 258
(deftest type-and-class-macros
  (notnot-mv (macro-function 'deftype))
  t)
259

260 261 262 263 264 265 266 267 268
;;; TYPE-ERROR accessors

(deftest type-error-datum.1
  (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer)))
    (type-error-datum c))
  a)

(deftest type-error-expected-type.1
  (let ((c (make-condition 'type-error
sds's avatar
sds committed
269
                           :datum 'a :expected-type 'integer)))
270 271 272
    (type-error-expected-type c))
  integer)

273 274 275
;;; Error checking of type-related functions

(deftest type-error-datum.error.1
276 277
  (signals-error (type-error-datum) program-error)
  t)
278 279

(deftest type-error-datum.error.2
280
  (signals-error
281
   (let ((c (make-condition 'type-error :datum nil
sds's avatar
sds committed
282
                            :expected-type t)))
283 284 285
     (type-error-datum c nil))
   program-error)
  t)
286 287

(deftest type-error-expected-type.error.1
288
  (signals-error (type-error-expected-type)
sds's avatar
sds committed
289
                 program-error)
290
  t)
291 292

(deftest type-error-expected-type.error.2
293
  (signals-error
294
   (let ((c (make-condition 'type-error :datum nil
sds's avatar
sds committed
295
                            :expected-type t)))
296 297 298
     (type-error-expected-type c nil))
   program-error)
  t)
299