((zerop count) result)
(declare (type index count))))
\f
-;;; 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)))
\f
;;;; list copying functions
(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))))
(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
(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)
(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)
;; 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