X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fsrctran.lisp;h=c1a53a9bd8d8b9e98035b260705a17cf710bbd0a;hb=65f551e30f6f52855fdb7ff28e0cfff2f17c3e48;hp=4679da2fcc239721a2f2349032e78a5a24bd547a;hpb=98a76d4426660876dec6649b1e228d2e5b47f579;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 4679da2..c1a53a9 100644
--- 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