143 |
(defun class-precedence-list (object) |
(defun class-precedence-list (object) |
144 |
(declare (ignore object)) |
(declare (ignore object)) |
145 |
nil) |
nil) |
146 |
|
(defun find-class (object) |
147 |
|
(declare (ignore object)) |
148 |
|
nil) |
149 |
|
|
150 |
;;; TYPEP predicate. |
;;; TYPEP predicate. |
151 |
;;; FIXME --optimize with most likely cases first |
;;; FIXME --optimize with most likely cases first |
203 |
(sequence (or (listp object) (vectorp object))) |
(sequence (or (listp object) (vectorp object))) |
204 |
((base-string string) ;FIXME |
((base-string string) ;FIXME |
205 |
(and (stringp object) |
(and (stringp object) |
206 |
(or (null i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
207 |
(bit-vector |
(bit-vector |
208 |
(and (bit-vector-p object) |
(and (bit-vector-p object) |
209 |
(or (null i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
210 |
((simple-base-string simple-string) ;FIXME |
((simple-base-string simple-string) ;FIXME |
211 |
(and (simple-string-p object) |
(and (simple-string-p object) |
212 |
(or (null i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
213 |
(simple-bit-vector |
(simple-bit-vector |
214 |
(and (simple-bit-vector-p object) |
(and (simple-bit-vector-p object) |
215 |
(or (null i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (match-dimensions (array-dimensions object) i)))) |
216 |
(simple-vector |
(simple-vector |
217 |
(and (simple-vector-p object) |
(and (simple-vector-p object) |
218 |
(or (null i) (match-dimensions (array-dimensions object) i)))) |
(or (endp i) (eq (car i) '*) |
219 |
|
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
220 |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
221 |
|
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
222 |
|
(vector |
223 |
|
(and (vectorp object) |
224 |
|
(or (endp i) (eq (car i) '*) |
225 |
|
(and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object))) |
226 |
|
(equal (array-element-type object) (best-array-element-type (car i)))) |
227 |
|
(or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i))))) |
228 |
(simple-array |
(simple-array |
229 |
(and (simple-array-p object) |
(and (simple-array-p object) |
230 |
(or (endp i) (eq (car i) '*) |
(or (endp i) (eq (car i) '*) |
231 |
(equal (array-element-type object)(best-array-element-type (car i)))) |
(equal (array-element-type object)(best-array-element-type (car i)))) |
232 |
(or (endp (cdr i)) (eq (cadr i) '*) |
(or (endp (cdr i)) (eq (cadr i) '*) |
233 |
(match-dimensions (array-dimensions object) (cadr i))))) |
(if (listp (cadr i)) |
234 |
|
(match-dimensions (array-dimensions object) (cadr i)) |
235 |
|
(eql (array-rank object) (cadr i)))))) |
236 |
(array |
(array |
237 |
(and (arrayp object) |
(and (arrayp object) |
238 |
(or (endp i) (eq (car i) '*) |
(or (endp i) (eq (car i) '*) |
240 |
;; Is this too strict? |
;; Is this too strict? |
241 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
(equal (array-element-type object) (best-array-element-type (car i)))) |
242 |
(or (endp (cdr i)) (eq (cadr i) '*) |
(or (endp (cdr i)) (eq (cadr i) '*) |
243 |
(match-dimensions (array-dimensions object) (cadr i))))) |
(if (listp (cadr i)) |
244 |
|
(match-dimensions (array-dimensions object) (cadr i)) |
245 |
|
(eql (array-rank object) (cadr i)))))) |
246 |
(t |
(t |
247 |
(cond ((setq tem (get tp 'si::s-data)) |
(cond ((setq tem (get tp 'si::s-data)) |
248 |
(structure-subtype-p object tem)) |
(structure-subtype-p object tem)) |
303 |
(return-from subtypep |
(return-from subtypep |
304 |
(if (member type2 (class-precedence-list type1)) |
(if (member type2 (class-precedence-list type1)) |
305 |
(values t t) (values nil t)))) |
(values t t) (values nil t)))) |
306 |
|
(when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object))) |
307 |
|
(return-from subtypep |
308 |
|
(if (member (find-class type2) (class-precedence-list type1)) |
309 |
|
(values t t) (values nil t)))) |
310 |
(when (or c1 c2) |
(when (or c1 c2) |
311 |
(return-from subtypep (values nil t)))) |
(return-from subtypep (values nil t)))) |
312 |
(setq t1 (normalize-type type1)) |
(setq t1 (normalize-type type1)) |