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

diff --git a/src/list.lisp b/src/list.lisp
index 7a4ca6d..274d2f3 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -13,9 +13,11 @@
 ;; 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))
+(defun cons (x y) (cons x y))
 (defun consp (x) (consp x))
 
 (defun listp (x)
@@ -37,6 +39,12 @@
 
 (defun cdr (x) (cdr x))
 
+(defun rplaca (cons x)
+  (rplaca cons x))
+
+(defun rplacd (cons x)
+  (rplacd cons x))
+
 (defun first   (x) (car    x))
 (defun second  (x) (cadr   x))
 (defun third   (x) (caddr  x))
@@ -59,6 +67,13 @@
                ((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))
@@ -68,21 +83,30 @@
 (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 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 +114,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 +124,51 @@
 (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"))
+  (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 subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+  (labels ((s (x)
+             (cond ((satisfies-test-p old x :key key :test test :testp testp
+                                      :test-not test-not :test-not-p test-not-p)
+                    new)
+                   ((atom x) x)
+                   (t (let ((a (s (car x)))
+                            (b (s (cdr x))))
+                        (if (and (eq a (car x))
+                                 (eq b (cdr x)))
+                            x
+                            (cons a b)))))))
+    (s tree)))
 
 (defun copy-list (x)
   (mapcar #'identity x))
@@ -109,12 +179,17 @@
           (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)))
@@ -122,26 +197,13 @@
     (when (eql tail object)
       (return-from tailp t))))
 
-(defun subst (new old tree &key (key #'identity) (test #'eql))
-  (cond 
-    ((funcall test (funcall key tree) (funcall key old))
-     new) 
-    ((consp tree)
-     (cons (subst new old (car tree) :key key :test test)
-           (subst new old (cdr tree) :key key :test test))) 
-    (t tree)))
-
-(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 make-list (size &key (initial-element nil))
+  "Create a list of size `size` of `initial-element`s."
+  (when (< size 0)
+    (error "Size must be non-negative"))
+  (let ((newlist))
+    (dotimes (i size newlist)
+      (push initial-element newlist))))
 
 (defun map1 (func list)
   (with-collect
@@ -161,32 +223,83 @@
                (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)
+  (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)))
+
 (defun last (x)
   (while (consp (cdr x))
     (setq x (cdr x)))
   x)
 
-(defun butlast (x)
-  (and (consp (cdr x))
-       (cons (car x) (butlast (cdr x)))))
-
-(defun member (x list &key (key #'identity) (test #'eql))
+(defun butlast (x &optional (n 1))
+  "Returns x, less the n last elements in the list."
+  (nbutlast (copy-list x) n))
+
+(defun nbutlast (x &optional (n 1))
+  "Destructively returns x, less the n last elements in the list."
+  (cond
+    ((not (and (integerp n) (>= n 0)))
+     ;; TODO: turn this error into a type error, per CLHS spec.
+     (error "n must be a non-negative integer"))
+    ;; trivial optimizations
+    ((zerop n) x)
+    (t
+     ;; O(n) walk of the linked list, trimming out the link where appropriate
+     (let* ((head x)
+            (trailing (nthcdr n x)))
+       ;; If there are enough conses
+       (when (consp trailing)
+         (while (consp (cdr trailing))
+           (setq head (cdr head))
+           (setq trailing (cdr trailing)))
+         ;; snip
+         (rplacd head nil)
+         x)))))
+
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
   (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))))
 
 
-(defun assoc (x alist &key (test #'eql))
+(defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
   (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))
 
-(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
-    (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))
@@ -225,7 +338,7 @@
             (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.
@@ -273,6 +386,54 @@
 (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))
+
+(defun get-properties (plist indicator-list)
+  (do* ((plist plist (cddr plist))
+        (cdr (cdr plist) (cdr plist))
+        (car (car plist) (car plist)))
+      ((null plist) (values nil nil nil))
+    (when (null cdr)
+      (error "malformed property list ~S" plist))
+    (let ((found (member car indicator-list :test #'eq)))
+      (when found
+        (return (values car (cadr plist) plist))))))
+
+(defun getf (plist indicator &optional default)
+  (do* ((plist plist (cddr plist))
+        (cdr (cdr plist) (cdr plist))
+        (car (car plist) (car plist)))
+      ((null plist) default)
+    (when (null cdr)
+      (error "malformed property list ~S" plist))
+    (when (eq indicator car)
+      (return (cadr plist)))))
+
+(defun %putf (plist indicator new-value)
+  (do* ((tail plist (cddr tail))
+        (cdr (cdr tail) (cdr tail))
+        (car (car tail) (car tail)))
+      ((null tail) (list* indicator new-value plist))
+    (when (null cdr)
+      (error "malformed property list ~S" tail))
+    (when (eq indicator car)
+      ;; TODO: should be cadr, needs a defsetf for that
+      (setf (car (cdr tail)) new-value)
+      (return tail))))
+
+(define-setf-expander getf (plist indicator &optional default)
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion plist)
+    (let ((store (gensym))
+          (indicator-sym (gensym))
+          (default-sym (and default (gensym))))
+      (values `(,indicator-sym ,@(and default `(,default-sym)) ,@dummies)
+              `(,indicator ,@(and default `(,default)) ,@vals)
+              `(,store)
+              `(let ((,(car newval) (%putf ,getter ,indicator-sym ,store))
+                     ,@(cdr newval))
+                 ,setter
+                 ,store)
+              `(getf ,getter ,indicator-sym ,@(and default `(,default-sym)))))))