NJF DOLIST/MACROLET patch for vmtran (sbcl-devel 2002-01-07,

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index e94f70d..0e1990d 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -141,7 +141,7 @@
 
 ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
 ;;; elements.
-(def-source-transform vector (&rest elements)
+(define-source-transform vector (&rest elements)
   (let ((len (length elements))
        (n -1))
     (once-only ((n-vec `(make-array ,len)))
@@ -155,10 +155,10 @@
         ,n-vec))))
 
 ;;; Just convert it into a MAKE-ARRAY.
-(def-source-transform make-string (length &key
-                                         (element-type ''base-char)
-                                         (initial-element
-                                          '#.*default-init-char-form*))
+(define-source-transform make-string (length &key
+                                            (element-type ''base-char)
+                                            (initial-element
+                                             '#.*default-init-char-form*))
   `(make-array (the index ,length)
               :element-type ,element-type
               :initial-element ,initial-element))
@@ -379,7 +379,7 @@
        (give-up-ir1-transform
         "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
       (unless (> (length dims) axis)
-       (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
+       (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
                             dims
                             axis))
       (let ((dim (nth axis dims)))
@@ -548,14 +548,14 @@
              (cond (,end
                     (unless (or ,unsafe? (<= ,end ,size))
                       ,(if fail-inline?
-                           `(error "End ~D is greater than total size ~D."
+                           `(error "End ~W is greater than total size ~W."
                                    ,end ,size)
                            `(failed-%with-array-data ,array ,start ,end)))
                     ,end)
                    (t ,size))))
        (unless (or ,unsafe? (<= ,start ,defaulted-end))
         ,(if fail-inline?
-             `(error "Start ~D is greater than end ~D." ,start ,defaulted-end)
+             `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
              `(failed-%with-array-data ,array ,start ,end)))
        (do ((,data ,array (%array-data-vector ,data))
            (,cumulative-offset 0
@@ -595,9 +595,9 @@
 ;;; assertions on the array.
 (macrolet ((define-frob (reffer setter type)
             `(progn
-               (def-source-transform ,reffer (a &rest i)
+               (define-source-transform ,reffer (a &rest i)
                  `(aref (the ,',type ,a) ,@i))
-               (def-source-transform ,setter (a &rest i)
+               (define-source-transform ,setter (a &rest i)
                  `(%aset (the ,',type ,a) ,@i)))))
   (define-frob svref %svset simple-vector)
   (define-frob schar %scharset simple-string)
@@ -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)