(error 'sequence::protocol-unimplemented
:datum sequence :expected-type '(or list vector)))
+(defgeneric sequence:emptyp (sequence)
+ (:method ((s list)) (null s))
+ (:method ((s vector)) (zerop (length s)))
+ (:method ((s sequence)) (zerop (length s)))
+ #+sb-doc
+ (:documentation
+ "Returns T if SEQUENCE is an empty sequence and NIL
+ otherwise. Signals an error if SEQUENCE is not a sequence."))
+
(defgeneric sequence:length (sequence)
(:method ((s list)) (length s))
(:method ((s vector)) (length s))
- (:method ((s sequence)) (sequence::protocol-unimplemented s)))
+ (:method ((s sequence)) (sequence::protocol-unimplemented s))
+ #+sb-doc
+ (:documentation
+ "Returns the length of SEQUENCE or signals a PROTOCOL-UNIMPLEMENTED
+ error if the sequence protocol is not implemented for the class of
+ SEQUENCE."))
(defgeneric sequence:elt (sequence index)
(:method ((s list) index) (elt s index))
(:method ((s vector) index) (elt s index))
- (:method ((s sequence) index) (sequence::protocol-unimplemented s)))
+ (:method ((s sequence) index) (sequence::protocol-unimplemented s))
+ #+sb-doc
+ (:documentation
+ "Returns the element at position INDEX of SEQUENCE or signals a
+ PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
+ implemented for the class of SEQUENCE."))
(defgeneric (setf sequence:elt) (new-value sequence index)
(:argument-precedence-order sequence new-value index)
(:method (new-value (s list) index) (setf (elt s index) new-value))
(:method (new-value (s vector) index) (setf (elt s index) new-value))
(:method (new-value (s sequence) index)
- (sequence::protocol-unimplemented s)))
+ (sequence::protocol-unimplemented s))
+ #+sb-doc
+ (:documentation
+ "Replaces the element at position INDEX of SEQUENCE with NEW-VALUE
+ and returns NEW-VALUE or signals a PROTOCOL-UNIMPLEMENTED error if
+ the sequence protocol is not implemented for the class of
+ SEQUENCE."))
(defgeneric sequence:make-sequence-like
(sequence length &key initial-element initial-contents)
(t (make-array length :element-type (array-element-type s)))))
(:method ((s sequence) length &key initial-element initial-contents)
(declare (ignore initial-element initial-contents))
- (sequence::protocol-unimplemented s)))
+ (sequence::protocol-unimplemented s))
+ #+sb-doc
+ (:documentation
+ "Returns a freshly allocated sequence of length LENGTH and of the
+ same class as SEQUENCE. Elements of the new sequence are
+ initialized to INITIAL-ELEMENT, if supplied, initialized to
+ INITIAL-CONTENTS if supplied, or identical to the elements of
+ SEQUENCE if neither is supplied. Signals a PROTOCOL-UNIMPLEMENTED
+ error if the sequence protocol is not implemented for the class of
+ SEQUENCE."))
(defgeneric sequence:adjust-sequence
(sequence length &key initial-element initial-contents)
(t (apply #'adjust-array s length args))))
(:method (new-value (s sequence) &rest args)
(declare (ignore args))
- (sequence::protocol-unimplemented s)))
+ (sequence::protocol-unimplemented s))
+ #+sb-doc
+ (:documentation
+ "Return destructively modified SEQUENCE or a freshly allocated
+ sequence of the same class as SEQUENCE of length LENGTH. Elements
+ of the returned sequence are initialized to INITIAL-ELEMENT, if
+ supplied, initialized to INITIAL-CONTENTS if supplied, or identical
+ to the elements of SEQUENCE if neither is supplied. Signals a
+ PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
+ implemented for the class of SEQUENCE."))
+
\f
;;;; iterator protocol
(values iterator limit from-end
#'sequence:iterator-step #'sequence:iterator-endp
#'sequence:iterator-element #'(setf sequence:iterator-element)
- #'sequence:iterator-index #'sequence:iterator-copy))))
+ #'sequence:iterator-index #'sequence:iterator-copy)))
+ (:method ((s t) &key from-end start end)
+ (declare (ignore from-end start end))
+ (error 'type-error
+ :datum s
+ :expected-type 'sequence))
+ #+sb-doc
+ (:documentation
+ "Returns a sequence iterator for SEQUENCE or, if START and/or END
+ are supplied, the subsequence bounded by START and END as nine
+ values:
+
+ 1. iterator state
+ 2. limit
+ 3. from-end
+ 4. step function
+ 5. endp function
+ 6. element function
+ 7. setf element function
+ 8. index function
+ 9. copy state function
+
+ If FROM-END is NIL, the constructed iterator visits the specified
+ elements in the order in which they appear in SEQUENCE. Otherwise,
+ the elements are visited in the opposite order."))
;;; the simple protocol: the simple iterator returns three values,
;;; STATE, LIMIT and FROM-END.
(let ((end (or end (length s))))
(if from-end
(values (1- end) (1- start) from-end)
- (values start end nil)))))
+ (values start end nil))))
+ #+sb-doc
+ (:documentation
+ "Returns a sequence iterator for SEQUENCE, START, END and FROM-END
+ as three values:
+
+ 1. iterator state
+ 2. limit
+ 3. from-end
+
+ The returned iterator can be used with the generic iterator
+ functions ITERATOR-STEP, ITERATOR-ENDP, ITERATOR-ELEMENT, (SETF
+ ITERATOR-ELEMENT), ITERATOR-INDEX and ITERATOR-COPY."))
(defgeneric sequence:iterator-step (sequence iterator from-end)
(:method ((s list) iterator from-end)
(:method ((s sequence) iterator from-end)
(if from-end
(1- iterator)
- (1+ iterator))))
+ (1+ iterator)))
+ #+sb-doc
+ (:documentation
+ "Moves ITERATOR one position forward or backward in SEQUENCE
+ depending on the iteration direction encoded in FROM-END."))
(defgeneric sequence:iterator-endp (sequence iterator limit from-end)
(:method ((s list) iterator limit from-end)
(:method ((s vector) iterator limit from-end)
(= iterator limit))
(:method ((s sequence) iterator limit from-end)
- (= iterator limit)))
+ (= iterator limit))
+ #+sb-doc
+ (:documentation
+ "Returns non-NIL when ITERATOR has reached LIMIT (which may
+ correspond to the end of SEQUENCE) with respect to the iteration
+ direction encoded in FROM-END."))
(defgeneric sequence:iterator-element (sequence iterator)
(:method ((s list) iterator)
(:method ((s vector) iterator)
(aref s iterator))
(:method ((s sequence) iterator)
- (elt s iterator)))
+ (elt s iterator))
+ #+sb-doc
+ (:documentation
+ "Returns the element of SEQUENCE associated to the position of
+ ITERATOR."))
(defgeneric (setf sequence:iterator-element) (new-value sequence iterator)
(:method (o (s list) iterator)
(:method (o (s vector) iterator)
(setf (aref s iterator) o))
(:method (o (s sequence) iterator)
- (setf (elt s iterator) o)))
+ (setf (elt s iterator) o))
+ #+sb-doc
+ (:documentation
+ "Destructively modifies SEQUENCE by replacing the sequence element
+ associated to position of ITERATOR with NEW-VALUE."))
(defgeneric sequence:iterator-index (sequence iterator)
(:method ((s list) iterator)
;; Apple implementation in Dylan...)
(loop for l on s for i from 0 when (eq l iterator) return i))
(:method ((s vector) iterator) iterator)
- (:method ((s sequence) iterator) iterator))
+ (:method ((s sequence) iterator) iterator)
+ #+sb-doc
+ (:documentation
+ "Returns the position of ITERATOR in SEQUENCE."))
(defgeneric sequence:iterator-copy (sequence iterator)
(:method ((s list) iterator) iterator)
(:method ((s vector) iterator) iterator)
- (:method ((s sequence) iterator) iterator))
+ (:method ((s sequence) iterator) iterator)
+ #+sb-doc
+ (:documentation
+ "Returns a copy of ITERATOR which also traverses SEQUENCE but can
+ be mutated independently of ITERATOR."))
(defmacro sequence:with-sequence-iterator
- ((&rest vars) (s &rest args &key from-end start end) &body body)
+ ((&rest vars) (sequence &rest args &key from-end start end) &body body)
+ #+sb-doc
+ "Executes BODY with the elements of VARS bound to the iteration
+ state returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE and
+ ARGS. Elements of VARS may be NIL in which case the corresponding
+ value returned by MAKE-SEQUENCE-ITERATOR is ignored."
(declare (ignore from-end start end))
- `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,s ,@args)
- (declare (type function ,@(nthcdr 3 vars)))
- ,@body))
+ (let* ((ignored '())
+ (vars (mapcar (lambda (x)
+ (or x (let ((name (gensym)))
+ (push name ignored)
+ name)))
+ vars)))
+ `(multiple-value-bind (,@vars) (sequence:make-sequence-iterator ,sequence ,@args)
+ (declare (type function ,@(nthcdr 3 vars))
+ (ignore ,@ignored))
+ ,@body)))
(defmacro sequence:with-sequence-iterator-functions
((step endp elt setf index copy)
- (s &rest args &key from-end start end)
+ (sequence &rest args &key from-end start end)
&body body)
+ #+sb-doc
+ "Executes BODY with the names STEP, ENDP, ELT, SETF, INDEX and COPY
+ bound to local functions which execute the iteration state query and
+ mutation functions returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE
+ and ARGS. STEP, ENDP, ELT, SETF, INDEX and COPY have dynamic
+ extent."
(declare (ignore from-end start end))
(let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
(nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
(ncopy (gensym "COPY")))
`(sequence:with-sequence-iterator
(,nstate ,nlimit ,nfrom-end ,nstep ,nendp ,nelt ,nsetf ,nindex ,ncopy)
- (,s ,@args)
- (flet ((,step () (setq ,nstate (funcall ,nstep ,s ,nstate ,nfrom-end)))
- (,endp () (funcall ,nendp ,s ,nstate ,nlimit ,nfrom-end))
- (,elt () (funcall ,nelt ,s ,nstate))
- (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate))
- (,index () (funcall ,nindex ,s ,nstate))
- (,copy () (funcall ,ncopy ,s ,nstate)))
+ (,sequence,@args)
+ (flet ((,step () (setq ,nstate (funcall ,nstep ,sequence,nstate ,nfrom-end)))
+ (,endp () (funcall ,nendp ,sequence,nstate ,nlimit ,nfrom-end))
+ (,elt () (funcall ,nelt ,sequence,nstate))
+ (,setf (new-value) (funcall ,nsetf new-value ,sequence,nstate))
+ (,index () (funcall ,nindex ,sequence,nstate))
+ (,copy () (funcall ,ncopy ,sequence,nstate)))
(declare (truly-dynamic-extent #',step #',endp #',elt
#',setf #',index #',copy))
,@body))))
(defmethod sequence:search
((sequence1 sequence) (sequence2 sequence) &key from-end (start1 0) end1
(start2 0) end2 test test-not key)
- (let ((test (sequence:canonize-test test test-not))
- (key (sequence:canonize-key key))
- (mainend2 (- (or end2 (length sequence2))
- (- (or end1 (length sequence1)) start1))))
- (when (< mainend2 0)
+ (let* ((test (sequence:canonize-test test test-not))
+ (key (sequence:canonize-key key))
+ (range1 (- (or end1 (length sequence1)) start1))
+ (range2 (- (or end2 (length sequence2)) start2))
+ (count (1+ (- range2 range1))))
+ (when (minusp count)
(return-from sequence:search nil))
- (sequence:with-sequence-iterator (statem limitm from-endm stepm endpm)
- (sequence2 :start start2 :end mainend2 :from-end from-end)
- (do ((s2 (if from-end mainend2 0) (if from-end (1- s2) (1+ s2))))
- (nil)
- (sequence:with-sequence-iterator (state1 limit1 from-end1 step1 endp1 elt1)
- (sequence1 :start start1 :end end1)
- (sequence:with-sequence-iterator (state2 limit2 from-end2 step2 endp2 elt2)
- (sequence2 :start s2)
- (declare (ignore limit2 endp2))
- (when (do ()
- ((funcall endp1 sequence1 state1 limit1 from-end1) t)
- (let ((o1 (funcall key (funcall elt1 sequence1 state1)))
- (o2 (funcall key (funcall elt2 sequence2 state2))))
- (unless (funcall test o1 o2)
- (return nil)))
- (setq state1 (funcall step1 sequence1 state1 from-end1))
- (setq state2 (funcall step2 sequence2 state2 from-end2)))
- (return-from sequence:search s2))))
- (when (funcall endpm sequence2 statem limitm from-endm)
- (return nil))
- (setq statem (funcall stepm sequence2 statem from-endm))))))
+ ;; Create an iteration state for SEQUENCE1 for the interesting
+ ;;range within SEQUENCE1. To compare this range against ranges in
+ ;;SEQUENCE2, we copy START-STATE1 and then mutate the copy.
+ (sequence:with-sequence-iterator (start-state1 nil from-end1 step1 nil elt1)
+ (sequence1 :start start1 :end end1 :from-end from-end)
+ ;; Create an iteration state for the interesting range within
+ ;; SEQUENCE2.
+ (sequence:with-sequence-iterator (start-state2 nil from-end2 step2 nil elt2 nil index2)
+ (sequence2 :start start2 :end end2 :from-end from-end)
+ ;; Copy both iterators at all COUNT possible match positions.
+ (dotimes (i count)
+ (let ((state1 (sequence:iterator-copy sequence1 start-state1))
+ (state2 (sequence:iterator-copy sequence2 start-state2)))
+ ;; Determine whether there is a match at the current
+ ;; position. Return immediately, if there is a match.
+ (dotimes
+ (j range1
+ (return-from sequence:search
+ (let ((position (funcall index2 sequence2 start-state2)))
+ (if from-end (- position range1 -1) position))))
+ (unless (funcall test
+ (funcall key (funcall elt1 sequence1 state1))
+ (funcall key (funcall elt2 sequence2 state2)))
+ (return nil))
+ (setq state1 (funcall step1 sequence1 state1 from-end1))
+ (setq state2 (funcall step2 sequence2 state2 from-end2))))
+ (setq start-state2 (funcall step2 sequence2 start-state2 from-end2)))))))
(defgeneric sequence:delete
(item sequence &key from-end test test-not start end count key)
projects / sbcl.git / blobdiff