From 4ad052044a22f502d9dc6faf6dfe01f3bab84262 Mon Sep 17 00:00:00 2001
From: William Harold Newman <william.newman@airmail.net>
Date: Thu, 10 Jan 2002 03:12:18 +0000
Subject: [PATCH] 	NJF DOLIST/MACROLET patch for vmtran (sbcl-devel
 2002-01-07, 		revised 2002-01-08)

---
 src/compiler/array-tran.lisp      |   35 +++++++------
 src/compiler/float-tran.lisp      |  100 +++++++++++++++++++------------------
 src/compiler/generic/vm-tran.lisp |   67 ++++++++++++-------------
 src/compiler/saptran.lisp         |   56 ++++++++++++++-------
 src/compiler/seqtran.lisp         |   26 +++-------
 src/compiler/srctran.lisp         |   91 +++++++++++++++++----------------
 version.lisp-expr                 |    2 +-
 7 files changed, 199 insertions(+), 178 deletions(-)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 4b4337f..0e1990d 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -682,20 +682,27 @@
 ;;;; and eliminates the need for any VM-dependent transforms to handle
 ;;;; these cases.
 
-(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
-		       bit-andc2 bit-orc1 bit-orc2))
-  ;; Make a result array if result is NIL or unsupplied.
-  (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
-		     '(bit-vector bit-vector &optional null) '*
-		     :eval-name t
-		     :policy (>= speed space))
-    `(,fun bit-array-1 bit-array-2
-	   (make-array (length bit-array-1) :element-type 'bit)))
-  ;; If result is T, make it the first arg.
-  (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
-		     '(bit-vector bit-vector (member t)) '*
-		     :eval-name t)
-    `(,fun bit-array-1 bit-array-2 bit-array-1)))
+(macrolet ((def-frob (fun)
+             `(progn
+               (deftransform ,fun ((bit-array-1 bit-array-2 &optional result-bit-array)
+                                   (bit-vector bit-vector &optional null) *
+                                   :policy (>= speed space))
+                 `(,',fun bit-array-1 bit-array-2
+                   (make-array (length bit-array-1) :element-type 'bit)))
+               ;; If result is T, make it the first arg.
+               (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
+                                   (bit-vector bit-vector (member t)) *)
+                 `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
+  (def-frob bit-and)
+  (def-frob bit-ior)
+  (def-frob bit-xor)
+  (def-frob bit-eqv)
+  (def-frob bit-nand)
+  (def-frob bit-nor)
+  (def-frob bit-andc1)
+  (def-frob bit-andc2)
+  (def-frob bit-orc1)
+  (def-frob bit-orc2))
 
 ;;; Similar for BIT-NOT, but there is only one arg...
 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index dc2615f..c1fbd73 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -390,59 +390,61 @@
   (double-float) double-float
   (movable foldable flushable))
 
-(dolist (stuff '((exp %exp *)
-		 (log %log float)
-		 (sqrt %sqrt float)
-		 (asin %asin float)
-		 (acos %acos float)
-		 (atan %atan *)
-		 (sinh %sinh *)
-		 (cosh %cosh *)
-		 (tanh %tanh *)
-		 (asinh %asinh *)
-		 (acosh %acosh float)
-		 (atanh %atanh float)))
-  (destructuring-bind (name prim rtype) stuff
-    (deftransform name ((x) '(single-float) rtype :eval-name t)
-      `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
-      `(,prim x))))
+(macrolet ((def-frob (name prim rtype)
+             `(progn
+               (deftransform ,name ((x) (single-float) ,rtype)
+                 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+               (deftransform ,name ((x) (double-float) ,rtype :when :both)
+                 `(,',prim x)))))
+  (def-frob exp %exp *)
+  (def-frob log %log float)
+  (def-frob sqrt %sqrt float)
+  (def-frob asin %asin float)
+  (def-frob acos %acos float)
+  (def-frob atan %atan *)
+  (def-frob sinh %sinh *)
+  (def-frob cosh %cosh *)
+  (def-frob tanh %tanh *)
+  (def-frob asinh %asinh *)
+  (def-frob acosh %acosh float)
+  (def-frob atanh %atanh float))
 
 ;;; The argument range is limited on the x86 FP trig. functions. A
 ;;; post-test can detect a failure (and load a suitable result), but
 ;;; this test is avoided if possible.
-(dolist (stuff '((sin %sin %sin-quick)
-		 (cos %cos %cos-quick)
-		 (tan %tan %tan-quick)))
-  (destructuring-bind (name prim prim-quick) stuff
-    (declare (ignorable prim-quick))
-    (deftransform name ((x) '(single-float) '* :eval-name t)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(single-float
-						 (#.(- (expt 2f0 64)))
-						 (#.(expt 2f0 64)))))
-		    `(coerce (,prim-quick (coerce x 'double-float))
-		    'single-float))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		      because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(coerce (,prim (coerce x 'double-float)) 'single-float)))
-      #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
-    (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
-      #!+x86 (cond ((csubtypep (continuation-type x)
-			       (specifier-type '(double-float
-						 (#.(- (expt 2d0 64)))
-						 (#.(expt 2d0 64)))))
-		    `(,prim-quick x))
-		   (t
-		    (compiler-note
-		    "unable to avoid inline argument range check~@
-		   because the argument range (~S) was not within 2^64"
-		    (type-specifier (continuation-type x)))
-		    `(,prim x)))
-      #!-x86 `(,prim x))))
+(macrolet ((def-frob (name prim prim-quick)
+             (declare (ignorable prim-quick))
+             `(progn
+                (deftransform ,name ((x) (single-float) *)
+                  #!+x86 (cond ((csubtypep (continuation-type x)
+                                           (specifier-type '(single-float
+                                                             (#.(- (expt 2f0 64)))
+                                                             (#.(expt 2f0 64)))))
+                                `(coerce (,',prim-quick (coerce x 'double-float))
+                                  'single-float))
+                               (t
+                                (compiler-note
+                                 "unable to avoid inline argument range check~@
+                                  because the argument range (~S) was not within 2^64"
+                                 (type-specifier (continuation-type x)))
+                                `(coerce (,',prim (coerce x 'double-float)) 'single-float)))
+                  #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+               (deftransform ,name ((x) (double-float) * :when :both)
+                 #!+x86 (cond ((csubtypep (continuation-type x)
+                                          (specifier-type '(double-float
+                                                            (#.(- (expt 2d0 64)))
+                                                            (#.(expt 2d0 64)))))
+                               `(,',prim-quick x))
+                              (t
+                               (compiler-note
+                                "unable to avoid inline argument range check~@
+                                 because the argument range (~S) was not within 2^64"
+                                (type-specifier (continuation-type x)))
+                               `(,',prim x)))
+                 #!-x86 `(,',prim x)))))
+  (def-frob sin %sin %sin-quick)
+  (def-frob cos %cos %cos-quick)
+  (def-frob tan %tan %tan-quick))
 
 (deftransform atan ((x y) (single-float single-float) *)
   `(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 0b81b5f..64f5fb1 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -185,41 +185,40 @@
 ;;; does 32 bits at a time.
 ;;;
 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should be a
-;;; function call instead. And do it with DEF-FROB instead of DOLIST.
-(dolist (x '((bit-and 32bit-logical-and)
-	     (bit-ior 32bit-logical-or)
-	     (bit-xor 32bit-logical-xor)
-	     (bit-eqv 32bit-logical-eqv)
-	     (bit-nand 32bit-logical-nand)
-	     (bit-nor 32bit-logical-nor)
-	     (bit-andc1 32bit-logical-andc1)
-	     (bit-andc2 32bit-logical-andc2)
-	     (bit-orc1 32bit-logical-orc1)
-	     (bit-orc2 32bit-logical-orc2)))
-  (destructuring-bind (bitfun wordfun) x
-    (deftransform bitfun
-		  ((bit-array-1 bit-array-2 result-bit-array)
-		   '(simple-bit-vector simple-bit-vector simple-bit-vector) '*
-		   :eval-name t :node node :policy (>= speed space))
-      `(progn
-	 ,@(unless (policy node (zerop safety))
-	     '((unless (= (length bit-array-1) (length bit-array-2)
-			  (length result-bit-array))
-		 (error "Argument and/or result bit arrays are not the same length:~
+;;; function call instead.
+(macrolet ((def-frob (bitfun wordfun)
+             `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array)
+                                     (simple-bit-vector simple-bit-vector simple-bit-vector) *
+                                     :node node :policy (>= speed space))
+                `(progn
+                   ,@(unless (policy node (zerop safety))
+                             '((unless (= (length bit-array-1) (length bit-array-2)
+                                          (length result-bit-array))
+                                 (error "Argument and/or result bit arrays are not the same length:~
 			 ~%  ~S~%  ~S  ~%  ~S"
-			bit-array-1 bit-array-2 result-bit-array))))
-	 (do ((index sb!vm:vector-data-offset (1+ index))
-	      (end (+ sb!vm:vector-data-offset
-		      (truncate (the index
-				     (+ (length bit-array-1)
-					sb!vm:n-word-bits -1))
-				sb!vm:n-word-bits))))
-	     ((= index end) result-bit-array)
-	   (declare (optimize (speed 3) (safety 0))
-		    (type index index end))
-	   (setf (%raw-bits result-bit-array index)
-		 (,wordfun (%raw-bits bit-array-1 index)
-			   (%raw-bits bit-array-2 index))))))))
+                                        bit-array-1 bit-array-2 result-bit-array))))
+                  (do ((index sb!vm:vector-data-offset (1+ index))
+                       (end (+ sb!vm:vector-data-offset
+                               (truncate (the index
+                                           (+ (length bit-array-1)
+                                              sb!vm:n-word-bits -1))
+                                         sb!vm:n-word-bits))))
+                      ((= index end) result-bit-array)
+                    (declare (optimize (speed 3) (safety 0))
+                             (type index index end))
+                    (setf (%raw-bits result-bit-array index)
+                          (,',wordfun (%raw-bits bit-array-1 index)
+                                      (%raw-bits bit-array-2 index))))))))
+ (def-frob bit-and 32bit-logical-and)
+ (def-frob bit-ior 32bit-logical-or)
+ (def-frob bit-xor 32bit-logical-xor)
+ (def-frob bit-eqv 32bit-logical-eqv)
+ (def-frob bit-nand 32bit-logical-nand)
+ (def-frob bit-nor 32bit-logical-nor)
+ (def-frob bit-andc1 32bit-logical-andc1)
+ (def-frob bit-andc2 32bit-logical-andc2)
+ (def-frob bit-orc1 32bit-logical-orc1)
+ (def-frob bit-orc2 32bit-logical-orc2))
 
 (deftransform bit-not
 	      ((bit-array result-bit-array)
diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp
index fcc376b..2f17e65 100644
--- a/src/compiler/saptran.lisp
+++ b/src/compiler/saptran.lisp
@@ -109,10 +109,14 @@
 
 ;;;; transforms for converting sap relation operators
 
-(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
-  (destructuring-bind (sap-fun int-fun) info
-    (deftransform sap-fun ((x y) '* '* :eval-name t)
-      `(,int-fun (sap-int x) (sap-int y)))))
+(macrolet ((def-frob (sap-fun int-fun)
+             `(deftransform ,sap-fun ((x y) * *)
+                `(,',int-fun (sap-int x) (sap-int y)))))
+  (def-frob sap< <)
+  (def-frob sap<= <=)
+  (def-frob sap= =)
+  (def-frob sap>= >=)
+  (def-frob sap> >))
 
 ;;;; transforms for optimizing SAP+
 
@@ -125,18 +129,32 @@
 	 '(lambda (sap offset1 offset2)
 	    (sap+ sap (+ offset1 offset2))))))
 
-(dolist (fun '(sap-ref-8 %set-sap-ref-8
-	       signed-sap-ref-8 %set-signed-sap-ref-8
-	       sap-ref-16 %set-sap-ref-16
-	       signed-sap-ref-16 %set-signed-sap-ref-16
-	       sap-ref-32 %set-sap-ref-32
-	       signed-sap-ref-32 %set-signed-sap-ref-32
-	       sap-ref-sap %set-sap-ref-sap
-	       sap-ref-single %set-sap-ref-single
-	       sap-ref-double %set-sap-ref-double
-	       #!+(or x86 long-float) sap-ref-long
-	       #!+long-float %set-sap-ref-long))
-  (deftransform fun ((sap offset) '* '* :eval-name t)
-    (extract-function-args sap 'sap+ 2)
-    `(lambda (sap offset1 offset2)
-       (,fun sap (+ offset1 offset2)))))
+(macrolet ((def-frob (fun)
+             `(deftransform ,fun ((sap offset) * *)
+                (extract-function-args sap 'sap+ 2)
+                 `(lambda (sap offset1 offset2)
+                   (,',fun sap (+ offset1 offset2))))))
+  (def-frob sap-ref-8)
+  (def-frob %set-sap-ref-8)
+  (def-frob signed-sap-ref-8)
+  (def-frob %set-signed-sap-ref-8)
+  (def-frob sap-ref-16)
+  (def-frob %set-sap-ref-16)
+  (def-frob signed-sap-ref-16)
+  (def-frob %set-signed-sap-ref-16)
+  (def-frob sap-ref-32)
+  (def-frob %set-sap-ref-32)
+  (def-frob signed-sap-ref-32)
+  (def-frob %set-signed-sap-ref-32)
+  (def-frob sap-ref-sap)
+  (def-frob %set-sap-ref-sap)
+  (def-frob sap-ref-single)
+  (def-frob %set-sap-ref-single)
+  (def-frob sap-ref-double)
+  (def-frob %set-sap-ref-double)
+  ;; The original CMUCL code had #!+(and x86 long-float) for this first one,
+  ;; but only #!+long-float for the second.  This was redundant, since the
+  ;; LONG-FLOAT target feature only exists on X86.  So we removed the
+  ;; redundancy.  --njf 2002-01-08
+  #!+long-float (def-frob sap-ref-long)
+  #!+long-float (def-frob %set-sap-ref-long))
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 91713e5..a938962 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -227,15 +227,8 @@
 (deftransform %setelt ((s i v) (list * *))
   '(setf (car (nthcdr i s)) v))
 
-;;; FIXME: The MACROLET ... DEF-FROB ... DEFTRANSFORM idioms in this
-;;; file are literal translations of old CMU CL DOLIST ... DEFTRANSFORM,
-;;; and so use :EVAL-NAME for historical reasons. It'd be tidier to
-;;; just let macroexpansion substitution take care of everything,
-;;; and remove both :EVAL-NAME and the extra layer of quotes.
-
 (macrolet ((def-frob (name)
-             `(deftransform ',name ((e l &key (test #'eql)) '* '* :node node :when :both
-                                    :eval-name t)
+             `(deftransform ,name ((e l &key (test #'eql)) * * :node node :when :both)
                 (unless (constant-continuation-p l)
                   (give-up-ir1-transform))
 
@@ -261,8 +254,7 @@
 ;;; this was done, a few bytes could be saved by a call to a shared
 ;;; function.  This remains to be done.
 (macrolet ((def-frob (fun eq-fun)
-             `(deftransform ',fun ((item list &key test) '(t list &rest t) '*
-                                   :eval-name t)
+             `(deftransform ,fun ((item list &key test) (t list &rest t) *)
                 "convert to EQ test"
                 ;; FIXME: The scope of this transformation could be
                 ;; widened somewhat, letting it work whenever the test is
@@ -543,9 +535,9 @@
 ;;; version. This is an IR1 transform so that we don't have to worry about
 ;;; changing the order of evaluation.
 (macrolet ((def-frob (fun pred*)
-             `(deftransform ',fun ((string1 string2 &key (start1 0) end1
+             `(deftransform ,fun ((string1 string2 &key (start1 0) end1
                                                          (start2 0) end2)
-                                   '* '* :eval-name t)
+                                   * *)
                 `(,',pred* string1 string2 start1 end1 start2 end2))))
   (def-frob string< string<*)
   (def-frob string> string>*)
@@ -559,9 +551,8 @@
 ;;; start and end are also gotten from the environment. Both strings
 ;;; must be SIMPLE-STRINGs.
 (macrolet ((def-frob (name lessp equalp)
-             `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
-                                    '(simple-string simple-string t t t t) '*
-                                    :eval-name t)
+             `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+                                    (simple-string simple-string t t t t) *)
                 `(let* ((end1 (if (not end1) (length string1) end1))
                         (end2 (if (not end2) (length string2) end2))
                         (index (sb!impl::%sp-string-compare
@@ -585,9 +576,8 @@
   (def-frob string>=* nil t))
 
 (macrolet ((def-frob (name result-fun)
-             `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
-                                   '(simple-string simple-string t t t t) '*
-                                   :eval-name t)
+             `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+                                   (simple-string simple-string t t t t) *)
                 `(,',result-fun
                   (sb!impl::%sp-string-compare
                    string1 start1 (or end1 (length string1))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index daa33b5..e7bae1b 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2665,20 +2665,18 @@
 
 ;;; 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-frob (name identity result)
+             `(deftransform ,name ((x y) (* (constant-argument (member ,identity)))
+                                    * :when :both)
+                "fold identity operations"
+                ',result)))
+  (def-frob ash 0 x)
+  (def-frob logand -1 x)
+  (def-frob logand 0 0)
+  (def-frob logior 0 x)
+  (def-frob logior -1 -1)
+  (def-frob logxor -1 (lognot x))
+  (def-frob 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.
@@ -2752,18 +2750,18 @@
   '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-frob (name result minus-result)
+             `(deftransform ,name ((x y) (t (constant-argument real))
+                                    * :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)))))
+  (def-frob * x (%negate x))
+  (def-frob / x (%negate x))
+  (def-frob expt x (/ 1 x)))
 
 ;;; Fold (expt x n) into multiplications for small integral values of
 ;;; N; convert (expt x 1/2) to sqrt.
@@ -2788,21 +2786,25 @@
 ;;; 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-frob (name)
+             `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+                                   * :when :both)
+                "fold zero arg"
+                0)))
+  (def-frob ash)
+  (def-frob /))
+
+(macrolet ((def-frob (name)
+             `(deftransform ,name ((x y) ((constant-argument (integer 0 0)) integer)
+                                   * :when :both)
+                "fold zero arg"
+                '(values 0 0))))
+  (def-frob truncate)
+  (def-frob round)
+  (def-frob floor)
+  (def-frob ceiling))
+
 
 ;;;; character operations
 
@@ -2860,8 +2862,11 @@
 	(t
 	 (give-up-ir1-transform))))
 
-(dolist (x '(eq char= equal))
-  (%deftransform x '(function * *) #'simple-equality-transform))
+(macrolet ((def-frob (x)
+             `(%deftransform ',x '(function * *) #'simple-equality-transform)))
+  (def-frob eq)
+  (def-frob char=)
+  (def-frob equal))
 
 ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
 ;;; try to convert to a type-specific predicate or EQ:
diff --git a/version.lisp-expr b/version.lisp-expr
index 86571b2..caeb541 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre7.120"
+"0.pre7.121"
-- 
1.7.10.4