0.7.1.47:
[sbcl.git] / src / compiler / array-tran.lisp
index 4b4337f..3e3329b 100644 (file)
        (n -1))
     (once-only ((n-vec `(make-array ,len)))
       `(progn
-        ,@(mapcar #'(lambda (el)
-                      (once-only ((n-val el))
-                        `(locally (declare (optimize (safety 0)))
-                                  (setf (svref ,n-vec ,(incf n))
-                                        ,n-val))))
+        ,@(mapcar (lambda (el)
+                    (once-only ((n-val el))
+                      `(locally (declare (optimize (safety 0)))
+                                (setf (svref ,n-vec ,(incf n))
+                                      ,n-val))))
                   elements)
         ,n-vec))))
 
                                   '(:initial-element initial-element))))
             (setf (%array-displaced-p header) nil)
             ,@(let ((axis -1))
-                (mapcar #'(lambda (dim)
-                            `(setf (%array-dimension header ,(incf axis))
-                                   ,dim))
+                (mapcar (lambda (dim)
+                          `(setf (%array-dimension header ,(incf axis))
+                                 ,dim))
                         dims))
             (truly-the ,spec header))))))
 \f
 ;;;; 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 (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 bit-and)
+  (def bit-ior)
+  (def bit-xor)
+  (def bit-eqv)
+  (def bit-nand)
+  (def bit-nor)
+  (def bit-andc1)
+  (def bit-andc2)
+  (def bit-orc1)
+  (def bit-orc2))
 
 ;;; Similar for BIT-NOT, but there is only one arg...
 (deftransform bit-not ((bit-array-1 &optional result-bit-array)
   '(bit-not bit-array-1
            (make-array (length bit-array-1) :element-type 'bit)))
 (deftransform bit-not ((bit-array-1 result-bit-array)
-                      (bit-vector (constant-argument t)))
+                      (bit-vector (constant-arg t)))
   '(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
-;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
+;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
+;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
 ;;; value?
 \f
 ;;; Pick off some constant cases.
 (deftransform array-header-p ((array) (array))
   (let ((type (continuation-type array)))
-    (declare (optimize (safety 3)))
     (unless (array-type-p type)
       (give-up-ir1-transform))
     (let ((dims (array-type-dimensions type)))
       (cond ((csubtypep type (specifier-type '(simple-array * (*))))
-            ;; No array header.
+            ;; no array header
             nil)
            ((and (listp dims) (> (length dims) 1))
-            ;; Multi-dimensional array, will have a header.
+            ;; multi-dimensional array, will have a header
             t)
            (t
             (give-up-ir1-transform))))))