X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=6b58aae4f3614be25ac44a5d007b24a7be6215f3;hb=21d052d84e68ca27e1815d2c8a9484da8f7beb7a;hp=96a359480abada1bf41dbbfe73fd02e5f4ec7890;hpb=8f59cd56540bb3699c80c141f30968cb0126ce04;p=jscl.git

diff --git a/src/list.lisp b/src/list.lisp
index 96a3594..6b58aae 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -68,6 +68,16 @@
 (defun nth (n list)
   (car (nthcdr n list)))
 
+(define-setf-expander nth (n list)
+  (let ((g!list (gensym))
+        (g!index (gensym))
+        (g!value (gensym)))
+    (values (list g!list g!index)
+            (list list n)
+            (list g!value)
+            `(rplaca (nthcdr ,g!index ,g!list) ,g!value)
+            `(nth ,g!index ,g!list))))
+
 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))
@@ -200,23 +210,27 @@
   (and (consp (cdr x))
        (cons (car x) (butlast (cdr x)))))
 
-(defun member (x list &key (key #'identity) (test #'eql))
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p)) 
   (while list
-    (when (funcall test x (funcall key (car list)))
+    (when (satisfies-test-p x (car list) :key key :test test :testp testp
+                            :test-not test-not :test-not-p test-not-p)
       (return list))
     (setq list (cdr list))))
 
 
-(defun assoc (x alist &key (test #'eql))
+(defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
   (while alist
-    (if (funcall test x (caar alist))
+    (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
+                          :test-not test-not :test-not-p test-not-p)
       (return)
       (setq alist (cdr alist))))
   (car alist))
 
-(defun rassoc (x alist &key (test #'eql))
+(defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
+                 (test-not #'eql test-not-p))
   (while alist
-    (if (funcall test x (cdar alist))
+    (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
+                          :test-not test-not :test-not-p test-not-p)
       (return)
       (setq alist (cdr alist))))
   (car alist))
@@ -255,7 +269,7 @@
             (list x)
             (list new-value)
             `(progn (rplacd ,cons ,new-value) ,new-value)
-            `(car ,cons))))
+            `(cdr ,cons))))
 
 
 ;; The NCONC function is based on the SBCL's one.