X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flist.lisp;h=a65faac30ae8f29bf18003726336de7918c890fb;hb=3a10f894e7867fa2c27a3af05380abc3247f728d;hp=cacffe8ac08009401d882b27f986d422180d3717;hpb=b711554e4ce0dce883ba9e09a445c969aec0d305;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index cacffe8..a65faac 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -257,45 +257,36 @@ ((zerop count) result) (declare (type index count)))) -;;; The outer loop finds the first non-null list and the result is -;;; started. The remaining lists in the arguments are tacked to the -;;; end of the result using splice which cdr's down the end of the new -;;; list. (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (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)))))))))))) + (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)." + (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))))) + (append1 (lists) + (let ((current (car lists)) + (rest (cdr lists))) + (cond ((null rest) current) + ((consp current) + (let ((result (truly-the cons (list (car current))))) + (append-into result + (cdr current) + rest) + result)) + ((null current) (append1 rest)) + (t (fail current)))))) + (append1 lists))) ;;;; list copying functions @@ -310,7 +301,7 @@ (let ((result (list (car list)))) (do ((x (cdr list) (cdr x)) (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) + (cdr (rplacd splice (cons (car x) '()))))) ((atom x) (unless (null x) (rplacd splice x)))) @@ -319,12 +310,12 @@ (defun copy-alist (alist) #!+sb-doc "Return a new association list which is EQUAL to ALIST." - (if (atom alist) + (if (endp alist) alist (let ((result (cons (if (atom (car alist)) (car alist) - (cons (caar alist) (cdar alist)) ) + (cons (caar alist) (cdar alist))) nil))) (do ((x (cdr alist) (cdr x)) (splice result @@ -334,10 +325,7 @@ (car x) (cons (caar x) (cdar x))) nil))))) - ;; Non-null terminated alist done here. - ((atom x) - (unless (null x) - (rplacd splice x)))) + ((endp x))) result))) (defun copy-tree (object) @@ -403,7 +391,7 @@ (defun nreconc (x y) #!+sb-doc "Return (NCONC (NREVERSE X) Y)." - (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) + (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st))) (2nd x 1st) ;2nd follows first down the list. (3rd y 2nd)) ;3rd follows 2nd down the list. ((atom 2nd) 3rd) @@ -898,32 +886,48 @@ ;; 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 + ;; top of the list or not. (do ((list1 list1) (list2 list2) (x list1 (cdr x)) - (splicex ())) + (splicex ()) + (deleted-y ()) + ;; elements of LIST2, which are "equal" to some processed + ;; earlier elements of LIST1 + ) ((endp x) (if (null splicex) (setq list1 list2) (rplacd splicex list2)) list1) - (do ((y list2 (cdr y)) - (splicey ())) - ((endp y) (setq splicex x)) - (cond ((let ((key-val-x (apply-key key (car x))) - (key-val-y (apply-key key (Car y)))) - (if notp - (not (funcall test-not key-val-x key-val-y)) - (funcall test key-val-x key-val-y))) - (if (null splicex) - (setq list1 (cdr x)) - (rplacd splicex (cdr x))) - (if (null splicey) - (setq list2 (cdr y)) - (rplacd splicey (cdr y))) - (return ())) ; assume lists are really sets - (t (setq splicey y))))))) + (let ((key-val-x (apply-key key (car x))) + (found-duplicate nil)) + + ;; Move all elements from LIST2, which are "equal" to (CAR X), + ;; to DELETED-Y. + (do* ((y list2 next-y) + (next-y (cdr y) (cdr y)) + (splicey ())) + ((endp y)) + (cond ((let ((key-val-y (apply-key key (car y)))) + (if notp + (not (funcall test-not key-val-x key-val-y)) + (funcall test key-val-x key-val-y))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (setq deleted-y (rplacd y deleted-y)) + (setq found-duplicate t)) + (t (setq splicey y)))) + + (unless found-duplicate + (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) + + (if found-duplicate + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (setq splicex x)))))) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc