136 |
(if (atom type) |
(if (atom type) |
137 |
(setq tp type i nil) |
(setq tp type i nil) |
138 |
(setq tp (car type) i (cdr type))) |
(setq tp (car type) i (cdr type))) |
139 |
|
(if (eq tp 'structure-object) (setq tp 'structure)) |
140 |
(let ((f (get tp 'type-predicate))) |
(let ((f (get tp 'type-predicate))) |
141 |
(when f (return-from typep (funcall f object)))) |
(when f (return-from typep (funcall f object)))) |
142 |
(case tp |
(case tp |
159 |
(ratio (eq (type-of object) 'ratio)) |
(ratio (eq (type-of object) 'ratio)) |
160 |
(standard-char |
(standard-char |
161 |
(and (characterp object) (standard-char-p object))) |
(and (characterp object) (standard-char-p object))) |
162 |
(string-char |
((base-char string-char) |
163 |
(and (characterp object) (string-char-p object))) |
(and (characterp object) (string-char-p object))) |
164 |
(integer |
(integer |
165 |
(and (integerp object) (in-interval-p object i))) |
(and (integerp object) (in-interval-p object i))) |
211 |
(equal (array-element-type object) (best-array-element-type (car i)))) |
(equal (array-element-type object) (best-array-element-type (car i)))) |
212 |
(or (endp (cdr i)) (eq (cadr i) '*) |
(or (endp (cdr i)) (eq (cadr i) '*) |
213 |
(match-dimensions (array-dimensions object) (cadr i))))) |
(match-dimensions (array-dimensions object) (cadr i))))) |
214 |
(t |
(t |
215 |
(cond ((setq tem (get tp 'si::s-data)) |
(cond ((setq tem (get tp 'si::s-data)) |
216 |
(structure-subtype-p object tem)) |
(structure-subtype-p object tem)) |
217 |
((get tp 'deftype-definition) |
((setq tem (get tp 'deftype-definition)) |
218 |
(typep object |
(typep object |
219 |
(apply (get tp 'deftype-definition) i))))))) |
(apply tem nil))))))) |
220 |
|
|
221 |
|
|
222 |
;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. |
;;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions. |
236 |
;;; The type may not be normalized. |
;;; The type may not be normalized. |
237 |
(defun known-type-p (type) |
(defun known-type-p (type) |
238 |
(when (consp type) (setq type (car type))) |
(when (consp type) (setq type (car type))) |
239 |
(if (or (member type |
(if (or (equal (string type) "ERROR") |
240 |
|
(member type |
241 |
'(t nil boolean null symbol keyword atom cons list sequence |
'(t nil boolean null symbol keyword atom cons list sequence |
242 |
signed-char unsigned-char signed-short unsigned-short |
signed-char unsigned-char signed-short unsigned-short |
243 |
number integer bignum rational ratio float |
number integer bignum rational ratio float method-combination |
244 |
short-float single-float double-float long-float complex |
short-float single-float double-float long-float complex |
245 |
character standard-char string-char |
character standard-char string-char real |
246 |
real |
package stream pathname readtable hash-table random-state |
247 |
package stream pathname readtable hash-table random-state |
structure array simple-array function compiled-function |
248 |
structure array simple-array function compiled-function |
arithmetic-error base-char base-string broadcast-stream |
249 |
arithmetic-error base-char base-string broadcast-stream |
built-in-class cell-error class concatenated-stream condition |
250 |
built-in-class cell-error class concatenated-stream condition |
control-error division-by-zero echo-stream end-of-file error |
251 |
control-error division-by-zero echo-stream end-of-file error |
extended-char file-error file-stream floating-point-inexact |
252 |
extended-char file-error file-stream floating-point-inexact |
floating-point-invalid-operation floating-point-overflow |
253 |
floating-point-invalid-operation floating-point-overflow |
floating-point-underflow generic-function logical-pathname method |
254 |
floating-point-underflow generic-function logical-pathname method |
package-error parse-error print-not-readable program-error |
255 |
package-error parse-error print-not-readable program-error |
reader-error serious-condition simple-base-string simple-condition |
256 |
reader-error serious-condition simple-base-string simple-condition |
simple-type-error simple-warning standard-class |
257 |
simple-type-error simple-warning standard-class standard-generic-function |
standard-generic-function standard-method standard-object |
258 |
standard-method standard-object storage-condition stream-error |
storage-condition stream-error string-stream structure-class |
259 |
string-stream structure-class style-warning synonym-stream two-way-stream |
style-warning synonym-stream two-way-stream structure-object |
260 |
type-error unbound-slot unbound-variable undefined-function warning )) |
type-error unbound-slot unbound-variable undefined-function |
261 |
|
warning )) |
262 |
(get type 's-data)) |
(get type 's-data)) |
263 |
t |
t |
264 |
nil)) |
nil)) |
266 |
|
|
267 |
;;; SUBTYPEP predicate. |
;;; SUBTYPEP predicate. |
268 |
(defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
(defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem) |
269 |
(setq type1 (normalize-type type1)) |
(setq t1 (normalize-type type1)) |
270 |
(setq type2 (normalize-type type2)) |
(setq type1 (if (eq (car t1) 'satisfies) (list type1) t1)) |
271 |
|
(setq t2 (normalize-type type2)) |
272 |
|
(setq type2 (if (eq (car t2) 'satisfies) (list type2) t2)) |
273 |
|
; (setq type1 (normalize-type type1)) |
274 |
|
; (setq type2 (normalize-type type2)) |
275 |
(when (equal type1 type2) |
(when (equal type1 type2) |
276 |
(return-from subtypep (values t t))) |
(return-from subtypep (values t t))) |
277 |
(setq t1 (car type1) t2 (car type2)) |
(setq t1 (car type1) t2 (car type2)) |
317 |
((eq t1 't) (values nil ntp2)) |
((eq t1 't) (values nil ntp2)) |
318 |
((eq t1 'common) (values nil ntp2)) |
((eq t1 'common) (values nil ntp2)) |
319 |
((eq t2 'list) |
((eq t2 'list) |
320 |
(cond ((member t1 '(null cons list)) (values t t)) |
(cond ((member t1 '(null cons)) (values t t)) |
321 |
(t (values nil ntp1)))) |
(t (values nil ntp1)))) |
322 |
((eq t2 'sequence) |
((eq t2 'sequence) |
323 |
(cond ((member t1 '(null cons list sequence base-string simple-base-string)) (values t t)) |
(cond ((member t1 '(null cons list base-string simple-base-string)) |
324 |
|
(values t t)) |
325 |
((or (eq t1 'simple-array) (eq t1 'array)) |
((or (eq t1 'simple-array) (eq t1 'array)) |
326 |
(if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) |
(if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) |
327 |
(values t t) |
(values t t) |
335 |
(t (values nil nil)))) |
(t (values nil nil)))) |
336 |
((eq t1 'atom) (values nil ntp2)) |
((eq t1 'atom) (values nil ntp2)) |
337 |
((eq t2 'symbol) |
((eq t2 'symbol) |
338 |
(if (member t1 '(symbol keyword boolean null)) |
(if (member t1 '(keyword boolean null)) |
339 |
(values t t) |
(values t t) |
340 |
(values nil ntp1))) |
(values nil ntp1))) |
341 |
((eq t2 'function) |
((eq t2 'function) |
346 |
(if (eq t1 'standard-generic-function) |
(if (eq t1 'standard-generic-function) |
347 |
(values t t) |
(values t t) |
348 |
(values nil ntp1))) |
(values nil ntp1))) |
349 |
|
((eq t2 'boolean) |
350 |
|
(if (eq t1 'null) |
351 |
|
(values t t) |
352 |
|
(values nil ntp1))) |
353 |
|
((eq t2 'standard-object) |
354 |
|
(if (member t1 '(class built-in-class structure-class standard-class |
355 |
|
method standard-method)) |
356 |
|
(values t t) |
357 |
|
(values nil ntp1))) |
358 |
|
((eq t2 'class) |
359 |
|
(if (member t1 '(built-in-class structure-class standard-class )) |
360 |
|
(values t t) |
361 |
|
(values nil ntp1))) |
362 |
|
((eq t2 'condition) |
363 |
|
(if (or (equal (string t1) "ERROR") |
364 |
|
(member t1 '(serious-condition error type-error simple-type-error |
365 |
|
parse-error cell-error unbound-slot |
366 |
|
warning style-warning storage-condition |
367 |
|
simple-warning unbound-variable control-error |
368 |
|
program-error undefined-function |
369 |
|
package-error arithmetic-error |
370 |
|
division-by-zero simple-condition |
371 |
|
floating-point-invalid-operation |
372 |
|
floating-point-inexact |
373 |
|
floating-point-overflow |
374 |
|
floating-point-underflow |
375 |
|
file-error stream-error end-of-file |
376 |
|
print-not-readable |
377 |
|
reader-error))) |
378 |
|
(values t t) |
379 |
|
(values nil ntp1))) |
380 |
|
((eq t2 'serious-condition) |
381 |
|
(if (or (equal (string t1) "ERROR") |
382 |
|
(member t1 '( error type-error simple-type-error |
383 |
|
parse-error cell-error unbound-slot |
384 |
|
storage-condition |
385 |
|
unbound-variable control-error |
386 |
|
program-error undefined-function |
387 |
|
package-error arithmetic-error |
388 |
|
division-by-zero simple-type-error |
389 |
|
floating-point-invalid-operation |
390 |
|
floating-point-inexact |
391 |
|
floating-point-overflow |
392 |
|
floating-point-underflow |
393 |
|
file-error stream-error end-of-file |
394 |
|
print-not-readable |
395 |
|
reader-error))) |
396 |
|
(values t t) |
397 |
|
(values nil ntp1))) |
398 |
|
((eq t2 'type-error) |
399 |
|
(if (eq t1 'simple-type-error) |
400 |
|
(values t t) |
401 |
|
(values nil ntp1))) |
402 |
|
((eq t2 'parse-error) |
403 |
|
(if (eq t1 'reader-error) |
404 |
|
(values t t) |
405 |
|
(values nil ntp1))) |
406 |
|
((eq t2 'stream-error) |
407 |
|
(if (member t1 '(reader-error end-of-file)) |
408 |
|
(values t t) |
409 |
|
(values nil ntp1))) |
410 |
|
((or (equal (string t2) "ERROR") (eq t2 'error)) |
411 |
|
(if (member t1 '(simple-type-error type-error |
412 |
|
parse-error cell-error unbound-slot |
413 |
|
unbound-variable control-error |
414 |
|
program-error undefined-function |
415 |
|
package-error arithmetic-error |
416 |
|
division-by-zero simple-type-error |
417 |
|
floating-point-invalid-operation |
418 |
|
floating-point-inexact |
419 |
|
floating-point-overflow |
420 |
|
floating-point-underflow |
421 |
|
file-error stream-error end-of-file print-not-readable |
422 |
|
reader-error )) |
423 |
|
(values t t) |
424 |
|
(values nil ntp1))) |
425 |
|
((eq t2 'stream) |
426 |
|
(if (member t1 '(broadcast-stream concatenated-stream echo-stream file-stream |
427 |
|
string-stream synonym-stream two-way-stream)) |
428 |
|
(values t t) |
429 |
|
(values nil ntp1))) |
430 |
|
((eq t2 'pathname) |
431 |
|
(if (eq t1 'logical-pathname) |
432 |
|
(values t t) |
433 |
|
(values nil ntp1))) |
434 |
|
((eq t2 'method) |
435 |
|
(if (eq t1 'standard-method) |
436 |
|
(values t t) |
437 |
|
(values nil ntp1))) |
438 |
|
((eq t2 'simple-condition) |
439 |
|
(if (member t1 '(simple-type-error simple-warning)) |
440 |
|
(values t t) |
441 |
|
(values nil ntp1))) |
442 |
|
((eq t2 'simple-condition) |
443 |
|
(if (member t1 '(simple-type-error simple-warning)) |
444 |
|
(values t t) |
445 |
|
(values nil ntp1))) |
446 |
|
((eq t2 'cell-error) |
447 |
|
(if (member t1 '(unbound-slot unbound-variable undefined-function)) |
448 |
|
(values t t) |
449 |
|
(values nil ntp1))) |
450 |
|
((eq t2 'warning) |
451 |
|
(if (member t1 '(style-warning simple-warning)) |
452 |
|
(values t t) |
453 |
|
(values nil ntp1))) |
454 |
|
((eq t2 'arithmetic-error) |
455 |
|
(if (member t1 '(division-by-zero |
456 |
|
floating-point-invalid-operation |
457 |
|
floating-point-inexact |
458 |
|
floating-point-overflow |
459 |
|
floating-point-underflow )) |
460 |
|
(values t t) |
461 |
|
(values nil ntp1))) |
462 |
((eq t2 'keyword) |
((eq t2 'keyword) |
463 |
(if (eq t1 'keyword) (values t t) (values nil ntp1))) |
(if (eq t1 'keyword) (values t t) (values nil ntp1))) |
464 |
((eq t2 'null) |
((eq t2 'null) |
470 |
(values t t)) |
(values t t)) |
471 |
(t (values nil ntp1)))) |
(t (values nil ntp1)))) |
472 |
((eq t1 'number) (values nil ntp2)) |
((eq t1 'number) (values nil ntp2)) |
473 |
((eq t2 'structure) |
((or (eq t2 'structure) (eq t2 'structure-object)) |
474 |
(if (or (eq t1 'structure) (get t1 'si::s-data)) |
(if (or (eq t1 'structure) (get t1 'si::s-data)) |
475 |
(values t t) |
(values t t) |
476 |
(values nil ntp1))) |
(values nil ntp1))) |
484 |
(t (values nil ntp2))))) |
(t (values nil ntp2))))) |
485 |
((eq t2 'real) |
((eq t2 'real) |
486 |
(cond ((and |
(cond ((and |
487 |
(member t1 '(fixnum integer bignum float |
(member t1 '(fixnum integer bignum float short-float |
488 |
single-float double-float long-float |
single-float double-float long-float |
489 |
real |
real ratio |
490 |
rational)) |
rational)) |
491 |
(sub-interval-p i1 i2)) |
(sub-interval-p i1 i2)) |
492 |
(values t t)) |
(values t t)) |
504 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
505 |
(ratio |
(ratio |
506 |
(case t2 |
(case t2 |
|
(ratio (values t t)) |
|
507 |
(rational |
(rational |
508 |
(if (sub-interval-p '(* *) i2) (values t t) (values nil t))) |
(if (sub-interval-p '(* *) i2) (values t t) (values nil t))) |
509 |
(t (values nil ntp2)))) |
(t (values nil ntp2)))) |
510 |
(standard-char |
(standard-char |
511 |
(if (member t2 '(standard-char string-char character)) |
(if (member t2 '(base-char string-char character)) |
512 |
(values t t) |
(values t t) |
513 |
(values nil ntp2))) |
(values nil ntp2))) |
514 |
(base-string |
(base-string |
519 |
(if (member t2 '(character string-char)) |
(if (member t2 '(character string-char)) |
520 |
(values t t) |
(values t t) |
521 |
(values nil ntp2))) |
(values nil ntp2))) |
522 |
|
(extended-char |
523 |
|
(if (member t2 '(character string-char)) |
524 |
|
(values t t) |
525 |
|
(values nil ntp2))) |
526 |
(simple-base-string |
(simple-base-string |
527 |
(if (member t2 '(string simple-string base-string vector |
(if (member t2 '(string simple-string base-string vector |
528 |
simple-vector simple-array array sequence)) |
simple-vector simple-array array sequence)) |
529 |
(values t t) |
(values t t) |
530 |
(values nil ntp2))) |
(values nil ntp2))) |
531 |
(string-char |
(string-char |
532 |
(if (member t2 '(string-char character)) |
(if (eq t2 'character) |
533 |
(values t t) |
(values t t) |
534 |
(values nil ntp2))) |
(values nil ntp2))) |
535 |
(character |
(character |
536 |
(if (member t2 '(string-char character)) |
(if (eq t2 'string-char) |
537 |
(values t t) |
(values t t) |
538 |
(values nil ntp2))) |
(values nil ntp2))) |
539 |
(integer |
(integer |