Commit 06a3725d authored by Jan Moringen's avatar Jan Moringen Committed by Attila Lendvai

fix STARTS-WITH-SUBSEQ for non-array sequences

parent 926a0666
...@@ -300,28 +300,40 @@ sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE." ...@@ -300,28 +300,40 @@ sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENCE."
"Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX. "Test whether the first elements of SEQUENCE are the same (as per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the function returns, as a second value, a If RETURN-SUFFIX is T the function returns, as a second value, a
displaced array pointing to the sequence after PREFIX." sub-sequence or displaced array pointing to the sequence after PREFIX."
(declare (dynamic-extent args)) (declare (dynamic-extent args))
(let ((sequence-length (length sequence)) (let ((sequence-length (length sequence))
(prefix-length (length prefix))) (prefix-length (length prefix)))
(if (<= prefix-length sequence-length) (when (< sequence-length prefix-length)
(let ((mismatch (apply #'mismatch prefix sequence (return-from starts-with-subseq (values nil nil)))
(if return-suffix-supplied-p (flet ((make-suffix (start)
(remove-from-plist args :return-suffix) (when return-suffix
args)))) (cond
(if mismatch ((not (arrayp sequence))
(if (< mismatch prefix-length) (if start
(values nil nil) (subseq sequence start)
(values t (when return-suffix (subseq sequence 0 0)))
(make-array (- sequence-length mismatch) ((not start)
:element-type (array-element-type sequence) (make-array 0
:displaced-to sequence :element-type (array-element-type sequence)
:displaced-index-offset prefix-length :adjustable nil))
:adjustable nil)))) (t
(values t (when return-suffix (make-array (- sequence-length start)
(make-array 0 :element-type (array-element-type sequence) :element-type (array-element-type sequence)
:adjustable nil))))) :displaced-to sequence
(values nil nil)))) :displaced-index-offset start
:adjustable nil))))))
(let ((mismatch (apply #'mismatch prefix sequence
(if return-suffix-supplied-p
(remove-from-plist args :return-suffix)
args))))
(cond
((not mismatch)
(values t (make-suffix nil)))
((= mismatch prefix-length)
(values t (make-suffix mismatch)))
(t
(values nil nil)))))))
(defun ends-with-subseq (suffix sequence &key (test #'eql)) (defun ends-with-subseq (suffix sequence &key (test #'eql))
"Test whether SEQUENCE ends with SUFFIX. In other words: return true if "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
......
...@@ -1960,6 +1960,21 @@ ...@@ -1960,6 +1960,21 @@
n) n)
13) 13)
(deftest starts-with-subseq.string
(starts-with-subseq "f" "foo" :return-suffix t)
t
"oo")
(deftest starts-with-subseq.vector
(starts-with-subseq #(1) #(1 2 3) :return-suffix t)
t
#(2 3))
(deftest starts-with-subseq.list
(starts-with-subseq '(1) '(1 2 3) :return-suffix t)
t
(2 3))
(deftest starts-with-subseq.start1 (deftest starts-with-subseq.start1
(starts-with-subseq "foo" "oop" :start1 1) (starts-with-subseq "foo" "oop" :start1 1)
t t
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment