Handle run-program with :directory nil.

[sbcl.git] / src / code / bit-bash.lisp

diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp
index 7c7e539..28d9204 100644 (file)
--- a/src/code/bit-bash.lisp
+++ b/src/code/bit-bash.lisp
@@ -594,3 +594,100 @@
   (declare (type system-area-pointer sap))
   (declare (type fixnum offset))
   (copy-ub8-to-system-area bv 0 sap offset (length bv)))
+
+\f
+;;;; Bashing-Style search for bits
+;;;;
+;;;; Similar search would work well for base-strings as well.
+;;;; (Technically for all unboxed sequences of sub-word size elements,
+;;;; but somehow I doubt eg. octet vectors get POSITION or FIND used
+;;;; as much on them.)
+(defconstant +bit-position-base-mask+ (1- n-word-bits))
+(defconstant +bit-position-base-shift+ (integer-length +bit-position-base-mask+))
+(macrolet ((def (name frob)
+             `(defun ,name (vector from-end start end)
+                (declare (simple-bit-vector vector)
+                         (index start end)
+                         (optimize (speed 3) (safety 0)))
+                (unless (= start end)
+                  (let* ((last-word (ash end (- +bit-position-base-shift+)))
+                         (last-bits (logand end +bit-position-base-mask+))
+                         (first-word (ash start (- +bit-position-base-shift+)))
+                         (first-bits (logand start +bit-position-base-mask+))
+                         ;; These mask out everything but the interesting parts.
+                         (end-mask #!+little-endian (lognot (ash -1 last-bits))
+                                   #!+big-endian (ash -1 (- sb!vm:n-word-bits last-bits)))
+                         (start-mask #!+little-endian (ash -1 first-bits)
+                                     #!+big-endian (lognot (ash -1 (- sb!vm:n-word-bits first-bits)))))
+                    (declare (index last-word first-word))
+                    (flet ((#!+little-endian start-bit
+                            #!+big-endian end-bit (x)
+                             (declare (word x))
+                             (- #!+big-endian sb!vm:n-word-bits
+                                (integer-length (logand x (- x)))
+                                #!+little-endian 1))
+                           (#!+little-endian end-bit
+                            #!+big-endian start-bit (x)
+                             (declare (word x))
+                             (- #!+big-endian sb!vm:n-word-bits
+                                (integer-length x)
+                                #!+little-endian 1))
+                           (found (i word-offset)
+                             (declare (index i word-offset))
+                             (return-from ,name
+                               (logior i (truly-the
+                                          fixnum
+                                          (ash word-offset +bit-position-base-shift+)))))
+                           (get-word (offset)
+                             (,@frob (%vector-raw-bits vector offset))))
+                      (declare (inline start-bit end-bit get-word))
+                      (if from-end
+                          ;; Back to front
+                          (let* ((word-offset last-word)
+                                 (word (logand end-mask (get-word word-offset))))
+                            (declare (word word)
+                                     (index word-offset))
+                            (unless (zerop word)
+                              (when (= word-offset first-word)
+                                (setf word (logand word start-mask)))
+                              (unless (zerop word)
+                                (found (end-bit word) word-offset)))
+                            (decf word-offset)
+                            (loop
+                              (when (< word-offset first-word)
+                                (return-from ,name nil))
+                              (setf word (get-word word-offset))
+                              (unless (zerop word)
+                                (when (= word-offset first-word)
+                                  (setf word (logand word start-mask)))
+                                (unless (zerop word)
+                                  (found (end-bit word) word-offset)))
+                              (decf word-offset)))
+                          ;; Front to back
+                          (let* ((word-offset first-word)
+                                 (word (logand start-mask (get-word word-offset))))
+                            (declare (word word)
+                                     (index word-offset))
+                            (unless (zerop word)
+                              (when (= word-offset last-word)
+                                (setf word (logand word end-mask)))
+                              (unless (zerop word)
+                                (found (start-bit word) word-offset)))
+                            (incf word-offset)
+                            (loop
+                              (when (> word-offset last-word)
+                                (return-from ,name nil))
+                              (setf word (get-word word-offset))
+                              (unless (zerop word)
+                                (when (= word-offset last-word)
+                                  (setf word (logand word end-mask)))
+                                (unless (zerop word)
+                                  (found (start-bit word) word-offset)))
+                              (incf word-offset))))))))))
+  (def %bit-position/0 (logandc2 #.(1- (expt 2 n-word-bits))))
+  (def %bit-position/1 (identity)))
+(defun %bit-position (bit vector from-end start end)
+  (case bit
+    (0 (%bit-position/0 vector from-end start end))
+    (1 (%bit-position/1 vector from-end start end))
+    (otherwise nil)))