Newlines after semicolons if *PRETTY-PRINT* is set.

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index d4439dd..36adc0e 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -13,6 +13,8 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 

+(/debug "loading list.lisp!")
+

 ;;;; Various list functions
 
 (defun cons (x y) (cons x y))
 ;;;; Various list functions
 
 (defun cons (x y) (cons x y))

@@ -68,6 +70,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)))

@@ -136,12 +148,17 @@
           (copy-tree (cdr tree)))
     tree))
 
           (copy-tree (cdr tree)))
     tree))
 

-(defun tree-equal (tree1 tree2 &key (test #'eql))
-  (if (atom tree1)
-    (and (atom tree2) (funcall test tree1 tree2))
-    (and (consp tree2)
-         (tree-equal (car tree1) (car tree2) :test test)
-         (tree-equal (cdr tree1) (cdr tree2) :test test))))
+(defun tree-equal (tree1 tree2 &key (test #'eql testp)
+                         (test-not #'eql test-not-p))
+  (when (and testp test-not-p) (error "Both test and test-not are set"))
+  (let ((func (if test-not-p (complement test-not) test)))
+    (labels ((%tree-equal (tree1 tree2)
+               (if (atom tree1)
+                 (and (atom tree2) (funcall func tree1 tree2))
+                 (and (consp tree2)
+                      (%tree-equal (car tree1) (car tree2))
+                      (%tree-equal (cdr tree1) (cdr tree2))))))
+      (%tree-equal tree1 tree2))))

 
 (defun tailp (object list)
   (do ((tail list (cdr tail)))
 
 (defun tailp (object list)
   (do ((tail list (cdr tail)))

@@ -179,10 +196,29 @@
                (rplaca tail (cdar tail)))
              (collect (apply func elems))))))))
 
                (rplaca tail (cdar tail)))
              (collect (apply func elems))))))))
 

+(defun mapn (func list)
+  (with-collect
+    (while list
+      (collect (funcall func list))
+      (setq list (cdr list)))))
+
+(defun maplist (func list &rest lists)
+  (let ((lists (cons list lists)))
+    (with-collect
+      (block loop
+        (loop
+           (let ((elems (mapn #'car lists)))
+             (do ((tail lists (cdr tail)))
+                 ((null tail))
+               (when (null (car tail)) (return-from loop))
+               (rplaca tail (cdar tail)))
+             (collect (apply func elems))))))))
+

 (defun mapc (func &rest lists)
 (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)))
+  (do* ((tails lists (map1 #'cdr tails))
+        (elems (map1 #'car tails)
+               (map1 #'car tails)))
+       ((dolist (x tails) (when (null x) (return t)))

         (car lists))
     (apply func elems)))
 
         (car lists))
     (apply func elems)))
 

@@ -195,23 +231,27 @@
   (and (consp (cdr x))
        (cons (car x) (butlast (cdr x)))))
 
   (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
   (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))))
 
 
       (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
   (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))

@@ -250,7 +290,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.

@@ -298,6 +338,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))