X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=c736fe1ef06d6fd48ec6148b09bd0e4103c3bc1e;hb=3c65762b927af861c9c8bc416e4cbac9a14ec0c3;hp=58585f454806ca2ca068e487d26c367fe9a54a68;hpb=c8218514d751c4d777892b79bbf1ca6597f731c0;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 58585f4..c736fe1 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -43,7 +43,7 @@
 (deftransform complement ((fun) * * :node node :when :both)
   "open code"
   (multiple-value-bind (min max)
-      (function-type-nargs (continuation-type fun))
+      (fun-type-nargs (continuation-type fun))
     (cond
      ((and min (eql min max))
       (let ((dums (make-gensym-list min)))
@@ -62,7 +62,7 @@
 
 ;;; Translate CxR into CAR/CDR combos.
 (defun source-transform-cxr (form)
-  (if (or (byte-compiling) (/= (length form) 2))
+  (if (/= (length form) 2)
       (values nil t)
       (let ((name (symbol-name (car form))))
 	(do ((i (- (length name) 2) (1- i))
@@ -158,19 +158,18 @@
 ;;; Note that all the integer division functions are available for
 ;;; inline expansion.
 
-;;; FIXME: DEF-FROB instead of FROB
-(macrolet ((frob (fun)
+(macrolet ((deffrob (fun)
 	     `(def-source-transform ,fun (x &optional (y nil y-p))
 		(declare (ignore y))
 		(if y-p
 		    (values nil t)
 		    `(,',fun ,x 1)))))
-  (frob truncate)
-  (frob round)
-  #!+sb-propagate-float-type
-  (frob floor)
-  #!+sb-propagate-float-type
-  (frob ceiling))
+  (deffrob truncate)
+  (deffrob round)
+  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+  (deffrob floor)
+  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+  (deffrob ceiling))
 
 (def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
 (def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
@@ -218,9 +217,6 @@
 ;;;; numeric-type has everything we want to know. Reason 2 wins for
 ;;;; now.
 
-#!+sb-propagate-float-type
-(progn
-
 ;;; The basic interval type. It can handle open and closed intervals.
 ;;; A bound is open if it is a list containing a number, just like
 ;;; Lisp says. NIL means unbounded.
@@ -248,7 +244,7 @@
 			;; The bound exists, so keep it open still.
 			(list new-val))))
 		   (t
-		    (error "Unknown bound type in make-interval!")))))
+		    (error "unknown bound type in MAKE-INTERVAL")))))
     (%make-interval :low (normalize-bound low)
 		    :high (normalize-bound high))))
 
@@ -629,11 +625,12 @@
 	    ((eq y-range '-)
 	     (interval-neg (interval-mul x (interval-neg y))))
 	    ((and (eq x-range '+) (eq y-range '+))
-	     ;; If we are here, X and Y are both positive
-	     (make-interval :low (bound-mul (interval-low x) (interval-low y))
-			    :high (bound-mul (interval-high x) (interval-high y))))
+	     ;; If we are here, X and Y are both positive.
+	     (make-interval
+	      :low (bound-mul (interval-low x) (interval-low y))
+	      :high (bound-mul (interval-high x) (interval-high y))))
 	    (t
-	     (error "This shouldn't happen!"))))))
+	     (error "internal error in INTERVAL-MUL"))))))
 
 ;;; Divide two intervals.
 (defun interval-div (top bot)
@@ -678,11 +675,12 @@
 	     ;; sign of the result.
 	     (interval-neg (interval-div (interval-neg top) bot)))
 	    ((and (eq top-range '+) (eq bot-range '+))
-	     ;; The easy case
-	     (make-interval :low (bound-div (interval-low top) (interval-high bot) t)
-			    :high (bound-div (interval-high top) (interval-low bot) nil)))
+	     ;; the easy case
+	     (make-interval
+	      :low (bound-div (interval-low top) (interval-high bot) t)
+	      :high (bound-div (interval-high top) (interval-low bot) nil)))
 	    (t
-	     (error "This shouldn't happen!"))))))
+	     (error "internal error in INTERVAL-DIV"))))))
 
 ;;; Apply the function F to the interval X. If X = [a, b], then the
 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
@@ -745,9 +743,8 @@
 ;;; Compute the square of an interval.
 (defun interval-sqr (x)
   (declare (type interval x))
-  (interval-func #'(lambda (x) (* x x))
+  (interval-func (lambda (x) (* x x))
 		 (interval-abs x)))
-) ; PROGN
 
 ;;;; numeric DERIVE-TYPE methods
 
@@ -771,9 +768,6 @@
 			     :high high))
 	(numeric-contagion x y))))
 
-#!+(or sb-propagate-float-type sb-propagate-fun-type)
-(progn
-
 ;;; simple utility to flatten a list
 (defun flatten-list (x)
   (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
@@ -1162,10 +1156,8 @@
 	  (if (rest results)
 	      (make-canonical-union-type results)
 	      (first results)))))))
-
-) ; PROGN
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 (defoptimizer (+ derive-type) ((x y))
   (derive-integer-type
@@ -1216,7 +1208,7 @@
 
 ) ; PROGN
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 (defun +-derive-type-aux (x y same-arg)
   (if (and (numeric-type-real-p x)
@@ -1356,90 +1348,7 @@
 ;;; and it's hard to avoid that calculation in here.
 #-(and cmu sb-xc-host)
 (progn
-#!-sb-propagate-fun-type
-(defoptimizer (ash derive-type) ((n shift))
-  ;; Large resulting bounds are easy to generate but are not
-  ;; particularly useful, so an open outer bound is returned for a
-  ;; shift greater than 64 - the largest word size of any of the ports.
-  ;; Large negative shifts are also problematic as the ASH
-  ;; implementation only accepts shifts greater than
-  ;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local
-  ;; functions:
-  ;;   ASH-OUTER: Perform the shift when within an acceptable range,
-  ;;     otherwise return an open bound.
-  ;;   ASH-INNER: Perform the shift when within range, limited to a
-  ;;     maximum of 64, otherwise returns the inner limit.
-  ;;
-  ;; FIXME: The magic number 64 should be given a mnemonic name as a
-  ;; symbolic constant -- perhaps +MAX-REGISTER-SIZE+. And perhaps is
-  ;; should become an architecture-specific SB!VM:+MAX-REGISTER-SIZE+
-  ;; instead of trying to have a single magic number which covers
-  ;; all possible ports.
-  (flet ((ash-outer (n s)
-            (when (and (fixnump s)
-                       (<= s 64)
-                       (> s sb!vm:*target-most-negative-fixnum*))
-              (ash n s)))
-          (ash-inner (n s)
-            (if (and (fixnump s)
-                     (> s sb!vm:*target-most-negative-fixnum*))
-              (ash n (min s 64))
-              (if (minusp n) -1 0))))
-     (or (let ((n-type (continuation-type n)))
-           (when (numeric-type-p n-type)
-             (let ((n-low (numeric-type-low n-type))
-                   (n-high (numeric-type-high n-type)))
-               (if (constant-continuation-p shift)
-                 (let ((shift (continuation-value shift)))
-                   (make-numeric-type :class 'integer
-				      :complexp :real
-                                      :low (when n-low (ash n-low shift))
-                                      :high (when n-high (ash n-high shift))))
-                 (let ((s-type (continuation-type shift)))
-                   (when (numeric-type-p s-type)
-                     (let* ((s-low (numeric-type-low s-type))
-			    (s-high (numeric-type-high s-type))
-			    (low-slot (when n-low
-					(if (minusp n-low)
-					    (ash-outer n-low s-high)
-					    (ash-inner n-low s-low))))
-			    (high-slot (when n-high
-					 (if (minusp n-high)
-					     (ash-inner n-high s-low)
-					     (ash-outer n-high s-high)))))
-                       (make-numeric-type :class 'integer
-					  :complexp :real
-                                          :low low-slot
-                                          :high high-slot))))))))
-         *universal-type*))
-  (or (let ((n-type (continuation-type n)))
-	(when (numeric-type-p n-type)
-	  (let ((n-low (numeric-type-low n-type))
-		(n-high (numeric-type-high n-type)))
-	    (if (constant-continuation-p shift)
-		(let ((shift (continuation-value shift)))
-		  (make-numeric-type :class 'integer
-				     :complexp :real
-				     :low (when n-low (ash n-low shift))
-				     :high (when n-high (ash n-high shift))))
-		(let ((s-type (continuation-type shift)))
-		  (when (numeric-type-p s-type)
-		    (let ((s-low (numeric-type-low s-type))
-			  (s-high (numeric-type-high s-type)))
-		      (if (and s-low s-high (<= s-low 64) (<= s-high 64))
-			  (make-numeric-type :class 'integer
-					     :complexp :real
-					     :low (when n-low
-						    (min (ash n-low s-high)
-							 (ash n-low s-low)))
-					     :high (when n-high
-						     (max (ash n-high s-high)
-							  (ash n-high s-low))))
-			  (make-numeric-type :class 'integer
-					     :complexp :real)))))))))
-      *universal-type*))
-
-#!+sb-propagate-fun-type
+
 (defun ash-derive-type-aux (n-type shift same-arg)
   (declare (ignore same-arg))
   (flet ((ash-outer (n s)
@@ -1472,12 +1381,11 @@
                                             (ash-outer n-high s-high))))))
 	*universal-type*)))
 
-#!+sb-propagate-fun-type
 (defoptimizer (ash derive-type) ((n shift))
   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
 ) ; PROGN
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (macrolet ((frob (fun)
 	     `#'(lambda (type type2)
 		  (declare (ignore type2))
@@ -1486,12 +1394,8 @@
 		    (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
 
   (defoptimizer (%negate derive-type) ((num))
-    (derive-integer-type num num (frob -)))
+    (derive-integer-type num num (frob -))))
 
-  (defoptimizer (lognot derive-type) ((int))
-    (derive-integer-type int int (frob lognot))))
-
-#!+sb-propagate-float-type
 (defoptimizer (lognot derive-type) ((int))
   (derive-integer-type int int
 		       (lambda (type type2)
@@ -1503,7 +1407,7 @@
 				   (numeric-type-class type)
 				   (numeric-type-format type))))))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (%negate derive-type) ((num))
   (flet ((negate-bound (b)
            (and b
@@ -1517,7 +1421,7 @@
 			    :high (negate-bound (numeric-type-low type))))
 			 #'-)))
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (abs derive-type) ((num))
   (let ((type (continuation-type num)))
     (if (and (numeric-type-p type)
@@ -1537,7 +1441,7 @@
 				       nil)))
 	(numeric-contagion type type))))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun abs-derive-type-aux (type)
   (cond ((eq (numeric-type-complexp type) :complex)
 	 ;; The absolute value of a complex number is always a
@@ -1566,11 +1470,11 @@
 	    :high (coerce-numeric-bound
 		   (interval-high abs-bnd) bound-type))))))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (abs derive-type) ((num))
   (one-arg-derive-type num #'abs-derive-type-aux #'abs))
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (truncate derive-type) ((number divisor))
   (let ((number-type (continuation-type number))
 	(divisor-type (continuation-type divisor))
@@ -1590,7 +1494,7 @@
 					      divisor-low divisor-high))))
 	*universal-type*)))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (progn
 
 (defun rem-result-type (number-type divisor-type)
@@ -2168,7 +2072,7 @@
 	     ;; anything about the result.
 	     `integer)))))
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun integer-rem-derive-type
        (number-low number-high divisor-low divisor-high)
   (if (and divisor-low divisor-high)
@@ -2198,7 +2102,7 @@
 		     0
 		     '*))))
 
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (random derive-type) ((bound &optional state))
   (let ((type (continuation-type bound)))
     (when (numeric-type-p type)
@@ -2214,7 +2118,7 @@
 		     ((or (consp high) (zerop high)) high)
 		     (t `(,high))))))))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun random-derive-type-aux (type)
   (let ((class (numeric-type-class type))
 	(high (numeric-type-high type))
@@ -2228,11 +2132,11 @@
 		     ((or (consp high) (zerop high)) high)
 		     (t `(,high))))))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defoptimizer (random derive-type) ((bound &optional state))
   (one-arg-derive-type bound #'random-derive-type-aux nil))
 
-;;;; logical derive-type methods
+;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
 
 ;;; Return the maximum number of bits an integer of the supplied type
 ;;; can take up, or NIL if it is unbounded. The second (third) value
@@ -2247,123 +2151,6 @@
 		(or (null min) (minusp min))))
       (values nil t t)))
 
-#!-sb-propagate-fun-type
-(progn
-
-(defoptimizer (logand derive-type) ((x y))
-  (multiple-value-bind (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (declare (ignore x-pos))
-    (multiple-value-bind (y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (declare (ignore y-pos))
-      (if (not x-neg)
-	  ;; X must be positive.
-	  (if (not y-neg)
-	      ;; The must both be positive.
-	      (cond ((or (null x-len) (null y-len))
-		     (specifier-type 'unsigned-byte))
-		    ((or (zerop x-len) (zerop y-len))
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type `(unsigned-byte ,(min x-len y-len)))))
-	      ;; X is positive, but Y might be negative.
-	      (cond ((null x-len)
-		     (specifier-type 'unsigned-byte))
-		    ((zerop x-len)
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type `(unsigned-byte ,x-len)))))
-	  ;; X might be negative.
-	  (if (not y-neg)
-	      ;; Y must be positive.
-	      (cond ((null y-len)
-		     (specifier-type 'unsigned-byte))
-		    ((zerop y-len)
-		     (specifier-type '(integer 0 0)))
-		    (t
-		     (specifier-type
-		      `(unsigned-byte ,y-len))))
-	      ;; Either might be negative.
-	      (if (and x-len y-len)
-		  ;; The result is bounded.
-		  (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-		  ;; We can't tell squat about the result.
-		  (specifier-type 'integer)))))))
-
-(defoptimizer (logior derive-type) ((x y))
-  (multiple-value-bind (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (multiple-value-bind (y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (cond
-       ((and (not x-neg) (not y-neg))
-	;; Both are positive.
-	(specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*))))
-       ((not x-pos)
-	;; X must be negative.
-	(if (not y-pos)
-	    ;; Both are negative. The result is going to be negative and be
-	    ;; the same length or shorter than the smaller.
-	    (if (and x-len y-len)
-		;; It's bounded.
-		(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
-		;; It's unbounded.
-		(specifier-type '(integer * -1)))
-	    ;; X is negative, but we don't know about Y. The result will be
-	    ;; negative, but no more negative than X.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low (continuation-type x)) '*)
-		       -1))))
-       (t
-	;; X might be either positive or negative.
-	(if (not y-pos)
-	    ;; But Y is negative. The result will be negative.
-	    (specifier-type
-	     `(integer ,(or (numeric-type-low (continuation-type y)) '*)
-		       -1))
-	    ;; We don't know squat about either. It won't get any bigger.
-	    (if (and x-len y-len)
-		;; Bounded.
-		(specifier-type `(signed-byte ,(1+ (max x-len y-len))))
-		;; Unbounded.
-		(specifier-type 'integer))))))))
-
-(defoptimizer (logxor derive-type) ((x y))
-  (multiple-value-bind (x-len x-pos x-neg)
-      (integer-type-length (continuation-type x))
-    (multiple-value-bind (y-len y-pos y-neg)
-	(integer-type-length (continuation-type y))
-      (cond
-       ((or (and (not x-neg) (not y-neg))
-	    (and (not x-pos) (not y-pos)))
-	;; Either both are negative or both are positive. The result
-	;; will be positive, and as long as the longer.
-	(specifier-type `(unsigned-byte ,(if (and x-len y-len)
-					     (max x-len y-len)
-					     '*))))
-       ((or (and (not x-pos) (not y-neg))
-	    (and (not y-neg) (not y-pos)))
-	;; Either X is negative and Y is positive of vice-versa. The
-	;; result will be negative.
-	(specifier-type `(integer ,(if (and x-len y-len)
-				       (ash -1 (max x-len y-len))
-				       '*)
-				  -1)))
-       ;; We can't tell what the sign of the result is going to be.
-       ;; All we know is that we don't create new bits.
-       ((and x-len y-len)
-	(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
-       (t
-	(specifier-type 'integer))))))
-
-) ; PROGN
-
-#!+sb-propagate-fun-type
-(progn
-
 (defun logand-derive-type-aux (x y &optional same-leaf)
   (declare (ignore same-leaf))
   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
@@ -2461,7 +2248,7 @@
 					     '*)))))
        ((or (and (not x-pos) (not y-neg))
 	    (and (not y-neg) (not y-pos)))
-	;; Either X is negative and Y is positive of vice-verca. The
+	;; Either X is negative and Y is positive of vice-versa. The
 	;; result will be negative.
 	(specifier-type `(integer ,(if (and x-len y-len)
 				       (ash -1 (max x-len y-len))
@@ -2474,21 +2261,22 @@
        (t
 	(specifier-type 'integer))))))
 
-(macrolet ((frob (logfcn)
+(macrolet ((deffrob (logfcn)
 	     (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
 	     `(defoptimizer (,logfcn derive-type) ((x y))
 		(two-arg-derive-type x y #',fcn-aux #',logfcn)))))
-  ;; FIXME: DEF-FROB, not just FROB
-  (frob logand)
-  (frob logior)
-  (frob logxor))
+  (deffrob logand)
+  (deffrob logior)
+  (deffrob logxor))
+
+;;;; miscellaneous derive-type methods
 
 (defoptimizer (integer-length derive-type) ((x))
   (let ((x-type (continuation-type x)))
     (when (and (numeric-type-p x-type)
                (csubtypep x-type (specifier-type 'integer)))
-      ;; If the X is of type (INTEGER LO HI), then the integer-length
-      ;; of X is (INTEGER (min lo hi) (max lo hi), basically.  Be
+      ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
+      ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically.  Be
       ;; careful about LO or HI being NIL, though.  Also, if 0 is
       ;; contained in X, the lower bound is obviously 0.
       (flet ((null-or-min (a b)
@@ -2504,9 +2292,6 @@
           (when (ctypep 0 x-type)
             (setf min-len 0))
           (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
-) ; PROGN
-
-;;;; miscellaneous derive-type methods
 
 (defoptimizer (code-char derive-type) ((code))
   (specifier-type 'base-char))
@@ -2877,10 +2662,11 @@
 	   (logand x ,mask)))))
 
 ;;;; arithmetic and logical identity operation elimination
-;;;;
-;;;; Flush calls to various arith functions that convert to the
-;;;; identity function or a constant.
 
+;;; Flush calls to various arith functions that convert to the
+;;; identity function or a constant.
+;;;
+;;; FIXME: Rewrite as DEF-FROB.
 (dolist (stuff '((ash 0 x)
 		 (logand -1 x)
 		 (logand 0 0)
@@ -2902,7 +2688,7 @@
   '(%negate y))
 (deftransform * ((x y) (rational (constant-argument (member 0))) *
 		 :when :both)
-  "convert (* x 0) to 0."
+  "convert (* x 0) to 0"
   0)
 
 ;;; Return T if in an arithmetic op including continuations X and Y,
@@ -3077,8 +2863,8 @@
 (dolist (x '(eq char= equal))
   (%deftransform x '(function * *) #'simple-equality-transform))
 
-;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to
-;;; convert to a type-specific predicate or EQ:
+;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
+;;; try to convert to a type-specific predicate or EQ:
 ;;; -- If both args are characters, convert to CHAR=. This is better than
 ;;;    just converting to EQ, since CHAR= may have special compilation
 ;;;    strategies for non-standard representations, etc.
@@ -3089,7 +2875,7 @@
 ;;;    it second. These rules make it easier for the back end to match
 ;;;    these interesting cases.
 ;;; -- If Y is a fixnum, then we quietly pass because the back end can
-;;;    handle that case, otherwise give an efficency note.
+;;;    handle that case, otherwise give an efficiency note.
 (deftransform eql ((x y) * * :when :both)
   "convert to simpler equality predicate"
   (let ((x-type (continuation-type x))
@@ -3159,7 +2945,7 @@
 ;;;
 ;;; FIXME: Why should constant argument be second? It would be nice to
 ;;; find out and explain.
-#!-sb-propagate-float-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun ir1-transform-< (x y first second inverse)
   (if (same-leaf-ref-p x y)
       nil
@@ -3178,7 +2964,7 @@
 	       `(,inverse y x))
 	      (t
 	       (give-up-ir1-transform))))))
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun ir1-transform-< (x y first second inverse)
   (if (same-leaf-ref-p x y)
       nil
@@ -3200,11 +2986,11 @@
 (deftransform > ((x y) (integer integer) * :when :both)
   (ir1-transform-< y x x y '<))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (deftransform < ((x y) (float float) * :when :both)
   (ir1-transform-< x y x y '>))
 
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (deftransform > ((x y) (float float) * :when :both)
   (ir1-transform-< y x x y '<))
 
@@ -3486,7 +3272,7 @@
                  (and (subtypep coerced-type 'integer)
                       (csubtypep value-type (specifier-type 'integer))))))
          (process-types (type)
-           ;; FIXME
+           ;; FIXME:
            ;; This needs some work because we should be able to derive
            ;; the resulting type better than just the type arg of
            ;; coerce.  That is, if x is (integer 10 20), the (coerce x
@@ -3516,29 +3302,28 @@
 
 (defoptimizer (array-element-type derive-type) ((array))
   (let* ((array-type (continuation-type array)))
-    #!+sb-show
-    (format t "~& defoptimizer array-elt-derive-type - array-element-type ~~
-~A~%" array-type)
     (labels ((consify (list)
               (if (endp list)
                   '(eql nil)
                   `(cons (eql ,(car list)) ,(consify (rest list)))))
             (get-element-type (a)
-              (let ((element-type (type-specifier
-                                   (array-type-specialized-element-type a))))
-                (cond ((symbolp element-type)
+              (let ((element-type
+		     (type-specifier (array-type-specialized-element-type a))))
+                (cond ((eq element-type '*)
+                       (specifier-type 'type-specifier))
+		      ((symbolp element-type)
                        (make-member-type :members (list element-type)))
                       ((consp element-type)
                        (specifier-type (consify element-type)))
                       (t
-                       (error "Can't grok type ~A~%" element-type))))))
+                       (error "can't understand type ~S~%" element-type))))))
       (cond ((array-type-p array-type)
-            (get-element-type array-type))
-           ((union-type-p array-type)             
+	     (get-element-type array-type))
+	    ((union-type-p array-type)             
              (apply #'type-union
                     (mapcar #'get-element-type (union-type-types array-type))))
-           (t
-            *universal-type*)))))
+	    (t
+	     *universal-type*)))))
 
 ;;;; debuggers' little helpers