;;;; -- 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))
(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
(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)))
\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
;;; 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
\f
;;;; 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.
(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)
(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)
(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)
;;;; 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)
(def (test)
(funcall test item target))
(def (test-not)
- (not (funcall test-not item target))))
+ (not (funcall test-not item target))))