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@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) ,@forms0) (progn ,@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 ,@args) + ,',notter))) + ,@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]