diff --git a/code/list.lisp b/code/list.lisp index 3a4cd1d49f8002fbf0032218ae92323b26ae16da..fb53b824c0a28e0d5b6eef65510baf1e58f01b36 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.10 1992/01/27 10:56:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.11 1992/05/15 17:54:55 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -410,16 +410,17 @@ (defun %rplacd (x val) (rplacd x val) val) (defun %setnth (n list newval) - (declare (fixnum n)) + (declare (type index n)) "Sets the Nth element of List (zero based) to Newval." - (if (< n 0) - (error "~S is an illegal N for SETF of NTH." n) - (do ((count n (1- count))) - ((zerop count) (rplaca list newval) newval) - (declare (fixnum count)) - (if (endp (cdr list)) - (error "~S is too large an index for SETF of NTH." n) - (setq list (cdr list)))))) + (do ((count n (1- count)) + (list list (cdr list))) + ((endp list) + (error "~S is too large an index for SETF of NTH." n)) + (declare (fixnum count)) + (when (<= count 0) + (rplaca list newval) + (return newval)))) + ;;;; Macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)). ;;; Use these with the following keyword args: @@ -607,7 +608,7 @@ (do ((list list (cdr list))) ((endp list) ()) (if (not (funcall test (funcall key (car list)))) - (return list))))) + (return list)))) (defun tailp (sublist list) "Returns T if (EQL Sublist (NTHCDR <n> List)) for some value of <n>, NIL @@ -617,7 +618,8 @@ (if (eql sublist list) (return t)))) -(defun adjoin (item list &key (key #'identity) (test #'eql) (test-not nil notp)) +(defun adjoin (item list &key (key #'identity) (test #'eql) + (test-not nil notp)) "Add item to list unless it is already a member" (declare (inline member)) (if (if notp (member (funcall key item) list :test-not test-not :key key) @@ -659,7 +661,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2)) + (let ((res list2) + (list1 list1)) (do () ((endp list1)) (if (not (with-set-keys (member (funcall key (car list1)) list2))) @@ -686,7 +689,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil)) + (let ((res nil) + (list1 list1)) (do () ((endp list1)) (if (with-set-keys (member (funcall key (car list1)) list2)) (steve-splice list1 res) @@ -714,7 +718,8 @@ (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res nil)) + (let ((res nil) + (list1 list1)) (do () ((endp list1)) (if (not (with-set-keys (member (funcall key (car list1)) list2))) (steve-splice list1 res) @@ -747,7 +752,9 @@ (key #'identity)) "Destructively return a list with elements which appear but once in list1 and list2." - (do ((x list1 (cdr x)) + (do ((list1 list1) + (list2 list2) + (x list1 (cdr x)) (splicex ())) ((endp x) (if (null splicex) @@ -768,7 +775,7 @@ (setq list2 (cdr y)) (rplacd splicey (cdr y))) (return ())) ; assume lists are really sets - (t (setq splicey y))))))) + (t (setq splicey y)))))) (defun subsetp (list1 list2 &key (key #'identity) (test #'eql testp) (test-not nil notp)) diff --git a/code/seq.lisp b/code/seq.lisp index 4da6e5deb18d5cb371cc582c9dbef6521d99a247..82e857dbacbcb3ad21ccd89c63691b1165b6c02d 100644 --- a/code/seq.lisp +++ b/code/seq.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.10 1991/10/01 16:12:59 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/seq.lisp,v 1.11 1992/05/15 17:56:15 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -99,12 +99,12 @@ "Returns the element of SEQUENCE specified by INDEX." (etypecase sequence (list - (do ((count index (1- count))) - ((= count 0) (car sequence)) + (do ((count index (1- count)) + (list list (cdr list))) + ((= count 0) (car list)) (declare (fixnum count)) - (if (atom sequence) - (error "~S: index too large." index) - (setq sequence (cdr sequence))))) + (when (endp list) + (error "~S: index too large." index)))) (vector (when (>= index (length sequence)) (error "~S: index too large." index)) @@ -411,15 +411,15 @@ ((:end2 source-end))) "The target sequence is destructively modified by copying successive elements into it from the source sequence." - (unless target-end (setq target-end (length target-sequence))) - (unless source-end (setq source-end (length source-sequence))) - (seq-dispatch target-sequence - (seq-dispatch source-sequence - (list-replace-from-list) - (list-replace-from-mumble)) - (seq-dispatch source-sequence - (mumble-replace-from-list) - (mumble-replace-from-mumble)))) + (let ((target-end (or target-end (length target-sequence))) + (source-end (or source-end (length source-sequence)))) + (seq-dispatch target-sequence + (seq-dispatch source-sequence + (list-replace-from-list) + (list-replace-from-mumble)) + (seq-dispatch source-sequence + (mumble-replace-from-list) + (mumble-replace-from-mumble))))) ;;; Reverse: @@ -747,26 +747,30 @@ end (initial-value nil ivp)) "The specified Sequence is ``reduced'' using the given Function. See manual for details." - (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (cond ((= (the fixnum end) start) - (if ivp initial-value (funcall function))) - ((listp sequence) - (if from-end - (list-reduce-from-end function sequence key start end - initial-value ivp) - (list-reduce function sequence key start end initial-value ivp))) - (from-end - (when (not ivp) - (setq end (1- (the fixnum end))) - (setq initial-value (apply-key key (aref sequence end)))) - (mumble-reduce-from-end function sequence key start end - initial-value aref)) - (t - (when (not ivp) - (setq initial-value (apply-key key (aref sequence start))) - (setq start (1+ start))) - (mumble-reduce function sequence key start end initial-value aref)))) + (declare (type index start)) + (let ((start start) + (end (or end (length sequence)))) + (declare (type index start end)) + (cond ((= end start) + (if ivp initial-value (funcall function))) + ((listp sequence) + (if from-end + (list-reduce-from-end function sequence key start end + initial-value ivp) + (list-reduce function sequence key start end + initial-value ivp))) + (from-end + (when (not ivp) + (setq end (1- (the fixnum end))) + (setq initial-value (apply-key key (aref sequence end)))) + (mumble-reduce-from-end function sequence key start end + initial-value aref)) + (t + (when (not ivp) + (setq initial-value (apply-key key (aref sequence start))) + (setq start (1+ start))) + (mumble-reduce function sequence key start end + initial-value aref))))) ;;; Coerce: @@ -1024,9 +1028,9 @@ "Returns a sequence formed by destructively removing the specified Item from the given Sequence." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length ))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (normal-list-delete-from-end) @@ -1060,9 +1064,9 @@ "Returns a sequence formed by destructively removing the elements satisfying the specified Predicate from the given Sequence." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (if-list-delete-from-end) @@ -1096,9 +1100,9 @@ "Returns a sequence formed by destructively removing the elements not satisfying the specified Predicate from the given Sequence." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (if-not-list-delete-from-end) @@ -1172,7 +1176,9 @@ ;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies ;;; the predicate. (defmacro list-remove-macro (pred reverse?) - `(let* (,@(if reverse? '((sequence (reverse (the list sequence))))) + `(let* ((sequence ,(if reverse? + '(reverse (the list sequence)) + 'sequence)) (splice (list nil)) (results (do ((index 0 (1+ index)) (before-start splice)) @@ -1238,9 +1244,9 @@ "Returns a copy of SEQUENCE with elements satisfying the test (default is EQL) with ITEM removed." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (normal-list-remove-from-end) @@ -1254,9 +1260,9 @@ "Returns a copy of sequence with elements such that predicate(element) is non-null are removed" (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (if-list-remove-from-end) @@ -1271,9 +1277,9 @@ "Returns a copy of sequence with elements such that predicate(element) is null are removed" (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or length end))) + (declare (type index length end)) (seq-dispatch sequence (if from-end (if-not-list-remove-from-end) @@ -1544,9 +1550,9 @@ except that all elements equal to Old are replaced with New. See manual for details." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence))) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length))) + (declare (type index length end)) (subst-dispatch 'normal))) @@ -1558,11 +1564,11 @@ except that all elements satisfying the Test are replaced with New. See manual for details." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence)) - test-not - old) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length)) + test-not + old) + (declare (type index length end)) (subst-dispatch 'if))) @@ -1574,11 +1580,11 @@ except that all elements not satisfying the Test are replaced with New. See manual for details." (declare (fixnum start count)) - (when (null end) (setf end (length sequence))) - (let ((length (length sequence)) - test-not - old) - (declare (fixnum length)) + (let* ((length (length sequence)) + (end (or end length)) + test-not + old) + (declare (type index length end)) (subst-dispatch 'if-not))) @@ -1591,19 +1597,19 @@ except that all elements equal to Old are replaced with New. The Sequence may be destroyed. See manual for details." (declare (fixnum count start)) - (when (null end) (setf end (length sequence))) - (if (listp sequence) - (if from-end - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not start end count key)) - (nlist-substitute* new old sequence - test test-not start end count key)) - (if from-end - (nvector-substitute* new old sequence -1 - test test-not (1- end) (1- start) count key) - (nvector-substitute* new old sequence 1 - test test-not start end count key)))) + (let ((end (or end (length sequence)))) + (if (listp sequence) + (if from-end + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not start end count key)) + (nlist-substitute* new old sequence + test test-not start end count key)) + (if from-end + (nvector-substitute* new old sequence -1 + test test-not (1- end) (1- start) count key) + (nvector-substitute* new old sequence 1 + test test-not start end count key))))) (defun nlist-substitute* (new old sequence test test-not start end count key) (declare (fixnum start count end)) @@ -1879,10 +1885,11 @@ (defun position-if (test sequence &key from-end (start 0) key end) "Returns the zero-origin index of the first element satisfying test(el)" (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-position-if test sequence) - (vector-position-if test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-position-if test sequence) + (vector-position-if test sequence)))) ;;; Position-if-not: @@ -1900,10 +1907,11 @@ (defun position-if-not (test sequence &key from-end (start 0) key end) "Returns the zero-origin index of the first element not satisfying test(el)" (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-position-if-not test sequence) - (vector-position-if-not test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-position-if-not test sequence) + (vector-position-if-not test sequence)))) ;;; Find: @@ -1960,10 +1968,11 @@ (defun find-if (test sequence &key from-end (start 0) end key) "Returns the zero-origin index of the first element satisfying the test." (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-find-if test sequence) - (vector-find-if test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-find-if test sequence) + (vector-find-if test sequence)))) ;;; Find-if-not: @@ -1981,10 +1990,11 @@ (defun find-if-not (test sequence &key from-end (start 0) end key) "Returns the zero-origin index of the first element not satisfying the test." (declare (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-find-if-not test sequence) - (vector-find-if-not test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-find-if-not test sequence) + (vector-find-if-not test sequence)))) ;;; Count: @@ -2021,10 +2031,11 @@ "Returns the number of elements in SEQUENCE satisfying a test with ITEM, which defaults to EQL." (declare (ignore from-end) (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-count item sequence) - (vector-count item sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-count item sequence) + (vector-count item sequence)))) ;;; Count-if: @@ -2053,10 +2064,11 @@ (defun count-if (test sequence &key from-end (start 0) end key) "Returns the number of elements in SEQUENCE satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-count-if test sequence) - (vector-count-if test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-count-if test sequence) + (vector-count-if test sequence)))) ;;; Count-if-not: @@ -2085,10 +2097,11 @@ (defun count-if-not (test sequence &key from-end (start 0) end key) "Returns the number of elements in SEQUENCE not satisfying TEST(el)." (declare (ignore from-end) (fixnum start)) - (when (null end) (setf end (length sequence))) - (seq-dispatch sequence - (list-count-if-not test sequence) - (vector-count-if-not test sequence))) + (let ((end (or end (length sequence)))) + (declare (type index end)) + (seq-dispatch sequence + (list-count-if-not test sequence) + (vector-count-if-not test sequence)))) ;;; Mismatch utilities: @@ -2106,6 +2119,7 @@ ,@body)) (defmacro matchify-list (sequence start length end) + (declare (ignore end)) ;; ### Should END be used below? `(setq ,sequence (if from-end (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1) @@ -2155,7 +2169,9 @@ (if-mismatch (pop sequence1) (aref sequence2 index2)))) (defmacro list-list-mismatch () - `(do ((index1 start1 (+ index1 (the fixnum inc))) + `(do ((sequence1 sequence1) + (sequence2 sequence2) + (index1 start1 (+ index1 (the fixnum inc))) (index2 start2 (+ index2 (the fixnum inc)))) (()) (declare (fixnum index1 index2)) @@ -2174,11 +2190,11 @@ keyword argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) - (when (null end1) (setf end1 (length sequence1))) - (when (null end2) (setf end2 (length sequence2))) - (let ((length1 (length sequence1)) - (length2 (length sequence2))) - (declare (fixnum length1 length2)) + (let* ((length1 (length sequence1)) + (end1 (or end1 length1)) + (length2 (length sequence2)) + (end2 (or end2 length2))) + (declare (type index length1 end1 length2 end2)) (match-vars (seq-dispatch sequence1 (progn (matchify-list sequence1 start1 length1 end1) @@ -2289,8 +2305,8 @@ sequence2, the index of the its leftmost element is returned; otherwise () is returned." (declare (fixnum start1 start2)) - (when (null end1) (setf end1 (length sequence1))) - (when (null end2) (setf end2 (length sequence2))) - (seq-dispatch sequence2 - (list-search sequence2 sequence1) - (vector-search sequence2 sequence1))) + (let ((end1 (or end1 (length sequence1))) + (end2 (or end2 (length sequence2)))) + (seq-dispatch sequence2 + (list-search sequence2 sequence1) + (vector-search sequence2 sequence1))))