X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=36adc0e9f4b647a870e951f7d4598a346dcc0d70;hb=0105d7b5712cbfd3b0bf8e527f562071b3c12151;hp=b353700fa6950e7cd97739408fd9ccdbbbad16c0;hpb=37b1b658da3d73aa304df83cc3e8bf8aa6548a25;p=jscl.git diff --git a/src/list.lisp b/src/list.lisp index b353700..36adc0e 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) @@ -68,21 +70,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 +101,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 +111,33 @@ (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 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 +148,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,15 +166,6 @@ (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) @@ -161,6 +196,32 @@ (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))) @@ -170,18 +231,29 @@ (and (consp (cdr x)) (cons (car x) (butlast (cdr x))))) -(defun member (x list) +(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p)) (while list - (when (eql x (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 (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 key (test #'eql) (test #'eql testp) + (test-not #'eql test-not-p)) (while alist - (if (funcall test x (caar alist)) - (return) - (setq alist (cdr 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)) (defun acons (key datum alist) @@ -194,6 +266,13 @@ (setq data (cdr data))) alist) +(defun copy-alist (alist) + (let ((new-alist ())) + (while alist + (push (cons (caar alist) (cdar alist)) new-alist) + (setq alist (cdr alist))) + (reverse new-alist))) + (define-setf-expander car (x) (let ((cons (gensym)) @@ -211,7 +290,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. @@ -249,3 +328,16 @@ (3rd y 2nd)) ;3rd follows 2nd down the list. ((atom 2nd) 3rd) (rplacd 2nd 3rd))) + + +(defun adjoin (item list &key (test #'eql) (key #'identity)) + (if (member item list :key key :test test) + list + (cons item list))) + +(defun intersection (list1 list2 &key (test #'eql) (key #'identity)) + (let ((new-list ())) + (dolist (x list1) + (when (member (funcall key x) list2 :test test :key key) + (push x new-list))) + new-list))