(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)
(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)
(in-package :seq-test)
+(defclass list-backed-sequence (standard-object
+ sequence)
+ ((elements :initarg :elements :type list :accessor %elements)))
+
+(defmethod sequence:make-sequence-like ((sequence list-backed-sequence) length
+ &rest args &key
+ initial-element initial-contents)
+ (declare (ignore initial-element initial-contents))
+ (make-instance 'list-backed-sequence
+ :elements (apply #'sequence:make-sequence-like
+ '() length args)))
+
+(defmethod sequence:length ((sequence list-backed-sequence))
+ (length (%elements sequence)))
+
+(defmethod sequence:elt
+ ((sequence list-backed-sequence) index)
+ (nth index (%elements sequence)))
+
+(defmethod (setf sequence:elt)
+ (new-value (sequence list-backed-sequence) index)
+ (setf (nth index (%elements sequence)) new-value))
+
;;; helper functions for exercising SEQUENCE code on data of many
;;; specialized types, and in many different optimization scenarios
(defun for-every-seq-1 (base-seq snippet)
- (dolist (seq-type '(list
- (simple-array t 1)
- (vector t)
- (simple-array character 1)
- (vector character)
- (simple-array (signed-byte 4) 1)
- (vector (signed-byte 4))))
- (flet ((entirely (eltype)
- (every (lambda (el) (typep el eltype)) base-seq)))
+ (labels
+ ((entirely (eltype)
+ (every (lambda (el) (typep el eltype)) base-seq))
+ (make-sequence-for-type (type)
+ (etypecase type
+ ((member list list-backed-sequence)
+ (coerce base-seq type))
+ ((cons (eql simple-array) (cons * (cons (eql 1) null)))
+ (destructuring-bind (eltype one) (rest type)
+ (when (entirely eltype)
+ (coerce base-seq type))))
+ ((cons (eql vector))
+ (destructuring-bind (eltype) (rest type)
+ (when (entirely eltype)
+ (let ((initial-element
+ (cond ((subtypep eltype 'character)
+ #\!)
+ ((subtypep eltype 'number)
+ 0)
+ (t #'error))))
+ (replace (make-array
+ (+ (length base-seq)
+ (random 3))
+ :element-type eltype
+ :fill-pointer
+ (length base-seq)
+ :initial-element
+ initial-element)
+ base-seq))))))))
+ (dolist (seq-type '(list
+ (simple-array t 1)
+ (vector t)
+ (simple-array character 1)
+ (vector character)
+ (simple-array (signed-byte 4) 1)
+ (vector (signed-byte 4))
+ list-backed-sequence))
(dolist (declaredness '(nil t))
(dolist (optimization '(((speed 3) (space 0))
((speed 2) (space 2))
((speed 1) (space 2))
((speed 0) (space 1))))
- (let* ((seq (if (eq seq-type 'list)
- (coerce base-seq 'list)
- (destructuring-bind (type-first &rest type-rest)
- seq-type
- (ecase type-first
- (simple-array
- (destructuring-bind (eltype one) type-rest
- (assert (= one 1))
- (if (entirely eltype)
- (coerce base-seq seq-type)
- (return))))
- (vector
- (destructuring-bind (eltype) type-rest
- (if (entirely eltype)
- (let ((initial-element
- (cond ((subtypep eltype 'character)
- #\!)
- ((subtypep eltype 'number)
- 0)
- (t #'error))))
- (replace (make-array
- (+ (length base-seq)
- (random 3))
- :element-type eltype
- :fill-pointer
- (length base-seq)
- :initial-element
- initial-element)
- base-seq))
- (return))))))))
- (lambda-expr `(lambda (seq)
- ,@(when declaredness
- `((declare (type ,seq-type seq))))
- (declare (optimize ,@optimization))
- ,snippet)))
+ (let ((seq (make-sequence-for-type seq-type))
+ (lambda-expr `(lambda (seq)
+ ,@(when declaredness
+ `((declare (type ,seq-type seq))))
+ (declare (optimize ,@optimization))
+ ,snippet)))
+ (when (not seq)
+ (return))
(format t "~&~S~%" lambda-expr)
(multiple-value-bind (fun warnings-p failure-p)
(compile nil lambda-expr)
projects / sbcl.git / commitdiff