[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv26386

Modified Files:
	lists.lisp 
Log Message:
Fix member to accept nil key. Fix copy-list to accept dotted list.


--- /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/04/29 11:41:34	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/lists.lisp	2006/05/03 22:20:02	1.15
@@ -9,7 +9,7 @@
 ;;;; Created at:    Tue Dec  5 18:40:11 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: lists.lisp,v 1.14 2006/04/29 11:41:34 ffjeld Exp $
+;;;; $Id: lists.lisp,v 1.15 2006/05/03 22:20:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -112,20 +112,21 @@
     ;;  That fact justifies this implementation.)
     (when (and (eq fast slow) (> n 0)) (return nil))))
 
-(defun member (item list &key (key 'identity) (test 'eql))
+(defun member (item list &key key (test 'eql))
   (numargs-case
    (2 (item list)
       (do ((p list (cdr p)))
 	  ((endp p) nil)
 	(when (eql item (car p))
 	  (return p))))
-   (t (item list &key (key 'identity) (test 'eql))
-      (with-funcallable (key)
-	(with-funcallable (test)
-	  (do ((p list (cdr p)))
-	      ((endp p) nil)
-	    (when (test item (key (car p)))
-	      (return p))))))))
+   (t (item list &key key (test 'eql))
+      (let ((key (or key 'identity)))
+	(with-funcallable (key)
+	  (with-funcallable (test)
+	    (do ((p list (cdr p)))
+		((endp p) nil)
+	      (when (test item (key (car p)))
+		(return p)))))))))
 
 (defun last (list &optional (n 1))
   ;; from the hyperspec..
@@ -198,10 +199,10 @@
 (defun copy-list (list)
   (if (null list)
       nil
-    (let ((new-list (cons (pop list) nil)))
+    (let ((new-list (cons (pop list) list)))
       (do ((new-tail new-list (cdr new-tail)))
-	  ((null list) new-list)
-	(setf (cdr new-tail) (cons (pop list) nil))))))
+	  ((atom list) new-list)
+	(setf (cdr new-tail) (cons (pop list) list))))))
 
 (defun list (&rest objects)
   (numargs-case