car and cdr variants: order definitions properly, remove duplicates and add missing...

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index 173dedf..99e6e7a 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -72,17 +72,16 @@
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))
 (defun cddr (x) (cdr (cdr x)))
-(defun cadar (x) (car (cdr (car x))))
-(defun caddr (x) (car (cdr (cdr x))))
-(defun cdddr (x) (cdr (cdr (cdr x))))
-(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-
-(defun cadar  (x) (car (cdar  x)))
-(defun caaar  (x) (car (caar  x)))
-(defun caadr  (x) (car (cadr  x)))
-(defun cdaar  (x) (cdr (caar  x)))
-(defun cdadr  (x) (cdr (cadr  x)))
-(defun cddar  (x) (cdr (cdar  x)))
+
+(defun caaar (x) (car (caar x)))
+(defun caadr (x) (car (cadr x)))
+(defun cadar (x) (car (cdar x)))
+(defun caddr (x) (car (cddr x)))
+(defun cdaar (x) (cdr (caar x)))
+(defun cdadr (x) (cdr (cadr x)))
+(defun cddar (x) (cdr (cdar x)))
+(defun cdddr (x) (cdr (cddr x)))
+
 (defun caaaar (x) (car (caaar x)))
 (defun caaadr (x) (car (caadr x)))
 (defun caadar (x) (car (cadar x)))
@@ -90,6 +89,7 @@
 (defun cadaar (x) (car (cdaar x)))
 (defun cadadr (x) (car (cdadr x)))
 (defun caddar (x) (car (cddar x)))
+(defun cadddr (x) (car (cdddr x)))
 (defun cdaaar (x) (cdr (caaar x)))
 (defun cdaadr (x) (cdr (caadr x)))
 (defun cdadar (x) (cdr (cadar x)))
@@ -161,6 +161,13 @@
                (rplaca tail (cdar tail)))
              (collect (apply func elems))))))))
 
+(defun mapc (func &rest lists)
+  (do* ((elems (map1 #'car lists) (map1 #'car lists-rest))
+        (lists-rest (map1 #'cdr lists) (map1 #'cdr lists-rest)))
+       ((dolist (x elems) (when (null x) (return t)))
+        (car lists))
+    (apply func elems)))
+
 (defun last (x)
   (while (consp (cdr x))
     (setq x (cdr x)))
@@ -170,9 +177,9 @@
   (and (consp (cdr x))
        (cons (car x) (butlast (cdr x)))))
 
-(defun member (x list)
+(defun member (x list &key (key #'identity) (test #'eql))
   (while list
-    (when (eql x (car list))
+    (when (funcall test x (funcall key (car list)))
       (return list))
     (setq list (cdr list))))
 
@@ -180,10 +187,33 @@
 (defun assoc (x alist &key (test #'eql))
   (while alist
     (if (funcall test x (caar alist))
-        (return)
-        (setq alist (cdr alist))))
+      (return)
+      (setq alist (cdr alist))))
+  (car alist))
+
+(defun rassoc (x alist &key (test #'eql))
+  (while alist
+    (if (funcall test x (cdar alist))
+      (return)
+      (setq alist (cdr alist))))
   (car alist))
 
+(defun acons (key datum alist)
+  (cons (cons key datum) alist))
+
+(defun pairlis (keys data &optional (alist ()))
+  (while keys
+    (setq alist (acons (car keys) (car data) alist))
+    (setq keys (cdr keys))
+    (setq data (cdr data)))
+  alist)
+
+(defun copy-alist (alist)
+  (let ((new-alist ()))
+    (while alist
+      (push (cons (caar alist) (cdar alist)) new-alist)
+      (setq alist (cdr alist)))
+    (reverse new-alist)))
 
 
 (define-setf-expander car (x)
@@ -240,3 +270,16 @@
        (3rd y 2nd))               ;3rd follows 2nd down the list.
       ((atom 2nd) 3rd)
     (rplacd 2nd 3rd)))
+
+
+(defun adjoin (item list &key (test #'eql) (key #'identity))
+  (if (member item list :key key :test test)
+    list
+    (cons item list)))
+
+(defun intersection (list1 list2 &key (test #'eql) (key #'identity))
+  (let ((new-list ()))
+    (dolist (x list1)
+      (when (member x list2 :test test :key key)
+        (push x new-list)))
+    new-list))