0.8.0.74:

[sbcl.git] / src / compiler / typetran.lisp

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index c538f46..b473f7f 100644 (file)
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -155,7 +155,6 @@
 ;;; binds specified by TYPE. BASE is the name of the base type, for
 ;;; declaration. We make SAFETY locally 0 to inhibit any checking of
 ;;; this assertion.
-#!-negative-zero-is-not-zero
 (defun transform-numeric-bound-test (n-object type base)
   (declare (type numeric-type type))
   (let ((low (numeric-type-low type))
@@ -164,55 +163,12 @@
        (declare (optimize (safety 0)))
        (and ,@(when low
                (if (consp low)
-                   `((> (the ,base ,n-object) ,(car low)))
-                   `((>= (the ,base ,n-object) ,low))))
+                   `((> (truly-the ,base ,n-object) ,(car low)))
+                   `((>= (truly-the ,base ,n-object) ,low))))
            ,@(when high
                (if (consp high)
-                   `((< (the ,base ,n-object) ,(car high)))
-                   `((<= (the ,base ,n-object) ,high))))))))
-
-#!+negative-zero-is-not-zero
-(defun transform-numeric-bound-test (n-object type base)
-  (declare (type numeric-type type))
-  (let ((low (numeric-type-low type))
-       (high (numeric-type-high type))
-       (float-type-p (csubtypep type (specifier-type 'float)))
-       (x (gensym))
-       (y (gensym)))
-    `(locally
-       (declare (optimize (safety 0)))
-       (and ,@(when low
-               (if (consp low)
-                   `((let ((,x (the ,base ,n-object))
-                           (,y ,(car low)))
-                       ,(if (not float-type-p)
-                           `(> ,x ,y)
-                           `(if (and (zerop ,x) (zerop ,y))
-                                (> (float-sign ,x) (float-sign ,y))
-                                (> ,x ,y)))))
-                   `((let ((,x (the ,base ,n-object))
-                           (,y ,low))
-                       ,(if (not float-type-p)
-                           `(>= ,x ,y)
-                           `(if (and (zerop ,x) (zerop ,y))
-                                (>= (float-sign ,x) (float-sign ,y))
-                                (>= ,x ,y)))))))
-           ,@(when high
-               (if (consp high)
-                   `((let ((,x (the ,base ,n-object))
-                           (,y ,(car high)))
-                       ,(if (not float-type-p)
-                            `(< ,x ,y)
-                            `(if (and (zerop ,x) (zerop ,y))
-                                 (< (float-sign ,x) (float-sign ,y))
-                                 (< ,x ,y)))))
-                   `((let ((,x (the ,base ,n-object))
-                           (,y ,high))
-                       ,(if (not float-type-p)
-                            `(<= ,x ,y)
-                            `(if (and (zerop ,x) (zerop ,y))
-                                 (<= (float-sign ,x) (float-sign ,y))
-                                 (<= ,x ,y)))))))))))
+                   `((< (truly-the ,base ,n-object) ,(car high)))
+                   `((<= (truly-the ,base ,n-object) ,high))))))))
 
 ;;; Do source transformation of a test of a known numeric type. We can
 ;;; assume that the type doesn't have a corresponding predicate, since
@@ -244,8 +200,8 @@
               ,(transform-numeric-bound-test n-object type base)))
        (:complex
         `(and (complexp ,n-object)
-              ,(once-only ((n-real `(realpart (the complex ,n-object)))
-                           (n-imag `(imagpart (the complex ,n-object))))
+              ,(once-only ((n-real `(realpart (truly-the complex ,n-object)))
+                           (n-imag `(imagpart (truly-the complex ,n-object))))
                  `(progn
                     ,n-imag ; ignorable
                     (and (typep ,n-real ',base)
@@ -264,8 +220,8 @@
   (let ((spec (hairy-type-specifier type)))
     (cond ((unknown-type-p type)
           (when (policy *lexenv* (> speed inhibit-warnings))
-            (compiler-note "can't open-code test of unknown type ~S"
-                           (type-specifier type)))
+            (compiler-notify "can't open-code test of unknown type ~S"
+                             (type-specifier type)))
           `(%typep ,object ',spec))
          (t
           (ecase (first spec)
@@ -316,10 +272,8 @@
 (defun source-transform-cons-typep (object type)
   (let* ((car-type (cons-type-car-type type))
         (cdr-type (cons-type-cdr-type type)))
-    (let ((car-test-p (not (or (type= car-type *wild-type*)
-                              (type= car-type (specifier-type t)))))
-         (cdr-test-p (not (or (type= cdr-type *wild-type*)
-                              (type= cdr-type (specifier-type t))))))
+    (let ((car-test-p (not (type= car-type *universal-type*)))
+         (cdr-test-p (not (type= cdr-type *universal-type*))))
       (if (and (not car-test-p) (not cdr-test-p))
          `(consp ,object)
          (once-only ((n-obj object))