- (and
- (if (atom hairy-spec)
- (values t t)
- (dolist (spec (cdr hairy-spec) (values t t))
- (multiple-value-bind (res win)
- (ctypep obj (specifier-type spec))
- (unless win (return (values nil nil)))
- (unless res (return (values nil t)))))))
- (not
- (multiple-value-bind (res win)
- (ctypep obj (specifier-type (cadr hairy-spec)))
- (if win
- (values (not res) t)
- (values nil nil))))
- (satisfies
- ;; KLUDGE: This stuff might well blow up if we tried to execute it
- ;; when cross-compiling. But since for the foreseeable future the
- ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
- ;; built without using SATISFIES types, it's arguably not important
- ;; to worry about this. -- WHN 19990210.
- (let ((fun (second hairy-spec)))
- (cond ((and (consp fun)
- (eq (car fun) 'lambda))
- (values (not (null (funcall (coerce fun 'function) obj)))
- t))
- ((and (symbolp fun) (fboundp fun))
- (values (not (null (funcall fun obj))) t))
- (t
- (values nil nil))))))))))
+ (and
+ (if (atom hairy-spec)
+ (values t t)
+ (dolist (spec (cdr hairy-spec) (values t t))
+ (multiple-value-bind (res win)
+ (ctypep obj (specifier-type spec))
+ (unless win (return (values nil nil)))
+ (unless res (return (values nil t)))))))
+ (not
+ (multiple-value-bind (res win)
+ (ctypep obj (specifier-type (cadr hairy-spec)))
+ (if win
+ (values (not res) t)
+ (values nil nil))))
+ (satisfies
+ ;; If the SATISFIES function is not foldable, we cannot answer!
+ (let* ((form `(,(second hairy-spec) ',obj)))
+ (multiple-value-bind (ok result)
+ (sb!c::constant-function-call-p form nil nil)
+ (values (not (null result)) ok)))))))))