nil
(if (<= 0 ,start ,length)
,start
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
index)
`(,end
nil
;; FIXME: defend against non-number non-NIL
;; stuff?
,end
- (signal-bounding-indices-bad-error ,sequence
- ,start ,end))
+ (sequence-bounding-indices-bad-error ,sequence ,start ,end))
(or null index)))))
'((start end length sequence)
(start1 end1 length1 sequence1)
;; This seems silly, is there something better?
'(integer 0 (0))))))
-(defun signal-bounding-indices-bad-error (sequence start end)
- (let ((length (length sequence)))
+(defun sequence-bounding-indices-bad-error (sequence start end)
+ (let ((size (length sequence)))
(error 'bounding-indices-bad-error
:datum (cons start end)
- :expected-type `(cons (integer 0 ,length)
- (or null (integer ,start ,length)))
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
:object sequence)))
+
+(defun array-bounding-indices-bad-error (array start end)
+ (let ((size (array-total-size array)))
+ (error 'bounding-indices-bad-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 ,size)
+ (integer ,start ,size))
+ :object array)))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
;;;; so we worry about dealing with END being supplied or defaulting
;;;; to NIL at this level.
-(defun vector-subseq* (sequence start &optional end)
+(defun string-subseq* (sequence start end)
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :force-inline t
+ :check-fill-pointer t)
+ (declare (optimize (speed 3) (safety 0)))
+ (string-dispatch ((simple-array character (*))
+ (simple-array base-char (*))
+ (vector nil))
+ data
+ (subseq data start end))))
+
+(defun vector-subseq* (sequence start end)
(declare (type vector sequence))
- (declare (type index start))
- (declare (type (or null index) end))
- (when (null end)
- (setf end (length sequence)))
- (unless (<= 0 start end (length sequence))
- (signal-bounding-indices-bad-error sequence start end))
- (do ((old-index start (1+ old-index))
- (new-index 0 (1+ new-index))
- (copy (%make-sequence-like sequence (- end start))))
- ((= old-index end) copy)
- (declare (fixnum old-index new-index))
- (setf (aref copy new-index)
- (aref sequence old-index))))
-
-(defun list-subseq* (sequence start &optional end)
- (declare (type list sequence))
- ;; the INDEX declaration isn't actually mandatory, but it's true for
- ;; all practical purposes.
- (declare (type index start))
- (declare (type (or null index) end))
- (do ((list sequence (cdr list))
- (index 0 (1+ index))
- (result nil))
- (nil)
- (cond
- ((null list) (if (or (and end (> end index))
- (< index start))
- (signal-bounding-indices-bad-error sequence start end)
- (return (nreverse result))))
- ((< index start) nil)
- ((and end (= index end)) (return (nreverse result)))
- (t (push (car list) result)))))
+ (declare (type index start)
+ (type (or null index) end))
+ (with-array-data ((data sequence)
+ (start start)
+ (end end)
+ :check-fill-pointer t
+ :force-inline t)
+ (let* ((copy (%make-sequence-like sequence (- end start)))
+ (setter (!find-data-vector-setter copy))
+ (reffer (!find-data-vector-reffer data)))
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((old-index start (1+ old-index))
+ (new-index 0 (1+ new-index)))
+ ((= old-index end) copy)
+ (declare (index old-index new-index))
+ (funcall setter copy new-index
+ (funcall reffer data old-index))))))
+
+(defun list-subseq* (sequence start end)
+ (declare (type list sequence)
+ (type unsigned-byte start)
+ (type (or null unsigned-byte) end))
+ (flet ((oops ()
+ (sequence-bounding-indices-bad-error sequence start end)))
+ (let ((pointer sequence))
+ (unless (zerop start)
+ ;; If START > 0 the list cannot be empty. So CDR down to
+ ;; it START-1 times, check that we still have something, then
+ ;; CDR the final time.
+ ;;
+ ;; If START was zero, the list may be empty if END is NIL or
+ ;; also zero.
+ (when (> start 1)
+ (setf pointer (nthcdr (1- start) pointer)))
+ (if pointer
+ (pop pointer)
+ (oops)))
+ (if end
+ (let ((n (- end start)))
+ (declare (integer n))
+ (when (minusp n)
+ (oops))
+ (when (plusp n)
+ (let* ((head (list nil))
+ (tail head))
+ (macrolet ((pop-one ()
+ `(let ((tmp (list (pop pointer))))
+ (setf (cdr tail) tmp
+ tail tmp))))
+ ;; Bignum case
+ (loop until (fixnump n)
+ do (pop-one)
+ (decf n))
+ ;; Fixnum case, but leave last element, so we should
+ ;; still have something left in the sequence.
+ (let ((m (1- n)))
+ (declare (fixnum m))
+ (loop repeat m
+ do (pop-one)))
+ (unless pointer
+ (oops))
+ ;; OK, pop the last one.
+ (pop-one)
+ (cdr head)))))
+ (loop while pointer
+ collect (pop pointer))))))
(defun subseq (sequence start &optional end)
#!+sb-doc
(do ((elt))
((= index end))
(setq elt (aref vector index))
- ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT
- ;; arguments simultaneously is a little fragile, since ANSI says
- ;; we can't depend on it, so we need to remember to keep that
- ;; extension in our implementation. It'd probably be better to
- ;; rewrite this to avoid passing both (as
- ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18).
(unless (or (and from-end
- (position (apply-key key elt) result
- :start start :end jndex
- :test test :test-not test-not :key key))
+ (if test-not
+ (position (apply-key key elt) result
+ :start start :end jndex
+ :test-not test-not :key key)
+ (position (apply-key key elt) result
+ :start start :end jndex
+ :test test :key key)))
(and (not from-end)
- (position (apply-key key elt) vector
- :start (1+ index) :end end
- :test test :test-not test-not :key key)))
+ (if test-not
+ (position (apply-key key elt) vector
+ :start (1+ index) :end end
+ :test-not test-not :key key)
+ (position (apply-key key elt) vector
+ :start (1+ index) :end end
+ :test test :key key))))
(setf (aref result jndex) elt)
(setq jndex (1+ jndex)))
(setq index (1+ index)))
(setf (aref vector jndex) (aref vector index))))
(declare (fixnum index jndex))
(setf (aref vector jndex) (aref vector index))
- (unless (position (apply-key key (aref vector index)) vector :key key
- :start (if from-end start (1+ index)) :test test
- :end (if from-end jndex end) :test-not test-not)
+ (unless (if test-not
+ (position (apply-key key (aref vector index)) vector :key key
+ :start (if from-end start (1+ index))
+ :end (if from-end jndex end)
+ :test-not test-not)
+ (position (apply-key key (aref vector index)) vector :key key
+ :start (if from-end start (1+ index))
+ :end (if from-end jndex end)
+ :test test))
(setq jndex (1+ jndex)))))
(define-sequence-traverser delete-duplicates
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds
- sequence-arg start end)))
+ (end end)
+ :check-fill-pointer t)
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
(vector-search sequence2 sequence1)
(apply #'sb!sequence:search sequence1 sequence2 args))))
-(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
- (let ((fun (gensym "STRING-DISPATCH-FUN-")))
- `(flet ((,fun (,var)
- ,@body))
- (declare (inline ,fun))
- (etypecase ,var
- ,@(loop for type in types
- collect `(,type (,fun (the ,type ,var))))))))
-
-;;; originally in array.lisp; probably best to put it back there and
-;;; make DOSEQUENCE and SEQ-DISPATCH be in early-seq.lisp.
+;;; FIXME: this was originally in array.lisp; it might be better to
+;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
+;;; a new early-seq.lisp file.
(defun fill-data-vector (vector dimensions initial-contents)
(let ((index 0))
(labels ((frob (axis dims contents)
axis (car dims) contents (length contents)))
(sb!sequence:dosequence (content contents)
(frob (1+ axis) (cdr dims) content))))))
- (frob 0 dimensions initial-contents))))
\ No newline at end of file
+ (frob 0 dimensions initial-contents))))