/[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.16 by pfdietz, Wed Jan 29 23:57:33 2003 UTC revision 1.17 by pfdietz, Fri Jan 31 01:58:10 2003 UTC
# Line 28  Line 28 
28  ;; These should get removed when I get a more up to date  ;; These should get removed when I get a more up to date
29  ;; image for that platform -- pfd  ;; image for that platform -- pfd
30    
31  (defparameter *subtype-table*  
 (let ((table  
        '(  
          (null symbol)  
          (symbol t)  
          #-(and cmu (not sparc)) (boolean symbol)  
          (standard-object t)  
          (function t)  
          (compiled-function function)  
          (generic-function function)  
          (standard-generic-function generic-function)  
          (class standard-object)  
          (built-in-class class)  
          (structure-class class)  
          (standard-class class)  
          (method standard-object)  
          (standard-method method)  
          (structure-object t)  
          (method-combination t)  
          (condition t)  
          (serious-condition condition)  
          (error serious-condition)  
          (type-error error)  
          (simple-type-error type-error)  
          (simple-condition condition)  
          (simple-type-error simple-condition)  
          (parse-error error)  
          (hash-table t)  
          (cell-error error)  
          (unbound-slot cell-error)  
          (warning condition)  
          (style-warning warning)  
          (storage-condition serious-condition)  
          (simple-warning warning)  
          (simple-warning simple-condition)  
          (keyword symbol)  
          (unbound-variable cell-error)  
          (control-error error)  
          (program-error error)  
          (undefined-function cell-error)  
          (package t)  
          (package-error error)  
          (random-state t)  
          (number t)  
          (real number)  
          (complex number)  
          (float real)  
          (short-float float)  
          (single-float float)  
          (double-float float)  
          (long-float float)  
          (rational real)  
          (integer rational)  
          (ratio rational)  
          (signed-byte integer)  
          (integer signed-byte)  
          (unsigned-byte signed-byte)  
          (bit unsigned-byte)  
          (fixnum integer)  
          (bignum integer)  
          (bit fixnum)  
          (arithmetic-error error)  
          (division-by-zero arithmetic-error)  
          (floating-point-invalid-operation arithmetic-error)  
          (floating-point-inexact arithmetic-error)  
          (floating-point-overflow arithmetic-error)  
          (floating-point-underflow arithmetic-error)  
          (character t)  
          (base-char character)  
          (standard-char base-char)  
          (extended-char character)  
          (sequence t)  
          (list sequence)  
          (null list)  
          #-(and cmu (not sparc)) (null boolean)  
          (cons list)  
          (array t)  
          (simple-array array)  
          (vector sequence)  
          (vector array)  
          (string vector)  
          (bit-vector vector)  
          (simple-vector vector)  
          (simple-vector simple-array)  
          (simple-bit-vector bit-vector)  
          (simple-bit-vector simple-array)  
          (base-string string)  
          (simple-string string)  
          (simple-string simple-array)  
          (simple-base-string base-string)  
          (simple-base-string simple-string)  
          (pathname t)  
          (logical-pathname pathname)  
          (file-error error)  
          (stream t)  
          (broadcast-stream stream)  
          (concatenated-stream stream)  
          (echo-stream stream)  
          (file-stream stream)  
          (string-stream stream)  
          (synonym-stream stream)  
          (two-way-stream stream)  
          (stream-error error)  
          (end-of-file stream-error)  
          (print-not-readable error)  
          (readtable t)  
          (reader-error parse-error)  
          (reader-error stream-error)  
          )))  
   (when (subtypep* 'character 'base-char)  
     (setq table  
           (append  
            '((character base-char)  
              (string base-string)  
              (simple-string simple-base-string))  
            table)))  
     
   table))  
32    
33  (deftest types-3  (deftest types-3
34      (count-if      (count-if
# Line 160  Line 43 
43       *subtype-table*)       *subtype-table*)
44    0)    0)
45    
46  (defparameter +float-types+  (declaim (special +float-types+ *subtype-table*))
   '(long-float double-float short-float single-float))  
   
47    
48  ;;; This next test is all screwed up.  Basically, it assumes  ;;; This next test is all screwed up.  Basically, it assumes
49  ;;; incorrectly that certain subtype relationships that are  ;;; incorrectly that certain subtype relationships that are
# Line 218  Line 99 
99    
100  (declaim (special *disjoint-types-list*))  (declaim (special *disjoint-types-list*))
101    
102    ;;; Check that the disjoint types really are disjoint
103    
104  (deftest types-7  (deftest types-7
105      (loop    (loop
106          for tp in *disjoint-types-list* sum     for tp in *disjoint-types-list* sum
107            (loop for tp2 in *disjoint-types-list* count     (loop for tp2 in *disjoint-types-list* count
108                  (and (not (eqt tp tp2))           (and (not (eqt tp tp2))
109                       (subtypep* tp tp2))))                (subtypep* tp tp2))))
110    0)    0)
111    
112    (deftest types-7a
113      (loop
114       for tp in *disjoint-types-list* sum
115       (loop for tp2 in *disjoint-types-list* count
116             (and (not (eqt tp tp2))
117                  (multiple-value-bind (sub valid)
118                      (subtypep `(not ,tp) `(not ,tp2))
119                    (and sub valid)))))
120      0)
121    
122    (deftest types-7b
123      (loop for e on *disjoint-types-list*
124            for tp1 = (first e)
125            append
126            (loop for tp2 in (rest e)
127                  for result = (check-disjointness tp1 tp2)
128                  append result))
129      nil)
130            
131    
132  (deftest types-8  (deftest types-8
133      (loop    (loop
134          for tp in *disjoint-types-list* count     for tp in *disjoint-types-list* count
135            (cond     (cond
136             ((and (not (eqt tp 'cons))      ((and (not (eqt tp 'cons))
137                   (not (subtypep* tp 'atom)))            (not (subtypep* tp 'atom)))
138              (format t "~%Should be atomic, but isn't: ~S" tp)       (format t "~%Should be atomic, but isn't: ~S" tp)
139              t)))       t)))
140    0)    0)
141    
142  (declaim (special *type-list*  (declaim (special *type-list*
# Line 247  Line 150 
150  ;;;  ;;;
151    
152  (deftest types-9  (deftest types-9
153      (types-9-body)    (types-9-body)
154    nil)    nil)
155    
156  ;;;  ;;;
# Line 263  Line 166 
166  ;;;  ;;;
167    
168  (deftest types-9a  (deftest types-9a
169      (types-9a-body)    (types-9a-body)
170    0)    0)
171    
172  ;;;  ;;;
# Line 278  Line 181 
181          collect (list e types))          collect (list e types))
182    nil)    nil)
183    
184    (deftest integer-and-ratio-are-disjoint
185      (check-disjointness 'integer 'ratio)
186      nil)
187    
188    (deftest integer-and-float-are-disjoint
189      (check-disjointness 'integer 'float)
190      nil)
191    
192    (deftest ratio-and-float-are-disjoint
193      (check-disjointness 'ratio 'float)
194      nil)
195    
196    (deftest complex-and-float-are-disjoint
197      (check-disjointness 'complex 'float)
198      nil)
199    
200  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
201  ;;; deftype  ;;; deftype
202    

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

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