GCD, LCM, SIGNUM.

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index a41d821..dabd201 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -68,6 +68,16 @@
 (defun nth (n list)
   (car (nthcdr n list)))
 
 (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)))
 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))

@@ -208,16 +218,19 @@
     (setq list (cdr 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
   (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))
 
       (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
   (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))
       (return)
       (setq alist (cdr alist))))
   (car alist))

@@ -256,7 +269,7 @@
             (list x)
             (list new-value)
             `(progn (rplacd ,cons ,new-value) ,new-value)
             (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.
 
 
 ;; The NCONC function is based on the SBCL's one.

@@ -304,6 +317,6 @@
 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
   (let ((new-list ()))
     (dolist (x list1)
 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
   (let ((new-list ()))
     (dolist (x list1)

-      (when (member x list2 :test test :key key)
+      (when (member (funcall key x) list2 :test test :key key)

         (push x new-list)))
     new-list))
         (push x new-list)))
     new-list))