;; 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)
((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 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 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"))
(s tree)))
(defun subst (new old 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 (x)
- (let ((key-val (if key (funcall key x) x)))
- (cond
- ((funcall (if test-not-p test-not test) key-val old) new)
- ((atom x) x)
- (t (cons (s (car x)) (s (cdr 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)
(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)))
(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
(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)))
(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))
(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.
(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))
projects / jscl.git / blobdiff