X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=b974cd016d48e0cf4fd8a0125d65942404163607;hb=95984c591c75b8085adde1d478b224c2ed29eaa5;hp=d0ec5178d2b7242b4fd2ae70f86fa820130c4c46;hpb=7b9c47361e1aac31bc78d4627b651b8cc5ee0a7c;p=jscl.git diff --git a/src/list.lisp b/src/list.lisp index d0ec517..b974cd0 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 . +(/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) @@ -59,6 +61,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,6 +77,16 @@ (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))) @@ -99,6 +118,24 @@ (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")) @@ -136,12 +173,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))) @@ -149,18 +191,6 @@ (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 @@ -179,10 +209,29 @@ (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* ((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))) @@ -195,23 +244,27 @@ (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 - (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)) @@ -250,7 +303,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. @@ -298,6 +351,6 @@ (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))