#+nil ; not tested yet..
(deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
- (vector vector &key
- (:start1 index) (:end1 (or index null))
- (:start2 index) (:end2 (or index null)))
- *
- ;; This is potentially an awfully big transform
- ;; (if things like (EQ SEQ1 SEQ2) aren't known
- ;; at runtime). We need to make it available
- ;; inline, since otherwise there's no way to do
- ;; it efficiently on all array types, but it
- ;; probably doesn't belong inline all the time.
- :policy (> speed (1+ space)))
+ (vector vector &key
+ (:start1 index) (:end1 (or index null))
+ (:start2 index) (:end2 (or index null)))
+ *
+ ;; This is potentially an awfully big transform
+ ;; (if things like (EQ SEQ1 SEQ2) aren't known
+ ;; at runtime). We need to make it available
+ ;; inline, since otherwise there's no way to do
+ ;; it efficiently on all array types, but it
+ ;; probably doesn't belong inline all the time.
+ :policy (> speed (1+ space)))
"open code"
(let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
- (et2 (upgraded-element-type-specifier-or-give-up seq2)))
+ (et2 (upgraded-element-type-specifier-or-give-up seq2)))
`(let* ((n-copied (min (- end1 start1) (- end2 start2)))
- (effective-end1 (+ start1 n-copied)))
+ (effective-end1 (+ start1 n-copied)))
(if (eq seq1 seq2)
- (with-array-data ((seq seq1)
- (start (min start1 start2))
- (end (max end1 end2)))
- (declare (type (simple-array ,et1 1) seq))
- (if (<= start1 start2)
- (let ((index2 start2))
- (declare (type index index2))
- (loop for index1 of-type index
- from start1 below effective-end1 do
- (setf (aref seq index1)
- (aref seq index2))
- (incf index2)))
- (let ((index2 (1- end2)))
- (declare (type (integer -2 #.most-positive-fixnum) index2))
- (loop for index1 of-type index-or-minus-1
- from (1- effective-end1) downto start1 do
- (setf (aref seq index1)
- (aref seq index2))
- (decf index2)))))
- (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
- (declare (type (simple-array ,et1 1) seq1))
- (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
- (declare (type (simple-array ,et2 1) seq2))
+ (with-array-data ((seq seq1)
+ (start (min start1 start2))
+ (end (max end1 end2)))
+ (declare (type (simple-array ,et1 1) seq))
+ (if (<= start1 start2)
+ (let ((index2 start2))
+ (declare (type index index2))
+ (loop for index1 of-type index
+ from start1 below effective-end1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (incf index2)))
+ (let ((index2 (1- end2)))
+ (declare (type (integer -2 #.most-positive-fixnum) index2))
+ (loop for index1 of-type index-or-minus-1
+ from (1- effective-end1) downto start1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (decf index2)))))
+ (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
+ (declare (type (simple-array ,et1 1) seq1))
+ (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
+ (declare (type (simple-array ,et2 1) seq2))
(let ((index2 start2))
- (declare (type index index2))
- (loop for index1 of-type index
- from start1 below effective-end1 do
- (setf (aref seq index1)
- (aref seq index2))
- (incf index2))))))
+ (declare (type index index2))
+ (loop for index1 of-type index
+ from start1 below effective-end1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (incf index2))))))
seq1)))
;;; Boyer-Moore search for strings.
;;; * investigate whether we can make this work with a hashtable and a
;;; default for "not in pattern"
(deftransform search ((pattern text)
- (simple-base-string simple-base-string))
+ (simple-base-string simple-base-string))
(unless (constant-lvar-p pattern)
(give-up-ir1-transform))
(let* ((pattern (lvar-value pattern))
- (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern)))
- (temp (make-array (length pattern) :element-type 'fixnum))
- (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern)))))
+ (bad-character (make-array 256 :element-type 'fixnum :initial-element (length pattern)))
+ (temp (make-array (length pattern) :element-type 'fixnum))
+ (good-suffix (make-array (length pattern) :element-type 'fixnum :initial-element (1- (length pattern)))))
(dotimes (i (1- (length pattern)))
(setf (aref bad-character (char-code (aref pattern i)))
- (- (length pattern) 1 i)))
+ (- (length pattern) 1 i)))
(setf (aref temp (1- (length pattern))) (length pattern))
(loop with g = (1- (length pattern))
- with f = (1- (length pattern)) ; XXXXXX?
- for i downfrom (- (length pattern) 2) above 0
- if (and (> i g)
- (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g)))
- do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f)))
- else
- do (progn
- (when (< i g)
- (setf g i))
- (setf f i)
- (do ()
- ((not
- (and (>= g 0)
- (char= (aref pattern g)
- (aref pattern (- (+ g (length pattern)) 1 f))))))
- (decf g))
- (setf (aref temp i) (- f g))))
+ with f = (1- (length pattern)) ; XXXXXX?
+ for i downfrom (- (length pattern) 2) above 0
+ if (and (> i g)
+ (< (aref temp (- (+ i (length pattern)) 1 f)) (- i g)))
+ do (setf (aref temp i) (aref temp (- (+ i (length pattern)) 1 f)))
+ else
+ do (progn
+ (when (< i g)
+ (setf g i))
+ (setf f i)
+ (do ()
+ ((not
+ (and (>= g 0)
+ (char= (aref pattern g)
+ (aref pattern (- (+ g (length pattern)) 1 f))))))
+ (decf g))
+ (setf (aref temp i) (- f g))))
(loop with j = 0
- for i downfrom (1- (length pattern)) to -1
- if (or (= i -1) (= (aref temp i) (1+ i)))
- do (do ()
- ((>= j (- (length pattern) 1 i)))
- (when (= (aref good-suffix j) (length pattern))
- (setf (aref good-suffix j) (- (length pattern) 1 i)))
- (incf j)))
+ for i downfrom (1- (length pattern)) to -1
+ if (or (= i -1) (= (aref temp i) (1+ i)))
+ do (do ()
+ ((>= j (- (length pattern) 1 i)))
+ (when (= (aref good-suffix j) (length pattern))
+ (setf (aref good-suffix j) (- (length pattern) 1 i)))
+ (incf j)))
(loop for i from 0 below (1- (length pattern))
- do (setf (aref good-suffix (- (length pattern) 1 (aref temp i)))
- (- (length pattern) 1 i)))
+ do (setf (aref good-suffix (- (length pattern) 1 (aref temp i)))
+ (- (length pattern) 1 i)))
`(let ((good-suffix ,good-suffix)
- (bad-character ,bad-character))
+ (bad-character ,bad-character))
(declare (optimize speed (safety 0)))
(block search
- (do ((j 0))
- ((> j (- (length text) (length pattern))))
- (declare (fixnum j))
- (do ((i (1- (length pattern)) (1- i)))
- ((< i 0) (return-from search j))
- (declare (fixnum i))
- (when (char/= (aref pattern i) (aref text (+ i j)))
- (incf j (max (aref good-suffix i)
- (+ (- (aref bad-character (char-code (aref text (+ i j))))
- (length pattern))
- (1+ i))))
- (return))))))))
+ (do ((j 0))
+ ((> j (- (length text) (length pattern))))
+ (declare (fixnum j))
+ (do ((i (1- (length pattern)) (1- i)))
+ ((< i 0) (return-from search j))
+ (declare (fixnum i))
+ (when (char/= (aref pattern i) (aref text (+ i j)))
+ (incf j (max (aref good-suffix i)
+ (+ (- (aref bad-character (char-code (aref text (+ i j))))
+ (length pattern))
+ (1+ i))))
+ (return))))))))
projects / sbcl.git / blobdiff