0.8.0.3:

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

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4679da2..c1a53a9 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -31,8 +31,7 @@
 
 ;;; Bind the value and make a closure that returns it.
 (define-source-transform constantly (value)
-  (let ((rest (gensym "CONSTANTLY-REST-"))
-       (n-value (gensym "CONSTANTLY-VALUE-")))
+  (with-unique-names (rest n-value)
     `(let ((,n-value ,value))
       (lambda (&rest ,rest)
        (declare (ignore ,rest))
@@ -835,11 +834,11 @@
             :low (if lo-float-zero-p
                      (if (consp lo)
                          (list (float 0.0 lo-val))
-                         (float -0.0 lo-val))
+                         (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val))
                      lo)
             :high (if hi-float-zero-p
                       (if (consp hi)
-                          (list (float -0.0 hi-val))
+                          (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))
                           (float 0.0 hi-val))
                       hi))
            type))
@@ -957,7 +956,9 @@
 
 ;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
 ;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations.
+;;; the compiler, invoked only during some type optimizations. (In
+;;; fact, as of 0.pre8.100 or so they probably are, under
+;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
 
 ;;; Take a list of types and return a canonical type specifier,
 ;;; combining any MEMBER types together. If both positive and negative
@@ -972,15 +973,15 @@
          (setf members (union members (member-type-members type)))
          (push type misc-types)))
     #!+long-float
-    (when (null (set-difference '(-0l0 0l0) members))
-      (push (specifier-type '(long-float 0l0 0l0)) misc-types)
-      (setf members (set-difference members '(-0l0 0l0))))
-    (when (null (set-difference '(-0d0 0d0) members))
-      (push (specifier-type '(double-float 0d0 0d0)) misc-types)
-      (setf members (set-difference members '(-0d0 0d0))))
-    (when (null (set-difference '(-0f0 0f0) members))
-      (push (specifier-type '(single-float 0f0 0f0)) misc-types)
-      (setf members (set-difference members '(-0f0 0f0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
+      (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
+      (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
+      (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
     (if members
        (apply #'type-union (make-member-type :members members) misc-types)
        (apply #'type-union misc-types))))
@@ -3372,7 +3373,7 @@
                        (error "can't understand type ~S~%" element-type))))))
       (cond ((array-type-p array-type)
             (get-element-type array-type))
-           ((union-type-p array-type)             
+           ((union-type-p array-type)
              (apply #'type-union
                     (mapcar #'get-element-type (union-type-types array-type))))
            (t