0.9.0.21:

[sbcl.git] / src / code / typep.lisp

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 2c200f3..0df87b1 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -59,7 +59,6 @@
                 (long-float (typep num 'long-float))
                 ((nil) (floatp num))))
              ((nil) t)))
-         #!-negative-zero-is-not-zero
          (flet ((bound-test (val)
                   (let ((low (numeric-type-low type))
                         (high (numeric-type-high type)))
@@ -77,37 +76,6 @@
                    (bound-test (imagpart object))))
              (:real
               (and (not (complexp object))
-                   (bound-test object)))))
-         #!+negative-zero-is-not-zero
-         (labels ((signed-> (x y)
-                    (if (and (zerop x) (zerop y) (floatp x) (floatp y))
-                        (> (float-sign x) (float-sign y))
-                        (> x y)))
-                  (signed->= (x y)
-                    (if (and (zerop x) (zerop y) (floatp x) (floatp y))
-                        (>= (float-sign x) (float-sign y))
-                        (>= x y)))
-                  (bound-test (val)
-                    (let ((low (numeric-type-low type))
-                          (high (numeric-type-high type)))
-                      (and (cond ((null low) t)
-                                 ((listp low)
-                                  (signed-> val (car low)))
-                                 (t
-                                  (signed->= val low)))
-                           (cond ((null high) t)
-                                 ((listp high)
-                                  (signed-> (car high) val))
-                                 (t
-                                  (signed->= high val)))))))
-           (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)))))))
     (array-type
      (and (arrayp object)
@@ -149,6 +117,14 @@
      (and (consp object)
          (%%typep (car object) (cons-type-car-type type))
          (%%typep (cdr object) (cons-type-cdr-type type))))
+    (character-set-type
+     (and (characterp object)
+         (let ((code (char-code object))
+               (pairs (character-set-type-pairs type)))
+           (dolist (pair pairs nil)
+             (destructuring-bind (low . high) pair
+               (when (<= low code high)
+                 (return t)))))))
     (unknown-type
      ;; dunno how to do this ANSIly -- WHN 19990413
      #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")