Fix (SETF OGET).

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index a41d821..b974cd0 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))

@@ -59,6 +61,13 @@
                ((null (cddr x)) (rplacd x (cadr x))))
            (cons arg others))))
 
                ((null (cddr x)) (rplacd x (cadr x))))
            (cons arg others))))
 

+(defun list-length (list)
+  (let ((l 0))
+    (while (not (null list))
+      (incf l)
+      (setq list (cdr list)))
+    l))
+

 (defun nthcdr (n list)
   (while (and (plusp n) list)
     (setq n (1- n))
 (defun nthcdr (n list)
   (while (and (plusp n) list)
     (setq n (1- n))

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

@@ -99,6 +118,24 @@
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 

+(defun append-two (list1 list2)
+  (if (null list1)
+      list2
+      (cons (car list1)
+            (append (cdr list1) list2))))
+
+(defun append (&rest lists)
+  (!reduce #'append-two lists nil))
+
+(defun revappend (list1 list2)
+  (while list1
+    (push (car list1) list2)
+    (setq list1 (cdr list1)))
+  list2)
+
+(defun reverse (list)
+  (revappend list '()))
+

 (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"))
 (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"))

@@ -154,18 +191,6 @@
     (when (eql tail object)
       (return-from tailp t))))
 
     (when (eql tail object)
       (return-from tailp t))))
 

-(defmacro pop (place)
-  (multiple-value-bind (dummies vals newval setter getter)
-    (get-setf-expansion place)
-    (let ((head (gensym)))
-      `(let* (,@(mapcar #'list dummies vals) 
-              (,head ,getter)
-              (,(car newval) (cdr ,head))
-              ,@(cdr newval)) 
-         ,setter
-         (car ,head)))))
-
-

 (defun map1 (func list)
   (with-collect
     (while list
 (defun map1 (func list)
   (with-collect
     (while list

@@ -184,10 +209,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)))
 

@@ -208,16 +252,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 +303,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 +351,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))