136 |
(loop for e in *universe* |
(loop for e in *universe* |
137 |
always (or (not (typep e type1)) (typep e type2)))))) |
always (or (not (typep e type1)) (typep e type2)))))) |
138 |
|
|
139 |
|
;;; Check that the subtype relationships implied |
140 |
|
;;; by disjointness are not contradicted. Return NIL |
141 |
|
;;; if ok, or a list of error messages if not. |
142 |
|
(defun check-disjointness (type1 type2) |
143 |
|
(remove 'nil |
144 |
|
(list |
145 |
|
(check-subtypep type1 type2 nil) |
146 |
|
(check-subtypep type2 type1 nil) |
147 |
|
(check-subtypep type1 `(not ,type2) t) |
148 |
|
(check-subtypep type2 `(not ,type1) t) |
149 |
|
(check-subtypep `(and ,type1 ,type2) nil t) |
150 |
|
(check-subtypep `(and ,type2 ,type1) nil t) |
151 |
|
))) |
152 |
|
|
153 |
|
(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) |
154 |
|
(multiple-value-bind |
155 |
|
(sub valid) |
156 |
|
(subtypep* type1 type2) |
157 |
|
(cond |
158 |
|
(valid |
159 |
|
(cond |
160 |
|
((and sub (not is-sub)) |
161 |
|
`((SUBTYPEP ',type1 ',type2) |
162 |
|
"==> <true>, <true>, expected NIL.")) |
163 |
|
((and (not sub) is-sub) |
164 |
|
`((SUBTYPEP ',type1 ',type2) |
165 |
|
"==> <false>, <true>, expected <true>.")) |
166 |
|
(t nil))) |
167 |
|
(should-be-valid |
168 |
|
`((SUBTYPEP ',type1 ',type2) "did not succeed but should have.")) |
169 |
|
(t nil)))) |
170 |
|
|
171 |
(defun check-type-predicate (P TYPE) |
(defun check-type-predicate (P TYPE) |
172 |
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) |
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) |
173 |
by applying both to all elements of *UNIVERSE*. Print message |
by applying both to all elements of *UNIVERSE*. Print message |
474 |
|
|
475 |
;;; From types-and-class.lsp |
;;; From types-and-class.lsp |
476 |
|
|
477 |
|
(defparameter +float-types+ |
478 |
|
'(long-float double-float short-float single-float)) |
479 |
|
|
480 |
|
(defparameter *subtype-table* |
481 |
|
(let ((table |
482 |
|
'( |
483 |
|
(null symbol) |
484 |
|
(symbol t) |
485 |
|
#-(and cmu (not sparc)) (boolean symbol) |
486 |
|
(standard-object t) |
487 |
|
(function t) |
488 |
|
(compiled-function function) |
489 |
|
(generic-function function) |
490 |
|
(standard-generic-function generic-function) |
491 |
|
(class standard-object) |
492 |
|
(built-in-class class) |
493 |
|
(structure-class class) |
494 |
|
(standard-class class) |
495 |
|
(method standard-object) |
496 |
|
(standard-method method) |
497 |
|
(structure-object t) |
498 |
|
(method-combination t) |
499 |
|
(condition t) |
500 |
|
(serious-condition condition) |
501 |
|
(error serious-condition) |
502 |
|
(type-error error) |
503 |
|
(simple-type-error type-error) |
504 |
|
(simple-condition condition) |
505 |
|
(simple-type-error simple-condition) |
506 |
|
(parse-error error) |
507 |
|
(hash-table t) |
508 |
|
(cell-error error) |
509 |
|
(unbound-slot cell-error) |
510 |
|
(warning condition) |
511 |
|
(style-warning warning) |
512 |
|
(storage-condition serious-condition) |
513 |
|
(simple-warning warning) |
514 |
|
(simple-warning simple-condition) |
515 |
|
(keyword symbol) |
516 |
|
(unbound-variable cell-error) |
517 |
|
(control-error error) |
518 |
|
(program-error error) |
519 |
|
(undefined-function cell-error) |
520 |
|
(package t) |
521 |
|
(package-error error) |
522 |
|
(random-state t) |
523 |
|
(number t) |
524 |
|
(real number) |
525 |
|
(complex number) |
526 |
|
(float real) |
527 |
|
(short-float float) |
528 |
|
(single-float float) |
529 |
|
(double-float float) |
530 |
|
(long-float float) |
531 |
|
(rational real) |
532 |
|
(integer rational) |
533 |
|
(ratio rational) |
534 |
|
(signed-byte integer) |
535 |
|
(integer signed-byte) |
536 |
|
(unsigned-byte signed-byte) |
537 |
|
(bit unsigned-byte) |
538 |
|
(fixnum integer) |
539 |
|
(bignum integer) |
540 |
|
(bit fixnum) |
541 |
|
(arithmetic-error error) |
542 |
|
(division-by-zero arithmetic-error) |
543 |
|
(floating-point-invalid-operation arithmetic-error) |
544 |
|
(floating-point-inexact arithmetic-error) |
545 |
|
(floating-point-overflow arithmetic-error) |
546 |
|
(floating-point-underflow arithmetic-error) |
547 |
|
(character t) |
548 |
|
(base-char character) |
549 |
|
(standard-char base-char) |
550 |
|
(extended-char character) |
551 |
|
(sequence t) |
552 |
|
(list sequence) |
553 |
|
(null list) |
554 |
|
#-(and cmu (not sparc)) (null boolean) |
555 |
|
(cons list) |
556 |
|
(array t) |
557 |
|
(simple-array array) |
558 |
|
(vector sequence) |
559 |
|
(vector array) |
560 |
|
(string vector) |
561 |
|
(bit-vector vector) |
562 |
|
(simple-vector vector) |
563 |
|
(simple-vector simple-array) |
564 |
|
(simple-bit-vector bit-vector) |
565 |
|
(simple-bit-vector simple-array) |
566 |
|
(base-string string) |
567 |
|
(simple-string string) |
568 |
|
(simple-string simple-array) |
569 |
|
(simple-base-string base-string) |
570 |
|
(simple-base-string simple-string) |
571 |
|
(pathname t) |
572 |
|
(logical-pathname pathname) |
573 |
|
(file-error error) |
574 |
|
(stream t) |
575 |
|
(broadcast-stream stream) |
576 |
|
(concatenated-stream stream) |
577 |
|
(echo-stream stream) |
578 |
|
(file-stream stream) |
579 |
|
(string-stream stream) |
580 |
|
(synonym-stream stream) |
581 |
|
(two-way-stream stream) |
582 |
|
(stream-error error) |
583 |
|
(end-of-file stream-error) |
584 |
|
(print-not-readable error) |
585 |
|
(readtable t) |
586 |
|
(reader-error parse-error) |
587 |
|
(reader-error stream-error) |
588 |
|
))) |
589 |
|
(when (subtypep* 'character 'base-char) |
590 |
|
(setq table |
591 |
|
(append |
592 |
|
'((character base-char) |
593 |
|
(string base-string) |
594 |
|
(simple-string simple-base-string)) |
595 |
|
table))) |
596 |
|
|
597 |
|
table)) |
598 |
|
|
599 |
(defvar *disjoint-types-list* |
(defvar *disjoint-types-list* |
600 |
'(cons symbol array |
'(cons symbol array |
601 |
number character hash-table function readtable package |
number character hash-table function readtable package |