X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=f9b0161ea2392f07b699e4345aae598211866de3;hb=ad1aa2961d81ed8db9dac59068c6861199c29a3a;hp=35b35b19cbbef59cf115599c43897181dcb20001;hpb=2d75f4246b8451a9c2c95cd36673d98c82c9845f;p=sbcl.git

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 35b35b1..f9b0161 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -15,22 +15,22 @@
 
 ;;; Convert into an IF so that IF optimizations will eliminate redundant
 ;;; negations.
-(def-source-transform not (x) `(if ,x nil t))
-(def-source-transform null (x) `(if ,x nil t))
+(define-source-transform not (x) `(if ,x nil t))
+(define-source-transform null (x) `(if ,x nil t))
 
 ;;; ENDP is just NULL with a LIST assertion. The assertion will be
 ;;; optimized away when SAFETY optimization is low; hopefully that
 ;;; is consistent with ANSI's "should return an error".
-(def-source-transform endp (x) `(null (the list ,x)))
+(define-source-transform endp (x) `(null (the list ,x)))
 
 ;;; We turn IDENTITY into PROG1 so that it is obvious that it just
 ;;; returns the first value of its argument. Ditto for VALUES with one
 ;;; arg.
-(def-source-transform identity (x) `(prog1 ,x))
-(def-source-transform values (x) `(prog1 ,x))
+(define-source-transform identity (x) `(prog1 ,x))
+(define-source-transform values (x) `(prog1 ,x))
 
 ;;; Bind the values and make a closure that returns them.
-(def-source-transform constantly (value)
+(define-source-transform constantly (value)
   (let ((rest (gensym "CONSTANTLY-REST-")))
     `(lambda (&rest ,rest)
        (declare (ignore ,rest))
@@ -40,10 +40,10 @@
 ;;; lambda with the appropriate fixed number of args. If the
 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
 ;;; MV optimization figure things out.
-(deftransform complement ((fun) * * :node node :when :both)
+(deftransform complement ((fun) * * :node node)
   "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))
@@ -97,31 +97,31 @@
 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
 ;;; favors it.
-(def-source-transform first (x) `(car ,x))
-(def-source-transform rest (x) `(cdr ,x))
-(def-source-transform second (x) `(cadr ,x))
-(def-source-transform third (x) `(caddr ,x))
-(def-source-transform fourth (x) `(cadddr ,x))
-(def-source-transform fifth (x) `(nth 4 ,x))
-(def-source-transform sixth (x) `(nth 5 ,x))
-(def-source-transform seventh (x) `(nth 6 ,x))
-(def-source-transform eighth (x) `(nth 7 ,x))
-(def-source-transform ninth (x) `(nth 8 ,x))
-(def-source-transform tenth (x) `(nth 9 ,x))
+(define-source-transform first (x) `(car ,x))
+(define-source-transform rest (x) `(cdr ,x))
+(define-source-transform second (x) `(cadr ,x))
+(define-source-transform third (x) `(caddr ,x))
+(define-source-transform fourth (x) `(cadddr ,x))
+(define-source-transform fifth (x) `(nth 4 ,x))
+(define-source-transform sixth (x) `(nth 5 ,x))
+(define-source-transform seventh (x) `(nth 6 ,x))
+(define-source-transform eighth (x) `(nth 7 ,x))
+(define-source-transform ninth (x) `(nth 8 ,x))
+(define-source-transform tenth (x) `(nth 9 ,x))
 
 ;;; Translate RPLACx to LET and SETF.
-(def-source-transform rplaca (x y)
+(define-source-transform rplaca (x y)
   (once-only ((n-x x))
     `(progn
        (setf (car ,n-x) ,y)
        ,n-x)))
-(def-source-transform rplacd (x y)
+(define-source-transform rplacd (x y)
   (once-only ((n-x x))
     `(progn
        (setf (cdr ,n-x) ,y)
        ,n-x)))
 
-(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
 
 (defvar *default-nthcdr-open-code-limit* 6)
 (defvar *extreme-nthcdr-open-code-limit* 20)
@@ -145,21 +145,21 @@
 
 ;;;; arithmetic and numerology
 
-(def-source-transform plusp (x) `(> ,x 0))
-(def-source-transform minusp (x) `(< ,x 0))
-(def-source-transform zerop (x) `(= ,x 0))
+(define-source-transform plusp (x) `(> ,x 0))
+(define-source-transform minusp (x) `(< ,x 0))
+(define-source-transform zerop (x) `(= ,x 0))
 
-(def-source-transform 1+ (x) `(+ ,x 1))
-(def-source-transform 1- (x) `(- ,x 1))
+(define-source-transform 1+ (x) `(+ ,x 1))
+(define-source-transform 1- (x) `(- ,x 1))
 
-(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(def-source-transform evenp (x) `(zerop (logand ,x 1)))
+(define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
+(define-source-transform evenp (x) `(zerop (logand ,x 1)))
 
 ;;; Note that all the integer division functions are available for
 ;;; inline expansion.
 
 (macrolet ((deffrob (fun)
-	     `(def-source-transform ,fun (x &optional (y nil y-p))
+	     `(define-source-transform ,fun (x &optional (y nil y-p))
 		(declare (ignore y))
 		(if y-p
 		    (values nil t)
@@ -171,29 +171,30 @@
   #-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)))
-(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
-(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(def-source-transform logbitp (index integer)
+(define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
+(define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
+(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
+(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
+(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
+(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
+(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+(define-source-transform logbitp (index integer)
   `(not (zerop (logand (ash 1 ,index) ,integer))))
-(def-source-transform byte (size position) `(cons ,size ,position))
-(def-source-transform byte-size (spec) `(car ,spec))
-(def-source-transform byte-position (spec) `(cdr ,spec))
-(def-source-transform ldb-test (bytespec integer)
+(define-source-transform byte (size position)
+  `(cons ,size ,position))
+(define-source-transform byte-size (spec) `(car ,spec))
+(define-source-transform byte-position (spec) `(cdr ,spec))
+(define-source-transform ldb-test (bytespec integer)
   `(not (zerop (mask-field ,bytespec ,integer))))
 
 ;;; With the ratio and complex accessors, we pick off the "identity"
 ;;; case, and use a primitive to handle the cell access case.
-(def-source-transform numerator (num)
+(define-source-transform numerator (num)
   (once-only ((n-num `(the rational ,num)))
     `(if (ratiop ,n-num)
 	 (%numerator ,n-num)
 	 ,n-num)))
-(def-source-transform denominator (num)
+(define-source-transform denominator (num)
   (once-only ((n-num `(the rational ,num)))
     `(if (ratiop ,n-num)
 	 (%denominator ,n-num)
@@ -355,11 +356,11 @@
 (defun interval-bounded-p (x how)
   (declare (type interval x))
   (ecase how
-    ('above
+    (above
      (interval-high x))
-    ('below
+    (below
      (interval-low x))
-    ('both
+    (both
      (and (interval-low x) (interval-high x)))))
 
 ;;; signed zero comparison functions. Use these functions if we need
@@ -630,7 +631,7 @@
 	      :low (bound-mul (interval-low x) (interval-low y))
 	      :high (bound-mul (interval-high x) (interval-high y))))
 	    (t
-	     (error "internal error in INTERVAL-MUL"))))))
+	     (bug "excluded case in INTERVAL-MUL"))))))
 
 ;;; Divide two intervals.
 (defun interval-div (top bot)
@@ -680,7 +681,7 @@
 	      :low (bound-div (interval-low top) (interval-high bot) t)
 	      :high (bound-div (interval-high top) (interval-low bot) nil)))
 	    (t
-	     (error "internal error in INTERVAL-DIV"))))))
+	     (bug "excluded case 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
@@ -732,9 +733,9 @@
 (defun interval-abs (x)
   (declare (type interval x))
   (case (interval-range-info x)
-    ('+
+    (+
      (copy-interval x))
-    ('-
+    (-
      (interval-neg x))
     (t
      (destructuring-bind (x- x+) (interval-split 0 x t t)
@@ -1354,14 +1355,14 @@
   (flet ((ash-outer (n s)
 	   (when (and (fixnump s)
 		      (<= s 64)
-		      (> s sb!vm:*target-most-negative-fixnum*))
+		      (> s sb!xc:most-negative-fixnum))
 	     (ash n s)))
          ;; KLUDGE: The bare 64's here should be related to
          ;; symbolic machine word size values somehow.
 
 	 (ash-inner (n s)
 	   (if (and (fixnump s)
-		    (> s sb!vm:*target-most-negative-fixnum*))
+		    (> s sb!xc:most-negative-fixnum))
              (ash n (min s 64))
              (if (minusp n) -1 0))))
     (or (and (csubtypep n-type (specifier-type 'integer))
@@ -1647,7 +1648,7 @@
 
 ;;; Define optimizers for FLOOR and CEILING.
 (macrolet
-    ((frob-opt (name q-name r-name)
+    ((def (name q-name r-name)
        (let ((q-aux (symbolicate q-name "-AUX"))
 	     (r-aux (symbolicate r-name "-AUX")))
 	 `(progn
@@ -1711,54 +1712,52 @@
 		 (when (and quot rem)
 		   (make-values-type :required (list quot rem))))))))))
 
-  ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
-  (frob-opt floor floor-quotient-bound floor-rem-bound)
-  (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
+  (def floor floor-quotient-bound floor-rem-bound)
+  (def ceiling ceiling-quotient-bound ceiling-rem-bound))
 
 ;;; Define optimizers for FFLOOR and FCEILING
-(macrolet
-    ((frob-opt (name q-name r-name)
-       (let ((q-aux (symbolicate "F" q-name "-AUX"))
-	     (r-aux (symbolicate r-name "-AUX")))
-	 `(progn
-	   ;; Compute type of quotient (first) result.
-	   (defun ,q-aux (number-type divisor-type)
-	     (let* ((number-interval
-		     (numeric-type->interval number-type))
-		    (divisor-interval
-		     (numeric-type->interval divisor-type))
-		    (quot (,q-name (interval-div number-interval
-						 divisor-interval)))
-		    (res-type (numeric-contagion number-type divisor-type)))
-	       (make-numeric-type
-		:class (numeric-type-class res-type)
-		:format (numeric-type-format res-type)
-		:low  (interval-low quot)
-		:high (interval-high quot))))
-
-	   (defoptimizer (,name derive-type) ((number divisor))
-	     (flet ((derive-q (n d same-arg)
-		      (declare (ignore same-arg))
-		      (if (and (numeric-type-real-p n)
-			       (numeric-type-real-p d))
-			  (,q-aux n d)
-			  *empty-type*))
-		    (derive-r (n d same-arg)
-		      (declare (ignore same-arg))
-		      (if (and (numeric-type-real-p n)
-			       (numeric-type-real-p d))
-			  (,r-aux n d)
-			  *empty-type*)))
-	       (let ((quot (two-arg-derive-type
-			    number divisor #'derive-q #',name))
-		     (rem (two-arg-derive-type
-			   number divisor #'derive-r #'mod)))
-		 (when (and quot rem)
-		   (make-values-type :required (list quot rem))))))))))
-
-  ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
-  (frob-opt ffloor floor-quotient-bound floor-rem-bound)
-  (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
+(macrolet ((def (name q-name r-name)
+	     (let ((q-aux (symbolicate "F" q-name "-AUX"))
+		   (r-aux (symbolicate r-name "-AUX")))
+	       `(progn
+		  ;; Compute type of quotient (first) result.
+		  (defun ,q-aux (number-type divisor-type)
+		    (let* ((number-interval
+			    (numeric-type->interval number-type))
+			   (divisor-interval
+			    (numeric-type->interval divisor-type))
+			   (quot (,q-name (interval-div number-interval
+							divisor-interval)))
+			   (res-type (numeric-contagion number-type
+							divisor-type)))
+		      (make-numeric-type
+		       :class (numeric-type-class res-type)
+		       :format (numeric-type-format res-type)
+		       :low  (interval-low quot)
+		       :high (interval-high quot))))
+
+		  (defoptimizer (,name derive-type) ((number divisor))
+		    (flet ((derive-q (n d same-arg)
+			     (declare (ignore same-arg))
+			     (if (and (numeric-type-real-p n)
+				      (numeric-type-real-p d))
+				 (,q-aux n d)
+				 *empty-type*))
+			   (derive-r (n d same-arg)
+			     (declare (ignore same-arg))
+			     (if (and (numeric-type-real-p n)
+				      (numeric-type-real-p d))
+				 (,r-aux n d)
+				 *empty-type*)))
+		      (let ((quot (two-arg-derive-type
+				   number divisor #'derive-q #',name))
+			    (rem (two-arg-derive-type
+				  number divisor #'derive-r #'mod)))
+			(when (and quot rem)
+			  (make-values-type :required (list quot rem))))))))))
+
+  (def ffloor floor-quotient-bound floor-rem-bound)
+  (def fceiling ceiling-quotient-bound ceiling-rem-bound))
 
 ;;; functions to compute the bounds on the quotient and remainder for
 ;;; the FLOOR function
@@ -2298,8 +2297,8 @@
 
 (defoptimizer (values derive-type) ((&rest values))
   (values-specifier-type
-   `(values ,@(mapcar #'(lambda (x)
-			  (type-specifier (continuation-type x)))
+   `(values ,@(mapcar (lambda (x)
+			(type-specifier (continuation-type x)))
 		      values))))
 
 ;;;; byte operations
@@ -2334,19 +2333,19 @@
 			  `(let ((,,temp ,,spec))
 			     ,,@body))))))
 
-  (def-source-transform ldb (spec int)
+  (define-source-transform ldb (spec int)
     (with-byte-specifier (size pos spec)
       `(%ldb ,size ,pos ,int)))
 
-  (def-source-transform dpb (newbyte spec int)
+  (define-source-transform dpb (newbyte spec int)
     (with-byte-specifier (size pos spec)
       `(%dpb ,newbyte ,size ,pos ,int)))
 
-  (def-source-transform mask-field (spec int)
+  (define-source-transform mask-field (spec int)
     (with-byte-specifier (size pos spec)
       `(%mask-field ,size ,pos ,int)))
 
-  (def-source-transform deposit-field (newbyte spec int)
+  (define-source-transform deposit-field (newbyte spec int)
     (with-byte-specifier (size pos spec)
       `(%deposit-field ,newbyte ,size ,pos ,int))))
 
@@ -2355,7 +2354,7 @@
     (if (and (numeric-type-p size)
 	     (csubtypep size (specifier-type 'integer)))
 	(let ((size-high (numeric-type-high size)))
-	  (if (and size-high (<= size-high sb!vm:word-bits))
+	  (if (and size-high (<= size-high sb!vm:n-word-bits))
 	      (specifier-type `(unsigned-byte ,size-high))
 	      (specifier-type 'unsigned-byte)))
 	*universal-type*)))
@@ -2370,7 +2369,7 @@
 	(let ((size-high (numeric-type-high size))
 	      (posn-high (numeric-type-high posn)))
 	  (if (and size-high posn-high
-		   (<= (+ size-high posn-high) sb!vm:word-bits))
+		   (<= (+ size-high posn-high) sb!vm:n-word-bits))
 	      (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
 	      (specifier-type 'unsigned-byte)))
 	*universal-type*)))
@@ -2390,7 +2389,7 @@
 	      (high (numeric-type-high int))
 	      (low (numeric-type-low int)))
 	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) sb!vm:word-bits))
+		   (<= (+ size-high posn-high) sb!vm:n-word-bits))
 	      (specifier-type
 	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
 		     (max (integer-length high)
@@ -2414,7 +2413,7 @@
 	      (high (numeric-type-high int))
 	      (low (numeric-type-low int)))
 	  (if (and size-high posn-high high low
-		   (<= (+ size-high posn-high) sb!vm:word-bits))
+		   (<= (+ size-high posn-high) sb!vm:n-word-bits))
 	      (specifier-type
 	       (list (if (minusp low) 'signed-byte 'unsigned-byte)
 		     (max (integer-length high)
@@ -2425,19 +2424,19 @@
 
 (deftransform %ldb ((size posn int)
 		    (fixnum fixnum integer)
-		    (unsigned-byte #.sb!vm:word-bits))
+		    (unsigned-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(logand (ash int (- posn))
-	   (ash ,(1- (ash 1 sb!vm:word-bits))
-		(- size ,sb!vm:word-bits))))
+	   (ash ,(1- (ash 1 sb!vm:n-word-bits))
+		(- size ,sb!vm:n-word-bits))))
 
 (deftransform %mask-field ((size posn int)
 			   (fixnum fixnum integer)
-			   (unsigned-byte #.sb!vm:word-bits))
+			   (unsigned-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(logand int
-	   (ash (ash ,(1- (ash 1 sb!vm:word-bits))
-		     (- size ,sb!vm:word-bits))
+	   (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
+		     (- size ,sb!vm:n-word-bits))
 		posn)))
 
 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
@@ -2448,7 +2447,7 @@
 
 (deftransform %dpb ((new size posn int)
 		    *
-		    (unsigned-byte #.sb!vm:word-bits))
+		    (unsigned-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(let ((mask (ldb (byte size 0) -1)))
      (logior (ash (logand new mask) posn)
@@ -2456,7 +2455,7 @@
 
 (deftransform %dpb ((new size posn int)
 		    *
-		    (signed-byte #.sb!vm:word-bits))
+		    (signed-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(let ((mask (ldb (byte size 0) -1)))
      (logior (ash (logand new mask) posn)
@@ -2464,7 +2463,7 @@
 
 (deftransform %deposit-field ((new size posn int)
 			      *
-			      (unsigned-byte #.sb!vm:word-bits))
+			      (unsigned-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
      (logior (logand new mask)
@@ -2472,7 +2471,7 @@
 
 (deftransform %deposit-field ((new size posn int)
 			      *
-			      (signed-byte #.sb!vm:word-bits))
+			      (signed-byte #.sb!vm:n-word-bits))
   "convert to inline logical operations"
   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
      (logior (logand new mask)
@@ -2484,7 +2483,7 @@
 (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
   (if (and (constant-continuation-p x)
 	   (not (constant-continuation-p y)))
-      `(,(continuation-function-name (basic-combination-fun node))
+      `(,(continuation-fun-name (basic-combination-fun node))
 	y
 	,(continuation-value x))
       (give-up-ir1-transform)))
@@ -2494,7 +2493,7 @@
 		 "place constant arg last"))
 
 ;;; Handle the case of a constant BOOLE-CODE.
-(deftransform boole ((op x y) * * :when :both)
+(deftransform boole ((op x y) * *)
   "convert to inline logical operations"
   (unless (constant-continuation-p op)
     (give-up-ir1-transform "BOOLE code is not a constant."))
@@ -2523,7 +2522,7 @@
 ;;;; converting special case multiply/divide to shifts
 
 ;;; If arg is a constant power of two, turn * into a shift.
-(deftransform * ((x y) (integer integer) * :when :both)
+(deftransform * ((x y) (integer integer) *)
   "convert x*2^k to shift"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2610,7 +2609,7 @@
     (frob y t)))
 
 ;;; Do the same for MOD.
-(deftransform mod ((x y) (integer integer) * :when :both)
+(deftransform mod ((x y) (integer integer) *)
   "convert remainder mod 2^k to LOGAND"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2647,7 +2646,7 @@
 		   (logand x ,mask))))))
 
 ;;; And the same for REM.
-(deftransform rem ((x y) (integer integer) * :when :both)
+(deftransform rem ((x y) (integer integer) *)
   "convert remainder mod 2^k to LOGAND"
   (unless (constant-continuation-p y)
     (give-up-ir1-transform))
@@ -2665,29 +2664,24 @@
 
 ;;; 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)
-		 (logior 0 x)
-		 (logior -1 -1)
-		 (logxor -1 (lognot x))
-		 (logxor 0 x)))
-  (destructuring-bind (name identity result) stuff
-    (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
-			:eval-name t :when :both)
-      "fold identity operations"
-      result)))
+(macrolet ((def (name identity result)
+             `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
+                "fold identity operations"
+                ',result)))
+  (def ash 0 x)
+  (def logand -1 x)
+  (def logand 0 0)
+  (def logior 0 x)
+  (def logior -1 -1)
+  (def logxor -1 (lognot x))
+  (def logxor 0 x))
 
 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
 ;;; (* 0 -4.0) is -0.0.
-(deftransform - ((x y) ((constant-argument (member 0)) rational) *
-		 :when :both)
+(deftransform - ((x y) ((constant-arg (member 0)) rational) *)
   "convert (- 0 x) to negate"
   '(%negate y))
-(deftransform * ((x y) (rational (constant-argument (member 0))) *
-		 :when :both)
+(deftransform * ((x y) (rational (constant-arg (member 0))) *)
   "convert (* x 0) to 0"
   0)
 
@@ -2729,7 +2723,7 @@
 ;;;
 ;;; If y is not constant, not zerop, or is contagious, or a positive
 ;;; float +0.0 then give up.
-(deftransform + ((x y) (t (constant-argument t)) * :when :both)
+(deftransform + ((x y) (t (constant-arg t)) *)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2742,7 +2736,7 @@
 ;;;
 ;;; If y is not constant, not zerop, or is contagious, or a negative
 ;;; float -0.0 then give up.
-(deftransform - ((x y) (t (constant-argument t)) * :when :both)
+(deftransform - ((x y) (t (constant-arg t)) *)
   "fold zero arg"
   (let ((val (continuation-value y)))
     (unless (and (zerop val)
@@ -2752,22 +2746,21 @@
   'x)
 
 ;;; Fold (OP x +/-1)
-(dolist (stuff '((* x (%negate x))
-		 (/ x (%negate x))
-		 (expt x (/ 1 x))))
-  (destructuring-bind (name result minus-result) stuff
-    (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t
-			:when :both)
-      "fold identity operations"
-      (let ((val (continuation-value y)))
-	(unless (and (= (abs val) 1)
-		     (not-more-contagious y x))
-	  (give-up-ir1-transform))
-	(if (minusp val) minus-result result)))))
+(macrolet ((def (name result minus-result)
+             `(deftransform ,name ((x y) (t (constant-arg real)) *)
+                "fold identity operations"
+                (let ((val (continuation-value y)))
+                  (unless (and (= (abs val) 1)
+                               (not-more-contagious y x))
+                    (give-up-ir1-transform))
+                  (if (minusp val) ',minus-result ',result)))))
+  (def * x (%negate x))
+  (def / x (%negate x))
+  (def expt x (/ 1 x)))
 
 ;;; Fold (expt x n) into multiplications for small integral values of
 ;;; N; convert (expt x 1/2) to sqrt.
-(deftransform expt ((x y) (t (constant-argument real)) *)
+(deftransform expt ((x y) (t (constant-arg real)) *)
   "recode as multiplication or sqrt"
   (let ((val (continuation-value y)))
     ;; If Y would cause the result to be promoted to the same type as
@@ -2788,21 +2781,24 @@
 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
 ;;; transformations?
 ;;; Perhaps we should have to prove that the denominator is nonzero before
-;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps
-;;; just FROB?) -- WHN 19990917
-;;;
-;;; FIXME: What gives with the single quotes in the argument lists
-;;; for DEFTRANSFORMs here? Does that work? Is it needed? Why?
-(dolist (name '(ash /))
-  (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
-		      :eval-name t :when :both)
-    "fold zero arg"
-    0))
-(dolist (name '(truncate round floor ceiling))
-  (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
-		      :eval-name t :when :both)
-    "fold zero arg"
-    '(values 0 0)))
+;;; doing them?  -- WHN 19990917
+(macrolet ((def (name)
+             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
+                                   *)
+                "fold zero arg"
+                0)))
+  (def ash)
+  (def /))
+
+(macrolet ((def (name)
+             `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
+                                   *)
+                "fold zero arg"
+                '(values 0 0))))
+  (def truncate)
+  (def round)
+  (def floor)
+  (def ceiling))
 
 ;;;; character operations
 
@@ -2850,8 +2846,7 @@
 ;;; if there is no intersection between the types of the arguments,
 ;;; then the result is definitely false.
 (deftransform simple-equality-transform ((x y) * *
-					 :defun-only t
-					 :when :both)
+					 :defun-only t)
   (cond ((same-leaf-ref-p x y)
 	 t)
 	((not (types-equal-or-intersect (continuation-type x)
@@ -2860,8 +2855,11 @@
 	(t
 	 (give-up-ir1-transform))))
 
-(dolist (x '(eq char= equal))
-  (%deftransform x '(function * *) #'simple-equality-transform))
+(macrolet ((def (x)
+             `(%deftransform ',x '(function * *) #'simple-equality-transform)))
+  (def eq)
+  (def char=)
+  (def equal))
 
 ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
@@ -2876,7 +2874,7 @@
 ;;;    these interesting cases.
 ;;; -- If Y is a fixnum, then we quietly pass because the back end can
 ;;;    handle that case, otherwise give an efficiency note.
-(deftransform eql ((x y) * * :when :both)
+(deftransform eql ((x y) * *)
   "convert to simpler equality predicate"
   (let ((x-type (continuation-type x))
 	(y-type (continuation-type y))
@@ -2902,7 +2900,7 @@
 
 ;;; Convert to EQL if both args are rational and complexp is specified
 ;;; and the same for both.
-(deftransform = ((x y) * * :when :both)
+(deftransform = ((x y) * *)
   "open code"
   (let ((x-type (continuation-type x))
 	(y-type (continuation-type y)))
@@ -2980,18 +2978,18 @@
 	      (t
 	       (give-up-ir1-transform))))))
 
-(deftransform < ((x y) (integer integer) * :when :both)
+(deftransform < ((x y) (integer integer) *)
   (ir1-transform-< x y x y '>))
 
-(deftransform > ((x y) (integer integer) * :when :both)
+(deftransform > ((x y) (integer integer) *)
   (ir1-transform-< y x x y '<))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform < ((x y) (float float) * :when :both)
+(deftransform < ((x y) (float float) *)
   (ir1-transform-< x y x y '>))
 
 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
-(deftransform > ((x y) (float float) * :when :both)
+(deftransform > ((x y) (float float) *)
   (ir1-transform-< y x x y '<))
 
 ;;;; converting N-arg comparisons
@@ -3031,31 +3029,31 @@
 	       ((zerop i)
 		`((lambda ,vars ,result) . ,args)))))))
 
-(def-source-transform = (&rest args) (multi-compare '= args nil))
-(def-source-transform < (&rest args) (multi-compare '< args nil))
-(def-source-transform > (&rest args) (multi-compare '> args nil))
-(def-source-transform <= (&rest args) (multi-compare '> args t))
-(def-source-transform >= (&rest args) (multi-compare '< args t))
+(define-source-transform = (&rest args) (multi-compare '= args nil))
+(define-source-transform < (&rest args) (multi-compare '< args nil))
+(define-source-transform > (&rest args) (multi-compare '> args nil))
+(define-source-transform <= (&rest args) (multi-compare '> args t))
+(define-source-transform >= (&rest args) (multi-compare '< args t))
 
-(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
+(define-source-transform char= (&rest args) (multi-compare 'char= args nil))
+(define-source-transform char< (&rest args) (multi-compare 'char< args nil))
+(define-source-transform char> (&rest args) (multi-compare 'char> args nil))
+(define-source-transform char<= (&rest args) (multi-compare 'char> args t))
+(define-source-transform char>= (&rest args) (multi-compare 'char< args t))
 
-(def-source-transform char-equal (&rest args)
+(define-source-transform char-equal (&rest args)
   (multi-compare 'char-equal args nil))
-(def-source-transform char-lessp (&rest args)
+(define-source-transform char-lessp (&rest args)
   (multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args)
+(define-source-transform char-greaterp (&rest args)
   (multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args)
+(define-source-transform char-not-greaterp (&rest args)
   (multi-compare 'char-greaterp args t))
-(def-source-transform char-not-lessp (&rest args)
+(define-source-transform char-not-lessp (&rest args)
   (multi-compare 'char-lessp args t))
 
 ;;; This function does source transformation of N-arg inequality
-;;; functions such as /=. This is similar to Multi-Compare in the <3
+;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
 ;;; arg cases. If there are more than two args, then we expand into
 ;;; the appropriate n^2 comparisons only when speed is important.
 (declaim (ftype (function (symbol list) *) multi-not-equal))
@@ -3080,20 +3078,20 @@
 		 (dolist (v2 next)
 		   (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
 
-(def-source-transform /= (&rest args) (multi-not-equal '= args))
-(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
-(def-source-transform char-not-equal (&rest args)
+(define-source-transform /= (&rest args) (multi-not-equal '= args))
+(define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(define-source-transform char-not-equal (&rest args)
   (multi-not-equal 'char-equal args))
 
 ;;; Expand MAX and MIN into the obvious comparisons.
-(def-source-transform max (arg &rest more-args)
+(define-source-transform max (arg &rest more-args)
   (if (null more-args)
       `(values ,arg)
       (once-only ((arg1 arg)
 		  (arg2 `(max ,@more-args)))
 	`(if (> ,arg1 ,arg2)
 	     ,arg1 ,arg2))))
-(def-source-transform min (arg &rest more-args)
+(define-source-transform min (arg &rest more-args)
   (if (null more-args)
       `(values ,arg)
       (once-only ((arg1 arg)
@@ -3107,13 +3105,13 @@
 ;;;; versions, and degenerate cases are flushed.
 
 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
-(declaim (ftype (function (symbol t list) list) associate-arguments))
-(defun associate-arguments (function first-arg more-args)
+(declaim (ftype (function (symbol t list) list) associate-args))
+(defun associate-args (function first-arg more-args)
   (let ((next (rest more-args))
 	(arg (first more-args)))
     (if (null next)
 	`(,function ,first-arg ,arg)
-	(associate-arguments function `(,function ,first-arg ,arg) next))))
+	(associate-args function `(,function ,first-arg ,arg) next))))
 
 ;;; Do source transformations for transitive functions such as +.
 ;;; One-arg cases are replaced with the arg and zero arg cases with
@@ -3128,18 +3126,20 @@
 	   `(,leaf-fun ,(first args) ,(second args))
 	   (values nil t)))
     (t
-     (associate-arguments fun (first args) (rest args)))))
+     (associate-args fun (first args) (rest args)))))
 
-(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
-(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args)
+(define-source-transform + (&rest args)
+  (source-transform-transitive '+ args 0))
+(define-source-transform * (&rest args)
+  (source-transform-transitive '* args 1))
+(define-source-transform logior (&rest args)
   (source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args)
+(define-source-transform logxor (&rest args)
   (source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args)
+(define-source-transform logand (&rest args)
   (source-transform-transitive 'logand args -1))
 
-(def-source-transform logeqv (&rest args)
+(define-source-transform logeqv (&rest args)
   (if (evenp (length args))
       `(lognot (logxor ,@args))
       `(logxor ,@args)))
@@ -3148,19 +3148,19 @@
 ;;; because when they are given one argument, they return its absolute
 ;;; value.
 
-(def-source-transform gcd (&rest args)
+(define-source-transform gcd (&rest args)
   (case (length args)
     (0 0)
     (1 `(abs (the integer ,(first args))))
     (2 (values nil t))
-    (t (associate-arguments 'gcd (first args) (rest args)))))
+    (t (associate-args 'gcd (first args) (rest args)))))
 
-(def-source-transform lcm (&rest args)
+(define-source-transform lcm (&rest args)
   (case (length args)
     (0 1)
     (1 `(abs (the integer ,(first args))))
     (2 (values nil t))
-    (t (associate-arguments 'lcm (first args) (rest args)))))
+    (t (associate-args 'lcm (first args) (rest args)))))
 
 ;;; Do source transformations for intransitive n-arg functions such as
 ;;; /. With one arg, we form the inverse. With two args we pass.
@@ -3170,11 +3170,11 @@
   (case (length args)
     ((0 2) (values nil t))
     (1 `(,@inverse ,(first args)))
-    (t (associate-arguments function (first args) (rest args)))))
+    (t (associate-args function (first args) (rest args)))))
 
-(def-source-transform - (&rest args)
+(define-source-transform - (&rest args)
   (source-transform-intransitive '- args '(%negate)))
-(def-source-transform / (&rest args)
+(define-source-transform / (&rest args)
   (source-transform-intransitive '/ args '(/ 1)))
 
 ;;;; transforming APPLY
@@ -3182,11 +3182,11 @@
 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
 ;;; only needs to understand one kind of variable-argument call. It is
 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
-(def-source-transform apply (fun arg &rest more-args)
+(define-source-transform apply (fun arg &rest more-args)
   (let ((args (cons arg more-args)))
     `(multiple-value-call ,fun
-       ,@(mapcar #'(lambda (x)
-		     `(values ,x))
+       ,@(mapcar (lambda (x)
+		   `(values ,x))
 		 (butlast args))
        (values-list ,(car (last args))))))