diff --git a/code/list.lisp b/code/list.lisp index d182b726fc5d11f5b924b5c6ddba7f30c381a071..11e987f5e5a17beb18c0155e529404e1979bcf41 100644 --- a/code/list.lisp +++ b/code/list.lisp @@ -36,6 +36,7 @@ assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not)) + (proclaim '(maybe-inline tree-equal list-length nth %setnth nthcdr last make-list append copy-list copy-alist copy-tree revappend nconc nreconc butlast @@ -291,35 +292,41 @@ (result y (cons (car top) result))) ((endp top) result))) -;;; NCONC finds the first non-null list, so it can make splice point -;;; to a cons. After finding the first cons element, it holds it in -;;; a result variable while running down successive elements tacking -;;; them together. While tacking lists together, if we encounter a -;;; null list, we set the previous list's last cdr to nil just in case -;;; it wasn't already nil, and it could have been dotted while the null -;;; list was the last argument to NCONC. The manipulation of splice (that -;;; is starting it out on a first cons, setting LAST of splice, and -;;; setting splice to ele) inherently handles (nconc x x), and it avoids -;;; running down the last argument to NCONC which allows the last argument -;;; to be circular. -;;; +;;; NCONC finds the first non-null list, so it can make splice point to a cons. +;;; After finding the first cons element, it holds it in a result variable +;;; while running down successive elements tacking them together. While +;;; tacking lists together, if we encounter a null list, we set the previous +;;; list's last cdr to nil just in case it wasn't already nil, and it could +;;; have been dotted while the null list was the last argument to NCONC. The +;;; manipulation of splice (that is starting it out on a first cons, setting +;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x), +;;; and it avoids running down the last argument to NCONC which allows the last +;;; argument to be circular. +;;; (defun nconc (&rest lists) "Concatenates the lists given as arguments (by changing them)" (do ((top lists (cdr top))) ((null top) nil) - (typecase (car top) - (cons - (let* ((result (car top)) - (splice result)) - (dolist (ele (cdr top)) - (typecase ele - (cons (rplacd (last splice) ele) - (setf splice ele)) - (null (rplacd (last splice) nil)) - (t (error "Argument is not a list -- ~S." ele)))) - (return result))) - (null) - (t (error "Argument is not a list -- ~S." (car top)))))) + (let ((top-of-top (car top))) + (typecase top-of-top + (cons + (let* ((result top-of-top) + (splice result)) + (do ((elements (cdr top) (cdr elements))) + ((endp elements)) + (let ((ele (car elements))) + (typecase ele + (cons (rplacd (last splice) ele) + (setf splice ele)) + (null (rplacd (last splice) nil)) + (atom (if (cdr elements) + (error "Argument is not a list -- ~S." ele) + (rplacd (last splice) ele))) + (t (error "Argument is not a list -- ~S." ele))))) + (return result))) + (null) + (atom (return top-of-top)) + (t (error "Argument is not a list -- ~S." top-of-top)))))) (defun nreconc (x y) "Returns (nconc (nreverse x) y)" @@ -553,7 +560,7 @@ (s tree)))) -;;; Functions for using lists as sets +;;;; Functions for using lists as sets (defun member (item list &key (key #'identity) (test #'eql testp) (test-not nil notp)) @@ -595,41 +602,48 @@ (member (funcall key item) list :test test :key key)) list (cons item list))) - -(defun union (list1 list2 &key (key #'identity) - (test #'eql testp) (test-not nil notp)) + + +;;; UNION -- Public. +;;; +;;; This function assumes list2 is the result, adding to it from list1 as +;;; necessary. List2 must initialize the result value, so the call to MEMBER +;;; will apply the test to the elements from list1 and list2 in the correct +;;; order. +;;; +(defun union (list1 list2 &key + (key #'identity) (test #'eql testp) (test-not nil notp)) "Returns the union of list1 and list2." - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res list1)) - (dolist (elt list2) - (if (not (with-set-keys (member (funcall key elt) list1))) - (push elt res))) + (when (and testp notp) (error "Test and test-not both supplied.")) + (let ((res list2)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (push elt res))) res)) -;;; Destination and source are setf-able and many-evaluable. -;;; Sets the source to the cdr, and "conses" the 1st elt of source to destination. +;;; Destination and source are setf-able and many-evaluable. Sets the source +;;; to the cdr, and "conses" the 1st elt of source to destination. +;;; (defmacro steve-splice (source destination) `(let ((temp ,source)) - (setf ,source (Cdr ,source) + (setf ,source (cdr ,source) (cdr temp) ,destination ,destination temp))) -(Defun nunion (list1 list2 &key (key #'identity) +(defun nunion (list1 list2 &key (key #'identity) (test #'eql testp) (test-not nil notp)) "Destructively returns the union list1 and list2." (if (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list1)) - (do () ((endp list2)) - (if (not (with-set-keys (member (funcall key (car list2)) list1))) - (steve-splice list2 res) - (Setq list2 (cdr list2)))) + (let ((res list2)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setf list1 (cdr list1)))) res)) - - (defun intersection (list1 list2 &key (key #'identity) (test #'eql testp) (test-not nil notp)) "Returns the intersection of list1 and list2." @@ -679,7 +693,7 @@ (setq list1 (cdr list1)))) res)) - + (defun set-exclusive-or (list1 list2 &key (key #'identity) (test #'eql testp) (test-not nil notp)) "Returns new list of elements appearing exactly once in list1 and list2." @@ -735,6 +749,28 @@ (return-from subsetp nil))) T) + + +;;;; :key arg optimization to save funcall of IDENTITY. + +;;; We should move this earlier in this file and make other functions use it as +;;; well. +;;; + +;;; APPLY-KEY saves us a function call sometimes. +;;; This is not in and (eval-when (compile eval) ... +;;; because this is used in seq.lisp and sort.lisp. +;;; +(defmacro apply-key (key element) + `(if ,key + (funcall ,key ,element) + ,element)) + +(defun identity (thing) + "Returns what was passed to it." + thing) + + ;;; Functions that operate on association lists @@ -751,47 +787,57 @@ (error "The lists of keys and data are of unequal length.")) (setq alist (acons (car x) (car y) alist)))) - ;;; In run-time environment, since these guys can be inline expanded. (defmacro assoc-guts (test-guy) `(do ((alist alist (cdr alist))) ((endp alist)) (if (car alist) (if ,test-guy (return (car alist)))))) +) ;eval-when -(defun assoc (item alist &key (key #'identity) test test-not) +(defun assoc (item alist &key key test test-not) "Returns the cons in alist whose car is equal (by a given test or EQL) to the Item." - (cond (test (assoc-guts (funcall test item (funcall key (caar alist))))) - (test-not (assoc-guts (not (funcall test-not item (funcall key (caar alist)))))) - (t (assoc-guts (eql item (funcall key (caar alist))))))) + (cond (test (assoc-guts (funcall test item (apply-key key (caar alist))))) + (test-not (assoc-guts (not (funcall test-not item + (apply-key key (caar alist)))))) + (t (assoc-guts (eql item (apply-key key (caar alist))))))) -(defun assoc-if (predicate alist) - "Returns the first cons in alist whose car satisfies the Predicate." - (assoc-guts (funcall predicate (caar alist)))) +(defun assoc-if (predicate alist &key key) + "Returns the first cons in alist whose car satisfies the Predicate. If + key is supplied, apply it to the car of each cons before testing." + (assoc-guts (funcall predicate (apply-key key (caar alist))))) -(defun assoc-if-not (predicate alist) - "Returns the first cons in alist whose car does not satisfy the Predicate." - (assoc-guts (not (funcall predicate (caar alist))))) +(defun assoc-if-not (predicate alist &key key) + "Returns the first cons in alist whose car does not satisfiy the Predicate. + If key is supplied, apply it to the car of each cons before testing." + (assoc-guts (not (funcall predicate (apply-key key (caar alist)))))) -(defun rassoc (item alist &key (key #'identity) test test-not) +(defun rassoc (item alist &key key test test-not) (declare (list alist)) "Returns the cons in alist whose cdr is equal (by a given test or EQL) to the Item." - (cond (test (assoc-guts (funcall test item (funcall key (cdar alist))))) - (test-not (assoc-guts (not (funcall test-not item (funcall key (cdar alist)))))) - (t (assoc-guts (eql item (funcall key (cdar alist))))))) + (cond (test (assoc-guts (funcall test item (apply-key key (cdar alist))))) + (test-not (assoc-guts (not (funcall test-not item + (apply-key key (cdar alist)))))) + (t (assoc-guts (eql item (apply-key key (cdar alist))))))) + +(defun rassoc-if (predicate alist &key key) + "Returns the first cons in alist whose cdr satisfies the Predicate. If key + is supplied, apply it to the cdr of each cons before testing." + (assoc-guts (funcall predicate (apply-key key (cdar alist))))) + +(defun rassoc-if-not (predicate alist &key key) + "Returns the first cons in alist whose cdr does not satisfy the Predicate. + If key is supplied, apply it to the cdr of each cons before testing." + (assoc-guts (not (funcall predicate (apply-key key (cdar alist)))))) -(defun rassoc-if (predicate alist) - "Returns the cons in alist whose cdr satisfies the Predicate." - (assoc-guts (funcall predicate (cdar alist)))) -(defun rassoc-if-not (predicate alist) - "Returns the first cons in alist whose cdr does not satisfy the Predicate." - (assoc-guts (not (funcall predicate (cdar alist))))) +;;;; Mapping functions. + (defun map1 (function original-arglists accumulate take-car) "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. It Maps function over the arglists in the appropriate way. It is done when any