X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=02563f6b5f7669813272f583c1de2d4bf55242e1;hb=f578dd10fa6d9a8d7c3d15d3100406976f6a273c;hp=9b076962c9413bbf8406cb59631bff2485fd4c1c;hpb=8a3bbf707f43fd95bc3025e3f222563c36b599fd;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 9b07696..02563f6 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -23,91 +23,91 @@ 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)) -;;; These functions perform basic list operations: -(defun car (list) #!+sb-doc "Returns the 1st object in a list." (car list)) +;;; These functions perform basic list operations. +(defun car (list) #!+sb-doc "Return the 1st object in a list." (car list)) (defun cdr (list) - #!+sb-doc "Returns all but the first object in a list." + #!+sb-doc "Return all but the first object in a list." (cdr list)) -(defun cadr (list) #!+sb-doc "Returns the 2nd object in a list." (cadr list)) -(defun cdar (list) #!+sb-doc "Returns the cdr of the 1st sublist." (cdar list)) -(defun caar (list) #!+sb-doc "Returns the car of the 1st sublist." (caar list)) +(defun cadr (list) #!+sb-doc "Return the 2nd object in a list." (cadr list)) +(defun cdar (list) #!+sb-doc "Return the cdr of the 1st sublist." (cdar list)) +(defun caar (list) #!+sb-doc "Return the car of the 1st sublist." (caar list)) (defun cddr (list) - #!+sb-doc "Returns all but the 1st two objects of a list." + #!+sb-doc "Return all but the 1st two objects of a list." (cddr list)) (defun caddr (list) - #!+sb-doc "Returns the 1st object in the cddr of a list." + #!+sb-doc "Return the 1st object in the cddr of a list." (caddr list)) (defun caadr (list) - #!+sb-doc "Returns the 1st object in the cadr of a list." + #!+sb-doc "Return the 1st object in the cadr of a list." (caadr list)) (defun caaar (list) - #!+sb-doc "Returns the 1st object in the caar of a list." + #!+sb-doc "Return the 1st object in the caar of a list." (caaar list)) (defun cdaar (list) - #!+sb-doc "Returns the cdr of the caar of a list." + #!+sb-doc "Return the cdr of the caar of a list." (cdaar list)) (defun cddar (list) - #!+sb-doc "Returns the cdr of the cdar of a list." + #!+sb-doc "Return the cdr of the cdar of a list." (cddar list)) (defun cdddr (list) - #!+sb-doc "Returns the cdr of the cddr of a list." + #!+sb-doc "Return the cdr of the cddr of a list." (cdddr list)) (defun cadar (list) - #!+sb-doc "Returns the car of the cdar of a list." + #!+sb-doc "Return the car of the cdar of a list." (cadar list)) (defun cdadr (list) - #!+sb-doc "Returns the cdr of the cadr of a list." + #!+sb-doc "Return the cdr of the cadr of a list." (cdadr list)) (defun caaaar (list) - #!+sb-doc "Returns the car of the caaar of a list." + #!+sb-doc "Return the car of the caaar of a list." (caaaar list)) (defun caaadr (list) - #!+sb-doc "Returns the car of the caadr of a list." + #!+sb-doc "Return the car of the caadr of a list." (caaadr list)) (defun caaddr (list) - #!+sb-doc "Returns the car of the caddr of a list." + #!+sb-doc "Return the car of the caddr of a list." (caaddr list)) (defun cadddr (list) - #!+sb-doc "Returns the car of the cdddr of a list." + #!+sb-doc "Return the car of the cdddr of a list." (cadddr list)) (defun cddddr (list) - #!+sb-doc "Returns the cdr of the cdddr of a list." + #!+sb-doc "Return the cdr of the cdddr of a list." (cddddr list)) (defun cdaaar (list) - #!+sb-doc "Returns the cdr of the caaar of a list." + #!+sb-doc "Return the cdr of the caaar of a list." (cdaaar list)) (defun cddaar (list) - #!+sb-doc "Returns the cdr of the cdaar of a list." + #!+sb-doc "Return the cdr of the cdaar of a list." (cddaar list)) (defun cdddar (list) - #!+sb-doc "Returns the cdr of the cddar of a list." + #!+sb-doc "Return the cdr of the cddar of a list." (cdddar list)) (defun caadar (list) - #!+sb-doc "Returns the car of the cadar of a list." + #!+sb-doc "Return the car of the cadar of a list." (caadar list)) (defun cadaar (list) - #!+sb-doc "Returns the car of the cdaar of a list." + #!+sb-doc "Return the car of the cdaar of a list." (cadaar list)) (defun cadadr (list) - #!+sb-doc "Returns the car of the cdadr of a list." + #!+sb-doc "Return the car of the cdadr of a list." (cadadr list)) (defun caddar (list) - #!+sb-doc "Returns the car of the cddar of a list." + #!+sb-doc "Return the car of the cddar of a list." (caddar list)) (defun cdaadr (list) - #!+sb-doc "Returns the cdr of the caadr of a list." + #!+sb-doc "Return the cdr of the caadr of a list." (cdaadr list)) (defun cdadar (list) - #!+sb-doc "Returns the cdr of the cadar of a list." + #!+sb-doc "Return the cdr of the cadar of a list." (cdadar list)) (defun cdaddr (list) - #!+sb-doc "Returns the cdr of the caddr of a list." + #!+sb-doc "Return the cdr of the caddr of a list." (cdaddr list)) (defun cddadr (list) - #!+sb-doc "Returns the cdr of the cdadr of a list." + #!+sb-doc "Return the cdr of the cdadr of a list." (cddadr list)) (defun cons (se1 se2) - #!+sb-doc "Returns a list with se1 as the car and se2 as the cdr." + #!+sb-doc "Return a list with SE1 as the CAR and SE2 as the CDR." (cons se1 se2)) (declaim (maybe-inline tree-equal-test tree-equal-test-not)) @@ -132,20 +132,21 @@ (defun tree-equal (x y &key (test #'eql) test-not) #!+sb-doc - "Returns T if X and Y are isomorphic trees with identical leaves." + "Return T if X and Y are isomorphic trees with identical leaves." (if test-not (tree-equal-test-not x y test-not) (tree-equal-test x y test))) (defun endp (object) #!+sb-doc - "The recommended way to test for the end of a list. True if Object is nil, - false if Object is a cons, and an error for any other types of arguments." + "This is the recommended way to test for the end of a proper list. It + returns true if OBJECT is NIL, false if OBJECT is a CONS, and an error + for any other type of OBJECT." (endp object)) (defun list-length (list) #!+sb-doc - "Returns the length of the given List, or Nil if the List is circular." + "Return the length of the given List, or Nil if the List is circular." (do ((n 0 (+ n 2)) (y list (cddr y)) (z list (cdr z))) @@ -157,47 +158,47 @@ (defun nth (n list) #!+sb-doc - "Returns the nth object in a list where the car is the zero-th element." + "Return the nth object in a list where the car is the zero-th element." (car (nthcdr n list))) (defun first (list) #!+sb-doc - "Returns the 1st object in a list or NIL if the list is empty." + "Return the 1st object in a list or NIL if the list is empty." (car list)) (defun second (list) - "Returns the 2nd object in a list or NIL if there is no 2nd object." + "Return the 2nd object in a list or NIL if there is no 2nd object." (cadr list)) (defun third (list) #!+sb-doc - "Returns the 3rd object in a list or NIL if there is no 3rd object." + "Return the 3rd object in a list or NIL if there is no 3rd object." (caddr list)) (defun fourth (list) #!+sb-doc - "Returns the 4th object in a list or NIL if there is no 4th object." + "Return the 4th object in a list or NIL if there is no 4th object." (cadddr list)) (defun fifth (list) #!+sb-doc - "Returns the 5th object in a list or NIL if there is no 5th object." + "Return the 5th object in a list or NIL if there is no 5th object." (car (cddddr list))) (defun sixth (list) #!+sb-doc - "Returns the 6th object in a list or NIL if there is no 6th object." + "Return the 6th object in a list or NIL if there is no 6th object." (cadr (cddddr list))) (defun seventh (list) #!+sb-doc - "Returns the 7th object in a list or NIL if there is no 7th object." + "Return the 7th object in a list or NIL if there is no 7th object." (caddr (cddddr list))) (defun eighth (list) #!+sb-doc - "Returns the 8th object in a list or NIL if there is no 8th object." + "Return the 8th object in a list or NIL if there is no 8th object." (cadddr (cddddr list))) (defun ninth (list) #!+sb-doc - "Returns the 9th object in a list or NIL if there is no 9th object." + "Return the 9th object in a list or NIL if there is no 9th object." (car (cddddr (cddddr list)))) (defun tenth (list) #!+sb-doc - "Returns the 10th object in a list or NIL if there is no 10th object." + "Return the 10th object in a list or NIL if there is no 10th object." (cadr (cddddr (cddddr list)))) (defun rest (list) #!+sb-doc @@ -215,7 +216,7 @@ (defun last (list &optional (n 1)) #!+sb-doc - "Returns the last N conses (not the last element!) of a list." + "Return the last N conses (not the last element!) of a list." (declare (type index n)) (do ((checked-list list (cdr checked-list)) (returned-list list) @@ -227,7 +228,7 @@ (defun list (&rest args) #!+sb-doc - "Returns constructs and returns a list of its arguments." + "Return constructs and returns a list of its arguments." args) ;;; List* is done the same as list, except that the last cons is made a @@ -235,7 +236,7 @@ (defun list* (arg &rest others) #!+sb-doc - "Returns a list of the arguments with last cons a dotted pair" + "Return a list of the arguments with last cons a dotted pair" (cond ((atom others) arg) ((atom (cdr others)) (cons arg (car others))) (t (do ((x others (cdr x))) @@ -258,40 +259,44 @@ (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (do ((top lists (cdr top))) ;;Cdr to first non-null list. - ((atom top) '()) - (cond ((null (car top))) ; Nil -> Keep looping - ((not (consp (car top))) ; Non cons - (if (cdr top) - (error "~S is not a list." (car top)) - (return (car top)))) - (t ; Start appending - (return - (if (atom (cdr top)) - (car top) ;;Special case. - (let* ((result (cons (caar top) '())) - (splice result)) - (do ((x (cdar top) (cdr x))) ;;Copy first list - ((atom x)) - (setq splice - (cdr (rplacd splice (cons (car x) ()) ))) ) - (do ((y (cdr top) (cdr y))) ;;Copy rest of lists. - ((atom (cdr y)) - (setq splice (rplacd splice (car y))) - result) - (if (listp (car y)) - (do ((x (car y) (cdr x))) ;;Inner copy loop. - ((atom x)) - (setq - splice - (cdr (rplacd splice (cons (car x) ()))))) - (error "~S is not a list." (car y))))))))))) + (flet ((fail (object) + (error 'type-error + :datum object + :expected-type 'list))) + (do ((top lists (cdr top))) ; CDR to first non-null list. + ((atom top) '()) + (cond ((null (car top))) ; NIL -> Keep looping + ((not (consp (car top))) ; Non CONS + (if (cdr top) + (fail (car top)) + (return (car top)))) + (t ; Start appending + (return + (if (atom (cdr top)) + (car top) ; Special case. + (let* ((result (cons (caar top) '())) + (splice result)) + (do ((x (cdar top) (cdr x))) ; Copy first list + ((atom x)) + (setq splice + (cdr (rplacd splice (cons (car x) ()) ))) ) + (do ((y (cdr top) (cdr y))) ; Copy rest of lists. + ((atom (cdr y)) + (setq splice (rplacd splice (car y))) + result) + (if (listp (car y)) + (do ((x (car y) (cdr x))) ; Inner copy loop. + ((atom x)) + (setq + splice + (cdr (rplacd splice (cons (car x) ()))))) + (fail (car y)))))))))))) ;;; list copying functions (defun copy-list (list) #!+sb-doc - "Returns a new list which is EQUAL to LIST." + "Return a new list which is EQUAL to LIST." ;; The list is copied correctly even if the list is not terminated ;; by NIL. The new list is built by CDR'ing SPLICE which is always ;; at the tail of the new list. @@ -308,7 +313,7 @@ (defun copy-alist (alist) #!+sb-doc - "Returns a new association list which is EQUAL to ALIST." + "Return a new association list which is EQUAL to ALIST." (if (atom alist) alist (let ((result @@ -341,7 +346,7 @@ (defun revappend (x y) #!+sb-doc - "Returns (append (reverse x) y)" + "Return (append (reverse x) y)." (do ((top x (cdr top)) (result y (cons (car top) result))) ((endp top) result))) @@ -360,38 +365,42 @@ (defun nconc (&rest lists) #!+sb-doc "Concatenates the lists given as arguments (by changing them)" - (do ((top lists (cdr top))) - ((null top) nil) - (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 - (if (cdr top) - (error "Argument is not a list -- ~S." top-of-top) - (return top-of-top))) - (t (error "Argument is not a list -- ~S." top-of-top)))))) + (flet ((fail (object) + (error 'type-error + :datum object + :expected-type 'list))) + (do ((top lists (cdr top))) + ((null top) nil) + (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) + (fail ele) + (rplacd (last splice) ele))) + (t (fail ele))))) + (return result))) + (null) + (atom + (if (cdr top) + (fail top-of-top) + (return top-of-top))) + (t (fail top-of-top))))))) (defun nreconc (x y) #!+sb-doc - "Returns (nconc (nreverse x) y)" + "Return (NCONC (NREVERSE X) Y)." (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) - (2nd x 1st) ;2nd follows first down the list. - (3rd y 2nd)) ;3rd follows 2nd down the list. + (2nd x 1st) ;2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. ((atom 2nd) 3rd) (rplacd 2nd 3rd))) @@ -479,40 +488,12 @@ ;;;; :KEY arg optimization to save funcall of IDENTITY ;;; APPLY-KEY saves us a function call sometimes. -;;; This is not wrapped in an (EVAL-WHEN (COMPILE EVAL) ..) -;;; because this is used in seq.lisp and sort.lisp. +;;; This isn't wrapped in an (EVAL-WHEN (COMPILE EVAL) ..) +;;; because it's used in seq.lisp and sort.lisp. (defmacro apply-key (key element) `(if ,key (funcall ,key ,element) ,element)) - -(defun identity (thing) - #!+sb-doc - "This function simply returns what was passed to it." - thing) - -(defun complement (function) - #!+sb-doc - "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) - (not (cond (more-args (apply function arg0 arg1 arg2 more-args)) - (arg2-p (funcall function arg0 arg1 arg2)) - (arg1-p (funcall function arg0 arg1)) - (arg0-p (funcall function arg0)) - (t (funcall function)))))) - -(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)) @@ -676,8 +657,8 @@ (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." + "Return the tail of LIST beginning with first element satisfying EQLity, + :TEST, or :TEST-NOT with the given ITEM." (do ((list list (cdr list))) ((null list) nil) (let ((car (car list))) @@ -819,17 +800,28 @@ res)) (defun set-exclusive-or (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (test #'eql testp) (test-not nil notp)) #!+sb-doc "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) - (let ((result nil)) + (let ((result nil) + (key (when key (coerce key 'function))) + (test (coerce test 'function)) + (test-not (if test-not (coerce test-not 'function) #'eql))) + (declare (type (or function null) key) + (type function test test-not)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (setq result (cons elt result)))) - (dolist (elt list2) - (unless (with-set-keys (member (apply-key key elt) list1)) - (setq result (cons elt result)))) + (let ((test (if testp + (lambda (x y) (funcall test y x)) + test)) + (test-not (if notp + (lambda (x y) (funcall test-not y x)) + test-not))) + (dolist (elt list2) + (unless (with-set-keys (member (apply-key key elt) list1)) + (setq result (cons elt result))))) result)) ;;; The outer loop examines list1 while the inner loop examines list2. @@ -907,7 +899,7 @@ (defun assoc (item alist &key key test test-not) #!+sb-doc - "Returns the cons in ALIST whose car is equal (by a given test or EQL) to + "Return the cons in ALIST whose car is equal (by a given test or EQL) to the ITEM." ;; FIXME: Shouldn't there be a check for existence of both TEST and TEST-NOT? (cond (test @@ -926,7 +918,7 @@ (defun assoc-if (predicate alist &key key) #!+sb-doc - "Returns the first cons in alist whose car satisfies the Predicate. If + "Return the first cons in alist whose car satisfies the Predicate. If key is supplied, apply it to the car of each cons before testing." (if key (assoc-guts (funcall predicate (funcall key (caar alist)))) @@ -934,7 +926,7 @@ (defun assoc-if-not (predicate alist &key key) #!+sb-doc - "Returns the first cons in ALIST whose car does not satisfy the PREDICATE. + "Return 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))))) @@ -943,7 +935,7 @@ (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 + "Return the cons in ALIST whose cdr is equal (by a given test or EQL) to the ITEM." (cond (test (if key @@ -961,7 +953,7 @@ (defun rassoc-if (predicate alist &key key) #!+sb-doc - "Returns the first cons in alist whose cdr satisfies the Predicate. If key + "Return the first cons in alist whose cdr satisfies the Predicate. If key is supplied, apply it to the cdr of each cons before testing." (if key (assoc-guts (funcall predicate (funcall key (cdar alist)))) @@ -969,7 +961,7 @@ (defun rassoc-if-not (predicate alist &key key) #!+sb-doc - "Returns the first cons in alist whose cdr does not satisfy the Predicate. + "Return 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." (if key (assoc-guts (not (funcall predicate (funcall key (cdar alist)))))