X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=9a445dbdd78268704e71259f8c541dcdccc78179;hb=fde8e7678f3a194026bf14d630d3b7e979e3ce6e;hp=7a4ca6d909dfd7c9ff98d5fac5b6e2dfeaf4b2db;hpb=a14d0ed62b18400b33805670b900db6a63899796;p=jscl.git

diff --git a/src/list.lisp b/src/list.lisp
index 7a4ca6d..9a445db 100644
--- 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)))
@@ -99,6 +99,19 @@
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 
+(defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+  (when (and testp test-not-p)
+    (error "Both test and test-not are set"))
+  (labels ((s (tree)
+             (let* ((key-val (if key (funcall key tree) tree))
+                    (replace (if test-not-p
+                                 (assoc key-val alist :test-not test-not)
+                                 (assoc key-val alist :test test)))
+                    (x (if replace (cdr replace) tree)))
+               (if (atom x)
+                   x
+                   (cons (s (car x)) (s (cdr x)))))))
+    (s tree)))
 
 (defun copy-list (x)
   (mapcar #'identity x))
@@ -161,6 +174,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)))