[movitz-cvs] CVS movitz/losp/muerte
ffjeld
ffjeld at common-lisp.net
Mon Apr 21 19:28:46 UTC 2008
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv21673
Modified Files:
sequences.lisp
Log Message:
Handle :test-not args more consistently.
--- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/08 20:20:07 1.40
+++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2008/04/21 19:28:46 1.41
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Tue Sep 11 14:19:23 2001
;;;;
-;;;; $Id: sequences.lisp,v 1.40 2008/04/08 20:20:07 ffjeld Exp $
+;;;; $Id: sequences.lisp,v 1.41 2008/04/21 19:28:46 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -23,7 +23,7 @@
(or (typep x 'vector)
(typep x 'cons)))
-(defmacro sequence-dispatch (sequence-var (type0 &body forms0) (type1 &body forms1))
+(defmacro do-sequence-dispatch (sequence-var (type0 &body forms0) (type1 &body forms1))
(cond
((and (eq 'list type0) (eq 'vector type1))
`(if (typep ,sequence-var 'list)
@@ -35,9 +35,33 @@
(progn (check-type ,sequence-var vector)
, at forms0)
(progn , at forms1)))
- (t (error "sequence-dispatch only understands list and vector types, not ~W and ~W."
+ (t (error "do-sequence-dispatch only understands list and vector types, not ~W and ~W."
type0 type1))))
+(defmacro with-tester ((test test-not) &body body)
+ (let ((function (gensym "with-test-"))
+ (notter (gensym "with-test-notter-")))
+ `(multiple-value-bind (,function ,notter)
+ (progn ;; the (values function boolean)
+ (ensure-tester ,test ,test-not))
+ (macrolet ((,test (&rest args)
+ `(xor (funcall%unsafe ,',function , at args)
+ ,',notter)))
+ , at body))))
+
+(defun ensure-tester (test test-not)
+ (cond
+ (test-not
+ (when test
+ (error "Both test and test-not specified."))
+ (values (ensure-funcallable test-not)
+ t))
+ (test
+ (values (ensure-funcallable test)
+ nil))
+ (t (values #'eql
+ nil))))
+
(defun sequence-double-dispatch-error (seq0 seq1)
(error "The type-set (~A, ~A) has not been implemented in this sequence-double-dispatch."
(type-of seq0)
@@ -86,12 +110,12 @@
(declare (type index length))))
(defun elt (sequence index)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector (aref sequence index))
(list (nth index sequence))))
(defun (setf elt) (value sequence index)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector (setf (aref sequence index) value))
(list (setf (nth index sequence) value))))
@@ -101,7 +125,7 @@
(numargs-case
(2 (function sequence)
(with-funcallable (funcall-function function)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(list
(cond
((null sequence)
@@ -131,7 +155,7 @@
(let ((start (check-the index start)))
(with-funcallable (funcall-function function)
(with-funcallable (key)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(list
(let ((list (nthcdr start sequence)))
(cond
@@ -197,7 +221,7 @@
(declare (index index)))))))))))))))
(defun subseq (sequence start &optional end)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector
(unless end
(setf end (length sequence)))
@@ -236,10 +260,10 @@
(defun copy-seq (sequence)
(subseq sequence 0))
-(defun position (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity))
+(defun position (item sequence &key from-end test test-not (start 0) end (key 'identity))
(numargs-case
(2 (item sequence)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector
(with-subvector-accessor (sequence-ref sequence)
(do ((end (length sequence))
@@ -254,10 +278,10 @@
(declare (index i))
(when (eql (pop sequence) item)
(return i))))))
- (t (item sequence &key from-end (test #'eql) test-not (start 0) end (key 'identity))
+ (t (item sequence &key from-end test test-not (start 0) end (key 'identity))
(with-funcallable (key)
- (with-funcallable (test)
- (sequence-dispatch sequence
+ (with-tester (test test-not)
+ (do-sequence-dispatch sequence
(vector
(unless end
(setf end (length sequence)))
@@ -301,7 +325,7 @@
(numargs-case
(2 (predicate sequence)
(with-funcallable (predicate)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector
(with-subvector-accessor (sequence-ref sequence)
(do ((end (length sequence))
@@ -320,7 +344,7 @@
(t (predicate sequence &key (start 0) end (key 'identity) from-end)
(with-funcallable (predicate)
(with-funcallable (key)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(vector
(setf end (or end (length sequence)))
(with-subvector-accessor (sequence-ref sequence start end)
@@ -362,7 +386,7 @@
(apply #'position-if (complement predicate) sequence key-args))
(defun nreverse (sequence)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(list
(do ((prev-cons nil current-cons)
(next-cons (cdr sequence) (cdr next-cons))
@@ -381,7 +405,7 @@
sequence)))
(defun reverse (sequence)
- (sequence-dispatch sequence
+ (do-sequence-dispatch sequence
(list
(let ((result nil))
(dolist (x sequence)
@@ -391,11 +415,11 @@
(nreverse (copy-seq sequence)))))
(defun mismatch-eql-identity (sequence-1 sequence-2 start1 start2 end1 end2)
- (sequence-dispatch sequence-1
+ (do-sequence-dispatch sequence-1
(vector
(unless end1 (setf end1 (length sequence-1)))
(with-subvector-accessor (seq1-ref sequence-1 start1 end1)
- (sequence-dispatch sequence-2
+ (do-sequence-dispatch sequence-2
(vector
(unless end2 (setf end2 (length sequence-2)))
(with-subvector-accessor (seq2-ref sequence-2 start2 end2)
@@ -457,7 +481,7 @@
(unless (eql (seq1-ref i1) (car p2))
(return i1))))))))))
(list
- (sequence-dispatch sequence-2
+ (do-sequence-dispatch sequence-2
(vector
(let ((mismatch-2 (mismatch-eql-identity sequence-2 sequence-1 start2 start1 end2 end1)))
(if (not mismatch-2)
@@ -499,21 +523,21 @@
(t form)))
(defun mismatch (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2
- (test 'eql) (key 'identity) from-end)
+ test test-not (key 'identity) from-end)
(numargs-case
(2 (s1 s2)
(mismatch-eql-identity s1 s2 0 0 nil nil))
(t (sequence-1 sequence-2 &key (start1 0) (start2 0) end1 end2
- (test 'eql) (key 'identity) from-end)
+ test test-not (key 'identity) from-end)
(assert (not from-end) ()
- "Mismatch :from-end not implemented.")
- (with-funcallable (test)
+ "Mismatch :from-end not implemented.")
+ (with-tester (test test-not)
(with-funcallable (key)
- (sequence-dispatch sequence-1
+ (do-sequence-dispatch sequence-1
(vector
(unless end1 (setf end1 (length sequence-1)))
(with-subvector-accessor (sequence-1-ref sequence-1 start1 end1)
- (sequence-dispatch sequence-2
+ (do-sequence-dispatch sequence-2
(vector
(let ((end2 (check-the index (or end2 (length sequence-2)))))
(with-subvector-accessor (sequence-2-ref sequence-2 start2 end2)
@@ -524,88 +548,88 @@
(let ((length1 (- end1 start1))
(length2 (- end2 start2)))
(cond
- ((< length1 length2)
- (dotimes (i length1)
- (declare (index i))
- (test-return (+ start1 i) (+ start2 i)))
- end1)
- ((> length1 length2)
- (dotimes (i length2)
- (declare (index i))
- (test-return (+ start1 i) (+ start2 i)))
- (+ start1 length2))
- (t (dotimes (i length1)
- (declare (index i))
- (test-return (+ start1 i) (+ start2 i)))
- nil)))))))
+ ((< length1 length2)
+ (dotimes (i length1)
+ (declare (index i))
+ (test-return (+ start1 i) (+ start2 i)))
+ end1)
+ ((> length1 length2)
+ (dotimes (i length2)
+ (declare (index i))
+ (test-return (+ start1 i) (+ start2 i)))
+ (+ start1 length2))
+ (t (dotimes (i length1)
+ (declare (index i))
+ (test-return (+ start1 i) (+ start2 i)))
+ nil)))))))
(list
(let ((length1 (- end1 start1))
(start-cons2 (nthcdr start2 sequence-2)))
(cond
- ((and (zerop length1) (null start-cons2))
- (if (and end2 (> end2 start2)) start1 nil))
- ((not end2)
- (do ((i1 start1 (1+ i1))
- (p2 start-cons2 (cdr p2)))
- ((>= i1 end1) (if (null p2) nil i1))
- (declare (index i1))
- (unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2))))
- (return-from mismatch i1))))
- ((< length1 (- end2 start2))
- (do ((i1 start1 (1+ i1))
- (p2 start-cons2 (cdr p2)))
- ((>= i1 end1) end1)
- (declare (index i1))
- (unless (test (key (sequence-1-ref i1)) (key (car p2)))
- (return-from mismatch i1))))
- ((> length1 (- end2 start2))
- (do ((i1 start1 (1+ i1))
- (p2 start-cons2 (cdr p2)))
- ((null p2) end1)
- (declare (index i1))
- (unless (test (key (sequence-1-ref i1)) (key (car p2)))
- (return-from mismatch i1))))
- (t (do ((i1 start1 (1+ i1))
- (p2 start-cons2 (cdr p2)))
- ((null p2) nil)
- (declare (index i1))
- (unless (test (key (sequence-1-ref i1)) (key (car p2)))
- (return-from mismatch i1))))))))))
+ ((and (zerop length1) (null start-cons2))
+ (if (and end2 (> end2 start2)) start1 nil))
+ ((not end2)
+ (do ((i1 start1 (1+ i1))
+ (p2 start-cons2 (cdr p2)))
+ ((>= i1 end1) (if (null p2) nil i1))
+ (declare (index i1))
+ (unless (and p2 (test (key (sequence-1-ref i1)) (key (car p2))))
+ (return-from mismatch i1))))
+ ((< length1 (- end2 start2))
+ (do ((i1 start1 (1+ i1))
+ (p2 start-cons2 (cdr p2)))
+ ((>= i1 end1) end1)
+ (declare (index i1))
+ (unless (test (key (sequence-1-ref i1)) (key (car p2)))
+ (return-from mismatch i1))))
+ ((> length1 (- end2 start2))
+ (do ((i1 start1 (1+ i1))
+ (p2 start-cons2 (cdr p2)))
+ ((null p2) end1)
+ (declare (index i1))
+ (unless (test (key (sequence-1-ref i1)) (key (car p2)))
+ (return-from mismatch i1))))
+ (t (do ((i1 start1 (1+ i1))
+ (p2 start-cons2 (cdr p2)))
+ ((null p2) nil)
+ (declare (index i1))
+ (unless (test (key (sequence-1-ref i1)) (key (car p2)))
+ (return-from mismatch i1))))))))))
(list
- (sequence-dispatch sequence-2
+ (do-sequence-dispatch sequence-2
(vector
(let ((mismatch-2 (mismatch sequence-2 sequence-1 :from-end from-end :test test :key key
- :start1 start2 :end1 end2 :start2 start1 :end2 end1)))
+ :start1 start2 :end1 end2 :start2 start1 :end2 end1)))
(if (not mismatch-2)
nil
- (+ start1 (- mismatch-2 start2)))))
+ (+ start1 (- mismatch-2 start2)))))
(list
(let ((start-cons1 (nthcdr start1 sequence-1))
(start-cons2 (nthcdr start2 sequence-2)))
(assert (and start-cons1 start-cons2) (start1 start2) "Illegal bounding indexes.")
(cond
- ((and (not end1) (not end2))
- (do ((p1 start-cons1 (cdr p1))
- (p2 start-cons2 (cdr p2))
- (i1 start1 (1+ i1)))
- ((null p1) (if (null p2) nil i1))
- (declare (index i1))
- (unless (and p2 (test (key (car p1)) (key (car p2))))
- (return i1))))
- (t (do ((p1 start-cons1 (cdr p1))
- (p2 start-cons2 (cdr p2))
- (i1 start1 (1+ i1))
- (i2 start2 (1+ i2)))
- ((if end1 (>= i1 end1) (null p1))
- (if (if end2 (>= i2 end2) (null p2)) nil i1))
- (declare (index i1 i2))
- (unless p2
- (if end2
- (error "Illegal end2 bounding index.")
- (return i1)))
- (unless (and (or (not end2) (< i1 end2))
- (test (key (car p1)) (key (car p2))))
- (return i1)))))))))))))))
+ ((and (not end1) (not end2))
+ (do ((p1 start-cons1 (cdr p1))
+ (p2 start-cons2 (cdr p2))
+ (i1 start1 (1+ i1)))
+ ((null p1) (if (null p2) nil i1))
+ (declare (index i1))
+ (unless (and p2 (test (key (car p1)) (key (car p2))))
+ (return i1))))
+ (t (do ((p1 start-cons1 (cdr p1))
+ (p2 start-cons2 (cdr p2))
+ (i1 start1 (1+ i1))
+ (i2 start2 (1+ i2)))
+ ((if end1 (>= i1 end1) (null p1))
+ (if (if end2 (>= i2 end2) (null p2)) nil i1))
+ (declare (index i1 i2))
+ (unless p2
+ (if end2
+ (error "Illegal end2 bounding index.")
+ (return i1)))
+ (unless (and (or (not end2) (< i1 end2))
+ (test (key (car p1)) (key (car p2))))
+ (return i1)))))))))))))))
(defun map-into (result-sequence function first-sequence &rest more-sequences)
(declare (dynamic-extent more-sequences))
@@ -648,7 +672,7 @@
(numargs-case
(2 (function first-sequence)
(with-funcallable (mapf function)
- (sequence-dispatch first-sequence
+ (do-sequence-dispatch first-sequence
(list
(dolist (x first-sequence)
(mapf x)))
@@ -684,7 +708,7 @@
(numargs-case
(2 (function first-sequence)
(with-funcallable (mapf function)
- (sequence-dispatch first-sequence
+ (do-sequence-dispatch first-sequence
(list
(mapcar function first-sequence))
(vector
@@ -746,7 +770,7 @@
(numargs-case
(3 (result function first-sequence)
(with-funcallable (mapf function)
- (sequence-dispatch first-sequence
+ (do-sequence-dispatch first-sequence
(vector
(do ((i 0 (1+ i)))
((>= i (length result)) result)
@@ -820,7 +844,7 @@
(if (= start1 start2)
sequence-1 ; no need to copy anything
;; must copy in reverse direction
- (sequence-dispatch sequence-1
[430 lines skipped]
More information about the Movitz-cvs
mailing list