X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fsequence.lisp;h=f3a0cae95ec78e100988137da6cf76f845229fcf;hb=b83353d9f998e5c0e34604b5593df70c66d2c510;hp=46f3f850770907a91c4d80f496d6adf406d26b94;hpb=6822034325136cde4e14773c83c3769b42721306;p=sbcl.git

diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp
index 46f3f85..f3a0cae 100644
--- a/src/pcl/sequence.lisp
+++ b/src/pcl/sequence.lisp
@@ -17,22 +17,47 @@
   (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)
@@ -58,7 +83,16 @@
       (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)
@@ -90,7 +124,17 @@
       (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."))
+
 
 ;;;; iterator protocol
 
@@ -104,7 +148,31 @@
       (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.
@@ -134,7 +202,19 @@
     (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)
@@ -151,7 +231,11 @@
   (: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)
@@ -159,7 +243,12 @@
   (: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)
@@ -167,7 +256,11 @@
   (: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)
@@ -175,7 +268,11 @@
   (: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)
@@ -183,24 +280,49 @@
     ;; 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"))
@@ -209,13 +331,13 @@
         (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))))
@@ -620,33 +742,40 @@
 (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)