X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=55f66c9f3302904abdc725cccf30b28677c0e95f;hb=416152f084604094445a758ff399871132dff2bd;hp=c3812dc5a877d0a1fbcd155f481779221d6db02e;hpb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index c3812dc..55f66c9 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -16,11 +16,10 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal list-length nth %setnth nthcdr last make-list append - copy-list copy-alist copy-tree revappend nconc nreconc butlast - nbutlast ldiff member member-if member-if-not tailp adjoin union + tree-equal nth %setnth nthcdr last make-list append + nconc member member-if member-if-not tailp adjoin union nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc + set-exclusive-or nset-exclusive-or subsetp acons assoc assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) @@ -427,9 +426,9 @@ list)))) (defun ldiff (list object) - "Returns a new list, whose elements are those of List that appear before - Object. If Object is not a tail of List, a copy of List is returned. - List must be a proper list or a dotted list." + "Return a new list, whose elements are those of LIST that appear before + OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. + LIST must be a proper list or a dotted list." (do* ((list list (cdr list)) (result (list ())) (splice result)) @@ -445,12 +444,12 @@ (defun rplaca (x y) #!+sb-doc - "Changes the car of x to y and returns the new x." + "Change the CAR of X to Y and return the new X." (rplaca x y)) (defun rplacd (x y) #!+sb-doc - "Changes the cdr of x to y and returns the new x." + "Change the CDR of X to Y and return the new X." (rplacd x y)) ;;; The following are for use by SETF. @@ -459,10 +458,9 @@ (defun %rplacd (x val) (rplacd x val) val) +;;; Set the Nth element of LIST to NEWVAL. (defun %setnth (n list newval) (declare (type index n)) - #!+sb-doc - "Sets the Nth element of List (zero based) to Newval." (do ((count n (1- count)) (list list (cdr list))) ((endp list) @@ -484,12 +482,12 @@ (defun identity (thing) #!+sb-doc - "Returns what was passed to it." + "This function simply returns what was passed to it." thing) (defun complement (function) #!+sb-doc - "Builds a new function that returns T whenever FUNCTION returns NIL and + "Return a new function that returns T whenever FUNCTION returns NIL and NIL whenever FUNCTION returns non-NIL." (lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p) &rest more-args) @@ -499,33 +497,22 @@ (arg0-p (funcall function arg0)) (t (funcall function)))))) -(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p) - &rest more-values) - #!+sb-doc - "Builds a function that always returns VALUE, and possibly MORE-VALUES." - (cond (more-values - (let ((list (list* value val1 val2 more-values))) - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values-list list)))) - (val2-p - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values value val1 val2))) - (val1-p - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values value val1))) - (t - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - value)))) +(defun constantly (value) + #!+sb-doc + "Return a function that always returns VALUE." + (lambda () + ;; KLUDGE: This declaration is a hack to make the closure ignore + ;; all its arguments without consing a &REST list or anything. + ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to + ;; screw around with this kind of thing. -- WHN 2001-04-06 + (declare (optimize (speed 3) (safety 0))) + value)) ;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP)) -;;; Use these with the following keyword args: +;;; Use these with the following &KEY args: (defmacro with-set-keys (funcall) - `(cond ((and testp notp) (error "Test and test-not both supplied.")) + `(cond ((and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) (notp ,(append funcall '(:key key :test-not test-not))) (t ,(append funcall '(:key key :test test))))) @@ -684,7 +671,7 @@ (defun member (item list &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Returns tail of list beginning with first element satisfying EQLity, - :test, or :test-not with a given item." + :TEST, or :TEST-NOT with a given item." (do ((list list (cdr list))) ((null list) nil) (let ((car (car list))) @@ -693,7 +680,7 @@ (defun member-if (test list &key key) #!+sb-doc - "Returns tail of list beginning with first element satisfying test(element)" + "Return tail of LIST beginning with first element satisfying TEST." (do ((list list (Cdr list))) ((endp list) nil) (if (funcall test (apply-key key (car list))) @@ -701,7 +688,7 @@ (defun member-if-not (test list &key key) #!+sb-doc - "Returns tail of list beginning with first element not satisfying test(el)" + "Return tail of LIST beginning with first element not satisfying TEST." (do ((list list (cdr list))) ((endp list) ()) (if (not (funcall test (apply-key key (car list)))) @@ -709,8 +696,8 @@ (defun tailp (object list) #!+sb-doc - "Returns true if Object is the same as some tail of List, otherwise - returns false. List must be a proper list or a dotted list." + "Return true if OBJECT is the same as some tail of LIST, otherwise + returns false. LIST must be a proper list or a dotted list." (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) @@ -718,7 +705,7 @@ (defun adjoin (item list &key key (test #'eql) (test-not nil notp)) #!+sb-doc - "Add item to list unless it is already a member" + "Add ITEM to LIST unless it is already a member" (declare (inline member)) (if (let ((key-val (apply-key key item))) (if notp @@ -733,7 +720,7 @@ ;;; order. (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the union of list1 and list2." + "Return the union of LIST1 and LIST2." (declare (inline member)) (when (and testp notp) (error "Test and test-not both supplied.")) (let ((res list2)) @@ -742,8 +729,8 @@ (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. Set the +;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION. ;;; ;;; FIXME: needs a more mnemonic name (defmacro steve-splice (source destination) @@ -754,10 +741,10 @@ (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the union list1 and list2." + "Destructively return the union of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) - (error "Test and test-not both supplied.")) + (error ":TEST and :TEST-NOT were both supplied.")) (let ((res list2) (list1 list1)) (do () @@ -770,7 +757,7 @@ (defun intersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the intersection of list1 and list2." + "Return the intersection of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -783,7 +770,7 @@ (defun nintersection (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the intersection of list1 and list2." + "Destructively return the intersection of LIST1 and LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -798,7 +785,7 @@ (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns the elements of list1 which are not in list2." + "Return the elements of LIST1 which are not in LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -813,7 +800,7 @@ (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Destructively returns the elements of list1 which are not in list2." + "Destructively return the elements of LIST1 which are not in LIST2." (declare (inline member)) (if (and testp notp) (error "Test and test-not both supplied.")) @@ -828,7 +815,7 @@ (defun set-exclusive-or (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns new list of elements appearing exactly once in list1 and list2." + "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) (let ((result nil)) (dolist (elt list1) @@ -839,18 +826,17 @@ (setq result (cons elt result)))) result)) -;;; The outer loop examines list1 while the inner loop examines list2. If an -;;; element is found in list2 "equal" to the element in list1, both are -;;; spliced out. When the end of list1 is reached, what is left of list2 is -;;; tacked onto what is left of list1. The splicing operation ensures that -;;; the correct operation is performed depending on whether splice is at the -;;; top of the list or not - +;;; The outer loop examines list1 while the inner loop examines list2. +;;; If an element is found in list2 "equal" to the element in list1, +;;; both are spliced out. When the end of list1 is reached, what is +;;; left of list2 is tacked onto what is left of list1. The splicing +;;; operation ensures that the correct operation is performed +;;; depending on whether splice is at the top of the list or not (defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) key) #!+sb-doc - "Destructively return a list with elements which appear but once in list1 - and list2." + "Destructively return a list with elements which appear but once in LIST1 + and LIST2." (do ((list1 list1) (list2 list2) (x list1 (cdr x)) @@ -879,7 +865,7 @@ (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc - "Returns T if every element in list1 is also in list2." + "Return T if every element in LIST1 is also in LIST2." (declare (inline member)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) @@ -890,12 +876,12 @@ (defun acons (key datum alist) #!+sb-doc - "Construct a new alist by adding the pair (key . datum) to alist" + "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." (cons (cons key datum) alist)) (defun pairlis (keys data &optional (alist '())) #!+sb-doc - "Construct an association list from keys and data (adding to alist)" + "Construct an association list from KEYS and DATA (adding to ALIST)." (do ((x keys (cdr x)) (y data (cdr y))) ((and (endp x) (endp y)) alist) @@ -942,8 +928,8 @@ (defun assoc-if-not (predicate alist &key key) #!+sb-doc - "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." + "Returns the first cons in ALIST whose car does not satisfy the PREDICATE. + If KEY is supplied, apply it to the car of each cons before testing." (if key (assoc-guts (not (funcall predicate (funcall key (caar alist))))) (assoc-guts (not (funcall predicate (caar alist)))))) @@ -951,8 +937,8 @@ (defun rassoc (item alist &key key test test-not) (declare (list alist)) #!+sb-doc - "Returns the cons in alist whose cdr is equal (by a given test or EQL) to - the Item." + "Returns the cons in ALIST whose cdr is equal (by a given test or EQL) to + the ITEM." (cond (test (if key (assoc-guts (funcall test item (funcall key (cdar alist))))