- (let (;; I think this works because of an invariant of the
- ;; two components of a COMPLEX are always coerced to
- ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
- ;; Dunno why that holds, though -- ANSI? Python
- ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
- (num (if (complexp object)
- (realpart object)
- object)))
- (ecase (numeric-type-class type)
- (integer (integerp num))
- (rational (rationalp num))
- (float
- (ecase (numeric-type-format type)
- (short-float (typep num 'short-float))
- (single-float (typep num 'single-float))
- (double-float (typep num 'double-float))
- (long-float (typep num 'long-float))
- ((nil) (floatp num))))
- ((nil) t)))
- (flet ((bound-test (val)
- (let ((low (numeric-type-low type))
- (high (numeric-type-high type)))
- (and (cond ((null low) t)
- ((listp low) (> val (car low)))
- (t (>= val low)))
- (cond ((null high) t)
- ((listp high) (< val (car high)))
- (t (<= val high)))))))
- (ecase (numeric-type-complexp type)
- ((nil) t)
- (:complex
- (and (complexp object)
- (bound-test (realpart object))
- (bound-test (imagpart object))))
- (:real
- (and (not (complexp object))
- (bound-test object)))))))
+ (let (;; I think this works because of an invariant of the
+ ;; two components of a COMPLEX are always coerced to
+ ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
+ ;; Dunno why that holds, though -- ANSI? Python
+ ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
+ (num (if (complexp object)
+ (realpart object)
+ object)))
+ (ecase (numeric-type-class type)
+ (integer (integerp num))
+ (rational (rationalp num))
+ (float
+ (ecase (numeric-type-format type)
+ (short-float (typep num 'short-float))
+ (single-float (typep num 'single-float))
+ (double-float (typep num 'double-float))
+ (long-float (typep num 'long-float))
+ ((nil) (floatp num))))
+ ((nil) t)))
+ (flet ((bound-test (val)
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (and (cond ((null low) t)
+ ((listp low) (> val (car low)))
+ (t (>= val low)))
+ (cond ((null high) t)
+ ((listp high) (< val (car high)))
+ (t (<= val high)))))))
+ (ecase (numeric-type-complexp type)
+ ((nil) t)
+ (:complex
+ (and (complexp object)
+ (bound-test (realpart object))
+ (bound-test (imagpart object))))
+ (:real
+ (and (not (complexp object))
+ (bound-test object)))))))
- (ecase (array-type-complexp type)
- ((t) (not (typep object 'simple-array)))
- ((nil) (typep object 'simple-array))
- ((:maybe) t))
- (or (eq (array-type-dimensions type) '*)
- (do ((want (array-type-dimensions type) (cdr want))
- (got (array-dimensions object) (cdr got)))
- ((and (null want) (null got)) t)
- (unless (and want got
- (or (eq (car want) '*)
- (= (car want) (car got))))
- (return nil))))
- (if (unknown-type-p (array-type-element-type type))
- ;; better to fail this way than to get bogosities like
- ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
- (error "~@<unknown element type in array type: ~2I~_~S~:>"
- (type-specifier type))
- t)
- (or (eq (array-type-element-type type) *wild-type*)
- (values (type= (array-type-specialized-element-type type)
- (specifier-type (array-element-type
- object)))))))
+ (ecase (array-type-complexp type)
+ ((t) (not (typep object 'simple-array)))
+ ((nil) (typep object 'simple-array))
+ ((:maybe) t))
+ (or (eq (array-type-dimensions type) '*)
+ (do ((want (array-type-dimensions type) (cdr want))
+ (got (array-dimensions object) (cdr got)))
+ ((and (null want) (null got)) t)
+ (unless (and want got
+ (or (eq (car want) '*)
+ (= (car want) (car got))))
+ (return nil))))
+ (if (unknown-type-p (array-type-element-type type))
+ ;; better to fail this way than to get bogosities like
+ ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
+ (error "~@<unknown element type in array type: ~2I~_~S~:>"
+ (type-specifier type))
+ t)
+ (or (eq (array-type-element-type type) *wild-type*)
+ (values (type= (array-type-specialized-element-type type)
+ (specifier-type (array-element-type
+ object)))))))
- (and
- (every (lambda (spec) (%%typep object (specifier-type spec)))
- (rest hairy-spec)))
- ;; Note: it should be safe to skip OR here, because union
- ;; types can always be represented as UNION-TYPE in general
- ;; or other CTYPEs in special cases; we never need to use
- ;; HAIRY-TYPE for them.
- (not
- (unless (proper-list-of-length-p hairy-spec 2)
- (error "invalid type specifier: ~S" hairy-spec))
- (not (%%typep object (specifier-type (cadr hairy-spec)))))
- (satisfies
- (unless (proper-list-of-length-p hairy-spec 2)
- (error "invalid type specifier: ~S" hairy-spec))
- (values (funcall (symbol-function (cadr hairy-spec)) object))))))
+ (and
+ (every (lambda (spec) (%%typep object (specifier-type spec)))
+ (rest hairy-spec)))
+ ;; Note: it should be safe to skip OR here, because union
+ ;; types can always be represented as UNION-TYPE in general
+ ;; or other CTYPEs in special cases; we never need to use
+ ;; HAIRY-TYPE for them.
+ (not
+ (unless (proper-list-of-length-p hairy-spec 2)
+ (error "invalid type specifier: ~S" hairy-spec))
+ (not (%%typep object (specifier-type (cadr hairy-spec)))))
+ (satisfies
+ (unless (proper-list-of-length-p hairy-spec 2)
+ (error "invalid type specifier: ~S" hairy-spec))
+ (values (funcall (symbol-function (cadr hairy-spec)) object))))))