(defun last1 (list)
#!+sb-doc
"Return the last cons (not the last element) of a list"
- (let ((rest list))
+ (let ((rest list)
+ (list list))
(loop (unless (consp rest) (return list))
(shiftf list rest (cdr rest)))))
(declare (type index size))
(do ((count size (1- count))
(result '() (cons initial-element result)))
- ((zerop count) result)
+ ((<= count 0) result)
(declare (type index count))))
\f
(defun append (&rest lists)
\f
;;;; 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
((endp elements))
(let ((ele (car elements)))
(typecase ele
- (cons (rplacd (last1 splice) ele)
+ (cons (rplacd (last splice) ele)
(setf splice ele))
- (null (rplacd (last1 splice) nil))
+ (null (rplacd (last splice) nil))
(atom (if (cdr elements)
(fail ele)
- (rplacd (last1 splice) ele)))
+ (rplacd (last splice) ele)))
(t (fail ele)))))
(return result)))
(null)
(do ((list list (cdr list)))
((null list) nil)
(let ((car (car list)))
- (if (satisfies-the-test item car)
- (return list))))))
+ (when (satisfies-the-test item car)
+ (return list))))))
(defun member-if (test list &key key)
#!+sb-doc
list
(cons item list))))
+(defconstant +list-based-union-limit+ 80)
+
(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
#!+sb-doc
"Return the union of LIST1 and LIST2."
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- ;; We assumes LIST2 is the result, adding to it from LIST1 as
- ;; necessary. LIST2 must initialize the result value, so the call to
- ;; MEMBER will apply the test to the elements from LIST1 and LIST2
- ;; in the correct order.
- (let ((key (and key (%coerce-callable-to-fun key))))
- (let ((res list2))
- (dolist (elt list1)
- (unless (with-set-keys (member (apply-key key elt) list2))
- (push elt res)))
- res)))
+ ;; We have to possibilities here: for shortish lists we pick up the
+ ;; shorter one as the result, and add the other one to it. For long
+ ;; lists we use a hash-table when possible.
+ (let ((n1 (length list1))
+ (n2 (length list2))
+ (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))))
+ (%coerce-callable-to-fun test))))
+ (multiple-value-bind (short long n-short)
+ (if (< n1 n2)
+ (values list1 list2 n1)
+ (values list2 list1 n2))
+ (if (or (< n-short +list-based-union-limit+)
+ (not (member test (list #'eq #'eql #'equal #'equalp))))
+ (let ((orig short))
+ (dolist (elt long)
+ (unless (member (apply-key key elt) orig :key key :test test)
+ (push elt short)))
+ short)
+ (let ((table (make-hash-table :test test :size (+ n1 n2)))
+ (union nil))
+ (dolist (elt long)
+ (setf (gethash (apply-key key elt) table) elt))
+ (dolist (elt short)
+ (setf (gethash (apply-key key elt) table) elt))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (push v union))
+ table)
+ union)))))
;;; Destination and source are SETF-able and many-evaluable. Set the
;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION.
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- (let ((key (and key (%coerce-callable-to-fun key))))
- (let ((res list2)
- (list1 list1))
- (do ()
- ((endp list1))
- (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
- (steve-splice list1 res)
- (setf list1 (cdr list1))))
- res)))
+ ;; We have to possibilities here: for shortish lists we pick up the
+ ;; shorter one as the result, and add the other one to it. For long
+ ;; lists we use a hash-table when possible.
+ (let ((n1 (length list1))
+ (n2 (length list2))
+ (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))))
+ (%coerce-callable-to-fun test))))
+ (multiple-value-bind (short long n-short)
+ (if (< n1 n2)
+ (values list1 list2 n1)
+ (values list2 list1 n2))
+ (if (or (< n-short +list-based-union-limit+)
+ (not (member test (list #'eq #'eql #'equal #'equalp))))
+ (let ((orig short))
+ (do ((elt (car long) (car long)))
+ ((endp long))
+ (if (not (member (apply-key key elt) orig :key key :test test))
+ (steve-splice long short)
+ (setf long (cdr long))))
+ short)
+ (let ((table (make-hash-table :test test :size (+ n1 n2))))
+ (dolist (elt long)
+ (setf (gethash (apply-key key elt) table) elt))
+ (dolist (elt short)
+ (setf (gethash (apply-key key elt) table) elt))
+ (let ((union long)
+ (head long))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (if head
+ (setf (car head) v
+ head (cdr head))
+ (push v union)))
+ table)
+ union))))))
(defun intersection (list1 list2
&key key (test #'eql testp) (test-not nil notp))
(setf (car l) (cdar l)))
(setq res (apply fun (nreverse args)))
(case accumulate
- (:nconc (setq temp (last1 (nconc temp res))))
+ (:nconc (setq temp (last (nconc temp res))))
(:list (rplacd temp (list res))
(setq temp (cdr temp))))))))
#!+sb-doc
"Apply FUNCTION to successive CDRs of lists. Return NCONC of results."
(map1 function (cons list more-lists) :nconc nil))
+
+;;;; 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)))
+ ((null list) nil)
+ (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)))))
+ (def ()
+ (eql item target))
+ (def (key)
+ (eql item (funcall key target)))
+ (def (key test)
+ (funcall test item (funcall key target)))
+ (def (key test-not)
+ (not (funcall test-not item (funcall key target))))
+ (def (test)
+ (funcall test item target))
+ (def (test-not)
+ (not (funcall test-not item target))))
projects / sbcl.git / blobdiff