+
+
+(defun copy-list (x)
+ (mapcar #'identity x))
+
+(defun copy-tree (tree)
+ (if (consp tree)
+ (cons (copy-tree (car tree))
+ (copy-tree (cdr tree)))
+ tree))
+
+(defun tree-equal (tree1 tree2 &key (test #'eql))
+ (if (atom tree1)
+ (and (atom tree2) (funcall test tree1 tree2))
+ (and (consp tree2)
+ (tree-equal (car tree1) (car tree2) :test test)
+ (tree-equal (cdr tree1) (cdr tree2) :test test))))
+
+(defun subst (new old tree &key (key #'identity) (test #'eql))
+ (cond
+ ((funcall test (funcall key tree) (funcall key old))
+ new)
+ ((consp tree)
+ (cons (subst new old (car tree) :key key :test test)
+ (subst new old (cdr tree) :key key :test test)))
+ (t tree)))
+
+(defmacro pop (place)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place)
+ (let ((head (gensym)))
+ `(let* (,@(mapcar #'list dummies vals)
+ (,head ,getter)
+ (,(car newval) (cdr ,head))
+ ,@(cdr newval))
+ ,setter
+ (car ,head)))))
+
+
+(defun map1 (func list)
+ (with-collect
+ (while list
+ (collect (funcall func (car list)))
+ (setq list (cdr list)))))
+
+(defun mapcar (func list &rest lists)
+ (let ((lists (cons list lists)))
+ (with-collect
+ (block loop
+ (loop
+ (let ((elems (map1 #'car lists)))
+ (do ((tail lists (cdr tail)))
+ ((null tail))
+ (when (null (car tail)) (return-from loop))
+ (rplaca tail (cdar tail)))
+ (collect (apply func elems))))))))
+
+(defun last (x)
+ (while (consp (cdr x))
+ (setq x (cdr x)))
+ x)
+
+(defun butlast (x)
+ (and (consp (cdr x))
+ (cons (car x) (butlast (cdr x)))))
+
+(defun member (x list)
+ (while list
+ (when (eql x (car list))
+ (return list))
+ (setq list (cdr list))))
+
+
+(defun assoc (x alist &key (test #'eql))
+ (while alist
+ (if (funcall test x (caar alist))
+ (return)
+ (setq alist (cdr alist))))
+ (car alist))
+
+
+
+(define-setf-expander car (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplaca ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+(define-setf-expander cdr (x)
+ (let ((cons (gensym))
+ (new-value (gensym)))
+ (values (list cons)
+ (list x)
+ (list new-value)
+ `(progn (rplacd ,cons ,new-value) ,new-value)
+ `(car ,cons))))
+
+
+;; The NCONC function is based on the SBCL's one.
+(defun nconc (&rest lists)
+ (flet ((fail (object)
+ (error "type-error in nconc")))
+ (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)
+ (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)
+ (rplacd 2nd 3rd)))