0.9.10.17: fix bug #400, aka more correct CONSTANTP
[sbcl.git] / src / compiler / srctran.lisp
index 69bc5e1..fa72708 100644 (file)
   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   (deffrob ceiling))
 
-(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+;;; This used to be a source transform (hence the lack of restrictions
+;;; on the argument types), but we make it a regular transform so that
+;;; the VM has a chance to see the bare LOGTEST and potentiall choose
+;;; to implement it differently.  --njf, 06-02-2006
+(deftransform logtest ((x y) * *)
+  `(not (zerop (logand x y))))
 
 (deftransform logbitp
     ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
            (if (and (floatp y)
                     (float-infinity-p y))
                nil
-               (set-bound (funcall f (type-bound-number x)) (consp x)))))))
+               (set-bound y (consp x)))))))
 
 ;;; Apply a binary operator OP to two bounds X and Y. The result is
 ;;; NIL if either is NIL. Otherwise bound is computed and the result
 (defmacro safely-binop (op x y)
   `(cond
     ((typep ,x 'single-float)
-     (if (<= most-negative-single-float ,y most-positive-single-float)
+     (if (or (typep ,y 'single-float)
+             (<= most-negative-single-float ,y most-positive-single-float))
          (,op ,x ,y)))
     ((typep ,x 'double-float)
-     (if (<= most-negative-double-float ,y most-positive-double-float)
+     (if (or (typep ,y 'double-float)
+             (<= most-negative-double-float ,y most-positive-double-float))
          (,op ,x ,y)))
     ((typep ,y 'single-float)
      (if (<= most-negative-single-float ,x most-positive-single-float)
       (when (stringp x)
         (check-format-args x args 'format)))))
 
+;;; We disable this transform in the cross-compiler to save memory in
+;;; the target image; most of the uses of FORMAT in the compiler are for
+;;; error messages, and those don't need to be particularly fast.
+#+sb-xc
 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
                       :policy (> speed space))
   (unless (constant-lvar-p control)