0.pre7.141:

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 56fa01a..8b24413 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -21,29 +21,29 @@
 ;;; We need to define these predicates, since the TYPEP source
 ;;; transform picks whichever predicate was defined last when there
 ;;; are multiple predicates for equivalent types.
-(def-source-transform short-float-p (x) `(single-float-p ,x))
+(define-source-transform short-float-p (x) `(single-float-p ,x))
 #!-long-float
-(def-source-transform long-float-p (x) `(double-float-p ,x))
+(define-source-transform long-float-p (x) `(double-float-p ,x))
 
-(def-source-transform compiled-function-p (x)
+(define-source-transform compiled-function-p (x)
   `(functionp ,x))
 
-(def-source-transform char-int (x)
+(define-source-transform char-int (x)
   `(char-code ,x))
 
 (deftransform abs ((x) (rational))
   '(if (< x 0) (- x) x))
 
 ;;; The layout is stored in slot 0.
-(def-source-transform %instance-layout (x)
+(define-source-transform %instance-layout (x)
   `(truly-the layout (%instance-ref ,x 0)))
-(def-source-transform %set-instance-layout (x val)
+(define-source-transform %set-instance-layout (x val)
   `(%instance-set ,x 0 (the layout ,val)))
 \f
 ;;;; character support
 
 ;;; In our implementation there are really only BASE-CHARs.
-(def-source-transform characterp (obj)
+(define-source-transform characterp (obj)
   `(base-char-p ,obj))
 \f
 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
@@ -179,47 +179,52 @@
   (frob (simple-array (unsigned-byte 2) (*)) 2)
   (frob (simple-array (unsigned-byte 4) (*)) 4))
 \f
-;;;; bit vector hackery
+;;;; BIT-VECTOR hackery
 
-;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that
-;;; does 32 bits at a time.
+;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
+;;; loop that 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:~
+;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
+;;; be a function call instead.
+(macrolet ((def (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 bit-and 32bit-logical-and)
+ (def bit-ior 32bit-logical-or)
+ (def bit-xor 32bit-logical-xor)
+ (def bit-eqv 32bit-logical-eqv)
+ (def bit-nand 32bit-logical-nand)
+ (def bit-nor 32bit-logical-nor)
+ (def bit-andc1 32bit-logical-andc1)
+ (def bit-andc2 32bit-logical-andc2)
+ (def bit-orc1 32bit-logical-orc1)
+ (def bit-orc2 32bit-logical-orc2))
 
 (deftransform bit-not
              ((bit-array result-bit-array)