1.0.17.36: better pprinting of DEFPACKAGE forms.

[sbcl.git] / src / code / list.lisp

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 5d32950..d18d3a5 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -320,7 +320,9 @@
 
 (defun list* (arg &rest others)
   #!+sb-doc
-  "Return a list of the arguments with last cons a dotted pair"
+  "Return a list of the arguments with last cons a dotted pair."
+  ;; We know the &REST is a proper list.
+  (declare (optimize (sb!c::type-check 0)))
   (cond ((atom others) arg)
         ((atom (cdr others)) (cons arg (car others)))
         (t (do ((x others (cdr x)))
@@ -857,14 +859,6 @@
         list
         (cons item list))))
 
-(define-compiler-macro adjoin (item list &rest keys)
-  (with-unique-names (n-item n-list)
-    `(let ((,n-item ,item)
-           (,n-list ,list))
-       (if (member ,n-item ,n-list ,@keys)
-           ,n-list
-           (cons ,n-item ,n-list)))))
-
 (defconstant +list-based-union-limit+ 80)
 
 (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
@@ -881,7 +875,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)
@@ -930,7 +924,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)
@@ -1298,44 +1292,58 @@
 
 ;;;; Specialized versions
 
-;;; %MEMBER-* and %ASSOC-* functions. The transforms for MEMBER and
-;;; ASSOC pick 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.
+;;; %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)
-                `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
-                     (item list ,@funs)
-                   (declare (optimize speed))
-                   ,@(when funs `((declare (function ,@funs))))
-                   (do ((list list (cdr list)))
-                       ((null list) nil)
-                     (declare (list list))
-                     (let ((this (car list)))
-                       ,(ecase name
-                               (assoc
-                                (if funs
-                                    `(when this
-                                       (let ((target (car this)))
+                (let* ((body-loop
+                        `(do ((list list (cdr list)))
+                             ((null list) nil)
+                           (declare (list list))
+                           (let ((this (car list)))
+                             ,(ecase name
+                                     (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 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))))))))))
+                                           (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 'member)
-            ,(%def 'assoc)))))
+            ,(%def 'adjoin)
+            ,(%def 'assoc)
+            ,(%def 'member)))))
   (def ()
       (eql item target))
   (def ()
@@ -1353,4 +1361,4 @@
   (def (test)
       (funcall test item target))
   (def (test-not)
-    (not (funcall test-not item target))))
+      (not (funcall test-not item target))))