/[gcl]/gcl/ansi-tests/types-and-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/types-and-class.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by pfdietz, Wed Oct 23 03:10:23 2002 UTC revision 1.8 by pfdietz, Tue Nov 5 12:44:24 2002 UTC
# Line 157  Line 157 
157                 (t2 (second pair)))                 (t2 (second pair)))
158             (cond             (cond
159              ((not (subtypep* t1 t2))              ((not (subtypep* t1 t2))
160               (format t "~%~S not a subtype of ~S" t1 t2)               (format t "~%Problem!  Did not find ~S to be a subtype of ~S" t1 t2)
161               t)               t)
162              (t nil))))              (t nil))))
163       *subtype-table*)       *subtype-table*)
# Line 226  Line 226 
226            (cond            (cond
227             ((and (not (member tp '(sequence cons list t)))             ((and (not (member tp '(sequence cons list t)))
228                   (not (subtypep* tp 'atom)))                   (not (subtypep* tp 'atom)))
229              (format t "~%Not an atomic type: ~S" tp)              (format t "~%Problem!  Did not find to be an atomic type: ~S" tp)
230              t)))))              t)))))
231    
232  (deftest types-6  (deftest types-6
# Line 259  Line 259 
259  (defvar *type-list* nil)  (defvar *type-list* nil)
260  (defvar *supertype-table* nil)  (defvar *supertype-table* nil)
261    
262    ;;;
263    ;;; TYPES-9 checks the transitivity of SUBTYPEP on pairs of types
264    ;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM,
265    ;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used
266    ;;; here.)
267    ;;;
268    
269  (defun types-9-body ()  (defun types-9-body ()
270    (let ((tp-list (append '(keyword atom list)    (let ((tp-list (append '(keyword atom list)
271                           (loop for p in *subtype-table* collect (car p))))                           (loop for p in *subtype-table* collect (car p))))
272          (result-list))          (result-list))
273      (setf tp-list (remove-duplicates tp-list))      (setf tp-list (remove-duplicates tp-list))
274        ;; TP-LIST is now a list of unique CL type names
275        ;; Store it in *TYPE-LIST* so we can inspect it later if this test
276        ;; fails.  The variable is also used in test TYPES-9A
277      (setf *type-list* tp-list)      (setf *type-list* tp-list)
278        ;; Compute all pairwise SUBTYPEP relationships among
279        ;; the elements of *TYPE-LIST*.
280      (let ((subs (make-hash-table :test #'eq))      (let ((subs (make-hash-table :test #'eq))
281            (sups (make-hash-table :test #'eq)))            (sups (make-hash-table :test #'eq)))
282        (loop        (loop
# Line 277  Line 289 
289                      (when result                      (when result
290                        (pushnew x (gethash y subs))                        (pushnew x (gethash y subs))
291                        (pushnew y (gethash x sups))))))                        (pushnew y (gethash x sups))))))
292          ;; Store the supertype relations for later inspection
293          ;; and use in test TYPES-9A
294        (setf *supertype-table* sups)        (setf *supertype-table* sups)
295          ;; Check that the relation we just computed is transitive.
296          ;; Return a list of triples on which transitivity fails.
297        (loop        (loop
298            for x in tp-list do            for x in tp-list do
299              (let ((sub-list (gethash x subs))              (let ((sub-list (gethash x subs))
# Line 294  Line 310 
310                
311        result-list)))        result-list)))
312    
313    ;;; TYPES-9-BODY returns a list of triples (T1 T2 T3)
314    ;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3)))
315    ;;;  (and where SUBTYPEP succeeds in each case, returning true as its
316    ;;;   second return value.)
317  (deftest types-9  (deftest types-9
318      (types-9-body)      (types-9-body)
319    nil)    nil)
320    
321    ;;;
322    ;;; TYPES-9A takes the supertype relationship computed by test TYPE-9
323    ;;; and checks that TYPEP respects it for all elements of *UNIVERSE*.
324    ;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*,
325    ;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2).
326    ;;;
327    ;;; The function prints error messages when this fails, and returns the
328    ;;; number of occurences of failure.
329    ;;;
330    ;;; Test TYPES-9 must be run before this test.
331    ;;;
332  (defun types-9a-body ()  (defun types-9a-body ()
333    (cond    (cond
334       ((not (and *type-list* *supertype-table*))       ((not (and *type-list* *supertype-table*))
# Line 321  Line 352 
352                              (handler-case                              (handler-case
353                                  (and (not (typep x tp2))                                  (and (not (typep x tp2))
354                                       (progn                                       (progn
355                                         (format t "Found element of ~S not in ~S ~S~%"                                         (format t "Found element of ~S not in ~S: ~S~%"
356                                                 tp tp2 x)                                                 tp tp2 x)
357                                         t))                                         t))
358                                (condition (c) (format t "Error ~S occured: ~S~%"                                (condition (c) (format t "Error ~S occured: ~S~%"
# Line 354  Line 385 
385    nil)    nil)
386    
387  (deftest deftype-3  (deftest deftype-3
388      (not (not (typep (make-array '(10)) '(even-array t (*)))))    (notnot (typep (make-array '(10)) '(even-array t (*))))
389    t)    t)
390    
391  (deftest deftype-4  (deftest deftype-4
392      (typep (make-array '(5)) '(even-array t (*)))    (typep (make-array '(5)) '(even-array t (*)))
393    nil)    nil)
394    
395  (deftest deftype-5  (deftest deftype-5
396      (not (not (typep (make-string 10) '(even-array character (*)))))    (notnot (typep (make-string 10) '(even-array character (*))))
397    t)    t)
398    
399  (deftest deftype-6  (deftest deftype-6
400      (not (not    (notnot
401            (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8))     (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8))
402             '(even-array (unsigned-byte 8)))))            '(even-array (unsigned-byte 8))))
403    t)    t)
404    
405  ;; This should be greatly expanded  ;; This should be greatly expanded
406    
   
407  (defparameter *type-and-class-fns*  (defparameter *type-and-class-fns*
408    '(coerce subtypep type-of typep type-error-datum type-error-expected-type))    '(coerce subtypep type-of typep type-error-datum type-error-expected-type))
409    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26