X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fsequence.lisp;h=89912adc2e32340bacae482b73a44b723869f8ba;hb=22c592cbf7e81e78ceaef80d1c15ad7a7fc3b40a;hp=200705faa2cdfa89af0cd49223af58c50f66acd0;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp index 200705f..89912ad 100644 --- a/src/pcl/sequence.lisp +++ b/src/pcl/sequence.lisp @@ -17,6 +17,11 @@ (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)))) + (defgeneric sequence:length (sequence) (:method ((s list)) (length s)) (:method ((s vector)) (length s)) @@ -104,7 +109,12 @@ (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))) ;;; the simple protocol: the simple iterator returns three values, ;;; STATE, LIMIT and FROM-END. @@ -193,9 +203,16 @@ (defmacro sequence:with-sequence-iterator ((&rest vars) (s &rest args &key from-end start end) &body body) (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 ,s ,@args) + (declare (type function ,@(nthcdr 3 vars)) + (ignore ,@ignored)) + ,@body))) (defmacro sequence:with-sequence-iterator-functions ((step endp elt setf index copy) @@ -216,7 +233,7 @@ (,setf (new-value) (funcall ,nsetf new-value ,s ,nstate)) (,index () (funcall ,nindex ,s ,nstate)) (,copy () (funcall ,ncopy ,s ,nstate))) - (declare (dynamic-extent #',step #',endp #',elt + (declare (truly-dynamic-extent #',step #',endp #',elt #',setf #',index #',copy)) ,@body)))) @@ -479,7 +496,7 @@ (:argument-precedence-order sequence new old)) (defmethod sequence:substitute (new old (sequence sequence) &rest args &key (start 0) end from-end test test-not count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end test test-not count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute new old result args))) @@ -489,7 +506,7 @@ (:argument-precedence-order sequence new predicate)) (defmethod sequence:substitute-if (new predicate (sequence sequence) &rest args &key (start 0) end from-end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute-if new predicate result args))) @@ -500,7 +517,7 @@ (defmethod sequence:substitute-if-not (new predicate (sequence sequence) &rest args &key (start 0) end from-end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore start end from-end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:nsubstitute-if-not new predicate result args))) @@ -620,33 +637,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) @@ -670,7 +694,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -710,7 +734,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -750,7 +774,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do () ((funcall endp2 sequence state2 limit2 from-end2) (finish)) (let ((e (funcall elt2 sequence state2))) @@ -774,7 +798,7 @@ (:argument-precedence-order sequence item)) (defmethod sequence:remove (item (sequence sequence) &rest args &key from-end test test-not (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end test test-not start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete item result args))) @@ -784,7 +808,7 @@ (:argument-precedence-order sequence predicate)) (defmethod sequence:remove-if (predicate (sequence sequence) &rest args &key from-end (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-if predicate result args))) @@ -794,7 +818,7 @@ (:argument-precedence-order sequence predicate)) (defmethod sequence:remove-if-not (predicate (sequence sequence) &rest args &key from-end (start 0) end count key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end start end count key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-if-not predicate result args))) @@ -820,7 +844,7 @@ (replace sequence sequence :start2 end :start1 (- end c) :end1 (- (length sequence) c)))) (sequence:adjust-sequence sequence (- (length sequence) c)))) - (declare (dynamic-extent #'finish)) + (declare (truly-dynamic-extent #'finish)) (do ((end (or end (length sequence))) (step 0 (1+ step))) ((funcall endp2 sequence state2 limit2 from-end2) (finish)) @@ -849,14 +873,14 @@ (sequence &key from-end test test-not start end key)) (defmethod sequence:remove-duplicates ((sequence sequence) &rest args &key from-end test test-not (start 0) end key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore from-end test test-not start end key)) (let ((result (copy-seq sequence))) (apply #'sequence:delete-duplicates result args))) (defgeneric sequence:sort (sequence predicate &key key)) (defmethod sequence:sort ((sequence sequence) predicate &rest args &key key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore key)) (let* ((length (length sequence)) (vector (make-array length))) @@ -879,7 +903,7 @@ (defgeneric sequence:stable-sort (sequence predicate &key key)) (defmethod sequence:stable-sort ((sequence sequence) predicate &rest args &key key) - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (declare (ignore key)) (let* ((length (length sequence)) (vector (make-array length)))