X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=045e1de04f9ffefbaf4314477983506d5cd0f4ac;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=5f968065fab9194fc70adce94fea8a29ae430993;hpb=8bb34dad31b73a7bd4ca17b1630f4f5bdc94f347;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 5f96806..045e1de 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,10 +18,10 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal nth %setnth nthcdr last last1 make-list append - nconc nconc2 member member-if member-if-not tailp adjoin union + tree-equal nth %setnth nthcdr make-list + member-if member-if-not tailp union nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons assoc + set-exclusive-or nset-exclusive-or subsetp acons 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)) @@ -230,28 +230,85 @@ (fast-nthcdr (mod n i) r-i)) (declare (type index i))))))) -(defun last1 (list) - #!+sb-doc - "Return the last cons (not the last element) of a list" - (let ((rest list) - (list list)) - (loop (unless (consp rest) (return list)) - (shiftf list rest (cdr rest))))) - -(defun last (list &optional (n 1)) - #!+sb-doc - "Return the last N conses (not the last element!) of a list." - (if (eql n 1) - (last1 list) - (if (typep n 'index) - (do ((checked-list list (cdr checked-list)) - (returned-list list) - (index 0 (1+ index))) - ((atom checked-list) returned-list) - (declare (type index index)) - (if (>= index n) - (pop returned-list))) - list))) +;;; LAST +;;; +;;; Transforms in src/compiler/srctran.lisp pick the most specific +;;; version possible. %LAST/BIGNUM is admittedly somewhat academic... +(macrolet ((last0-macro () + `(let ((rest list) + (list list)) + (loop (unless (consp rest) + (return rest)) + (shiftf list rest (cdr rest))))) + (last1-macro () + `(let ((rest list) + (list list)) + (loop (unless (consp rest) + (return list)) + (shiftf list rest (cdr rest))))) + (lastn-macro (type) + `(let ((returned-list list) + (checked-list list) + (n (truly-the ,type n))) + (declare (,type n)) + (tagbody + :scan + (pop checked-list) + (when (atom checked-list) + (go :done)) + (if (zerop (truly-the ,type (decf n))) + (go :pop) + (go :scan)) + :pop + (pop returned-list) + (pop checked-list) + (if (atom checked-list) + (go :done) + (go :pop)) + :done) + returned-list))) + + (defun %last0 (list) + (declare (optimize speed (sb!c::verify-arg-count 0))) + (last0-macro)) + + (defun %last1 (list) + (declare (optimize speed (sb!c::verify-arg-count 0))) + (last1-macro)) + + (defun %lastn/fixnum (list n) + (declare (optimize speed (sb!c::verify-arg-count 0)) + (type (and unsigned-byte fixnum) n)) + (case n + (1 (last1-macro)) + (0 (last0-macro)) + (t (lastn-macro fixnum)))) + + (defun %lastn/bignum (list n) + (declare (optimize speed (sb!c::verify-arg-count 0)) + (type (and unsigned-byte bignum) n)) + (lastn-macro unsigned-byte)) + + (defun last (list &optional (n 1)) + #!+sb-doc + "Return the last N conses (not the last element!) of a list." + (case n + (1 (last1-macro)) + (0 (last0-macro)) + (t + (typecase n + (fixnum + (lastn-macro fixnum)) + (bignum + (lastn-macro unsigned-byte))))))) + +(define-compiler-macro last (&whole form list &optional (n 1) &environment env) + (if (sb!xc:constantp n env) + (case (constant-form-value n env) + (0 `(%last0 ,list)) + (1 `(%last1 ,list)) + (t form)) + form)) (defun list (&rest args) #!+sb-doc @@ -282,52 +339,84 @@ (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" + (declare (dynamic-extent lists) (optimize speed)) (labels ((fail (object) (error 'type-error :datum object :expected-type 'list)) (append-into (last-cons current rest) - "Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST)." + ;; Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST). (declare (cons last-cons rest)) - (cond ((consp current) - (append-into (setf (cdr last-cons) (list (car current))) - (cdr current) - rest)) - ((not (null current)) (fail current)) - ((null (cdr rest)) (setf (cdr last-cons) (car rest))) - (t (append-into last-cons (car rest) (cdr rest))))) + (if (listp current) + (if (consp current) + ;; normal case, cdr down the list + (append-into (setf (cdr last-cons) (list (car current))) + (cdr current) + rest) + ;; empty list + (let ((more (cdr rest))) + (if (null more) + (setf (cdr last-cons) (car rest)) + (append-into last-cons (car rest) more)))) + (fail current))) (append1 (lists) (let ((current (car lists)) (rest (cdr lists))) - (cond ((null rest) current) + (cond ((null rest) + current) ((consp current) (let ((result (truly-the cons (list (car current))))) (append-into result - (cdr current) - rest) + (cdr current) + rest) result)) - ((null current) (append1 rest)) - (t (fail current)))))) + ((null current) + (append1 rest)) + (t + (fail current)))))) (append1 lists))) + +(defun append2 (x y) + (declare (optimize speed (sb!c::verify-arg-count 0))) + (if (null x) + y + (let ((result (list (car x)))) + (do ((more (cdr x) (cdr more)) + (tail result (cdr tail))) + ((null more) + (rplacd tail y) + result) + (rplacd tail (list (car more))))))) + +(define-compiler-macro append (&whole form &rest lists) + (case (length lists) + (0 nil) + (1 (car lists)) + (2 `(append2 ,@lists)) + (t form))) ;;;; list copying functions +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!xc:defmacro !copy-list-macro (list &key check-proper-list) + ;; Unless CHECK-PROPER-LIST is true, 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. + `(when ,list + (let ((copy (list (car ,list)))) + (do ((orig (cdr ,list) (cdr orig)) + (splice copy (cdr (rplacd splice (cons (car orig) nil))))) + (,@(if check-proper-list + '((endp orig)) + '((atom orig) + (unless (null orig) + (rplacd splice orig)))) + copy)))))) + (defun copy-list (list) #!+sb-doc - "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. - (if (atom list) - list - (let ((result (list (car list)))) - (do ((x (cdr list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '()))))) - ((atom x) - (unless (null x) - (rplacd splice x)))) - result))) + "Return a new list which is EQUAL to LIST. LIST may be improper." + (!copy-list-macro list)) (defun copy-alist (alist) #!+sb-doc @@ -378,47 +467,36 @@ ;;; and it avoids running down the last argument to NCONC which allows ;;; the last argument to be circular. (defun nconc (&rest lists) - #!+sb-doc - "Concatenates the lists given as arguments (by changing them)" - (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 nconc2 (x y) - (if (null x) y - (let ((z x) - (rest (cdr x))) - (loop - (unless (consp rest) - (rplacd z y) - (return x)) - (shiftf z rest (cdr rest)))))) + #!+sb-doc + "Concatenates the lists given as arguments (by changing them)" + (declare (dynamic-extent lists) (optimize speed)) + (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)))))) + (return result))) + (null) + (atom + (if (cdr top) + (fail top-of-top) + (return top-of-top)))))))) (defun nreconc (x y) #!+sb-doc @@ -486,15 +564,15 @@ ;;;; functions to alter list structure -(defun rplaca (x y) +(defun rplaca (cons x) #!+sb-doc - "Change the CAR of X to Y and return the new X." - (rplaca x y)) + "Change the CAR of CONS to X and return the CONS." + (rplaca cons x)) -(defun rplacd (x y) +(defun rplacd (cons x) #!+sb-doc - "Change the CDR of X to Y and return the new X." - (rplacd x y)) + "Change the CDR of CONS to X and return the CONS." + (rplacd cons x)) ;;; The following are for use by SETF. @@ -772,7 +850,6 @@ (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) (let ((key (and key (%coerce-callable-to-fun key)))) - (declare (inline member)) (if (let ((key-val (apply-key key item))) (if notp (member key-val list :test-not test-not :key key) @@ -796,7 +873,7 @@ (key (and key (%coerce-callable-to-fun key))) (test (if notp (let ((test-not-fun (%coerce-callable-to-fun test-not))) - (lambda (x) (not (funcall test-not-fun x)))) + (lambda (x y) (not (funcall test-not-fun x y)))) (%coerce-callable-to-fun test)))) (multiple-value-bind (short long n-short) (if (< n1 n2) @@ -845,7 +922,7 @@ (key (and key (%coerce-callable-to-fun key))) (test (if notp (let ((test-not-fun (%coerce-callable-to-fun test-not))) - (lambda (x) (not (funcall test-not-fun x)))) + (lambda (x y) (not (funcall test-not-fun x y)))) (%coerce-callable-to-fun test)))) (multiple-value-bind (short long n-short) (if (< n1 n2) @@ -1213,35 +1290,68 @@ ;;;; Specialized versions -;;; %MEMBER-* and %ASSOC-* function. The transforms for %MEMBER and %ASSOC pick -;;; the appropriate version. These win because they have only positional arguments, -;;; the TEST & KEY functions are known to exist (or not), and are known to be -;;; functions, not function designators. -(macrolet ((def (funs form) - (flet ((%def (name) - `(defun ,(intern (format nil "%~A~{-~A~}" name funs)) - (item list ,@funs) - ,@(when funs `((declare (function ,@funs)))) - (do ((list list (cdr list))) +;;; %ADJOIN-*, %ASSOC-*, and %MEMBER-* functions. Deftransforms +;;; delegate to TRANSFORM-LIST-ITEM-SEEK which picks the appropriate +;;; version. These win because they have only positional arguments, +;;; the TEST, TEST-NOT & KEY functions are known to exist (or not), +;;; and are known to be functions instead of function designators. We +;;; are also able to transform many common cases to -EQ versions, +;;; which are substantially faster then EQL using ones. +(macrolet + ((def (funs form &optional variant) + (flet ((%def (name) + (let* ((body-loop + `(do ((list list (cdr list))) ((null list) nil) + (declare (list list)) (let ((this (car list))) ,(ecase name - (assoc - `(when this - (let ((target (car this))) - (when (and this ,form) - (return this))))) - (member - `(let ((target this)) - (when ,form - (return list)))))))))) - `(progn - ,(%def 'member) - ,(%def 'assoc))))) + (assoc + (if funs + `(when this + (let ((target (car this))) + (when ,form + (return this)))) + ;; If there is no TEST/TEST-NOT or + ;; KEY, do the EQ/EQL test first, + ;; before checking for NIL. + `(let ((target (car this))) + (when (and ,form this) + (return this))))) + (member + `(let ((target this)) + (when ,form + (return list)))) + (adjoin + `(let ((target this)) + (when ,form + (return t)))))))) + (body (if (eq 'adjoin name) + `(if (let ,(when (member 'key funs) + `((item (funcall key item)))) + ,body-loop) + list + (cons item list)) + body-loop))) + `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) + (item list ,@funs) + (declare (optimize speed (sb!c::verify-arg-count 0))) + ,@(when funs `((declare (function ,@funs)))) + ,body)))) + `(progn + ,(%def 'adjoin) + ,(%def 'assoc) + ,(%def 'member))))) (def () (eql item target)) + (def () + (eq item target) + eq) (def (key) (eql item (funcall key target))) + (def (key) + (eq item (funcall key target)) + eq) (def (key test) (funcall test item (funcall key target))) (def (key test-not) @@ -1249,4 +1359,4 @@ (def (test) (funcall test item target)) (def (test-not) - (not (funcall test-not item target)))) + (not (funcall test-not item target))))