153 |
(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) |
(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) |
154 |
(multiple-value-bind |
(multiple-value-bind |
155 |
(sub valid) |
(sub valid) |
156 |
(subtypep* type1 type2) |
(subtypep type1 type2) |
157 |
(cond |
(unless (constantp type1) (setq type1 (list 'quote type1))) |
158 |
(valid |
(unless (constantp type2) (setq type2 (list 'quote type2))) |
159 |
(cond |
(if (or (and valid sub (not is-sub)) |
160 |
((and sub (not is-sub)) |
(and valid (not sub) is-sub) |
161 |
`((SUBTYPEP ',type1 ',type2) |
(and (not valid) should-be-valid)) |
162 |
"==> <true>, <true>, expected NIL.")) |
`((SUBTYPEP ,type1 ,type2) cl-user::==> ,sub ,valid) |
163 |
((and (not sub) is-sub) |
nil))) |
|
`((SUBTYPEP ',type1 ',type2) |
|
|
"==> <false>, <true>, expected <true>.")) |
|
|
(t nil))) |
|
|
(should-be-valid |
|
|
`((SUBTYPEP ',type1 ',type2) "did not succeed but should have.")) |
|
|
(t nil)))) |
|
164 |
|
|
165 |
(defun check-type-predicate (P TYPE) |
(defun check-type-predicate (P TYPE) |
166 |
"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)) |