X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Flist.lisp;h=9a445dbdd78268704e71259f8c541dcdccc78179;hb=fde8e7678f3a194026bf14d630d3b7e979e3ce6e;hp=d2b024730ba93b564801a86013dd8155948f0f6e;hpb=208c73a2f0efe2a798ac6ea959687c613dc7d5e8;p=jscl.git
diff --git a/src/list.lisp b/src/list.lisp
index d2b0247..9a445db 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -1,17 +1,17 @@
;;; list.lisp ---
-;; This program is free software: you can redistribute it and/or
+;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
-;; This program is distributed in the hope that it will be useful, but
+;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see .
+;; along with JSCL. If not, see .
;;;; Various list functions
@@ -29,7 +29,7 @@
t
(if (consp x)
nil
- (error "type-error"))))
+ (error "The value `~S' is not a type list." x))))
(defun car (x)
"Return the CAR part of a cons, or NIL if X is null."
@@ -37,11 +37,17 @@
(defun cdr (x) (cdr x))
-(defun first (x) (car x))
-(defun second (x) (cadr x))
-(defun third (x) (caddr x))
-(defun fourth (x) (cadddr x))
-(defun rest (x) (cdr x))
+(defun first (x) (car x))
+(defun second (x) (cadr x))
+(defun third (x) (caddr x))
+(defun fourth (x) (cadddr x))
+(defun fifth (x) (car (cddddr x)))
+(defun sixth (x) (cadr (cddddr x)))
+(defun seventh (x) (caddr (cddddr x)))
+(defun eighth (x) (cadddr (cddddr x)))
+(defun ninth (x) (car (cddddr (cddddr x))))
+(defun tenth (x) (cadr (cddddr (cddddr x))))
+(defun rest (x) (cdr x))
(defun list (&rest args)
args)
@@ -62,22 +68,20 @@
(defun nth (n list)
(car (nthcdr n list)))
-;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
(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)))
@@ -85,6 +89,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)))
@@ -94,6 +99,19 @@
(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 copy-list (x)
(mapcar #'identity x))
@@ -104,6 +122,19 @@
(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 tailp (object list)
+ (do ((tail list (cdr tail)))
+ ((atom tail) (eq object tail))
+ (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))
@@ -143,6 +174,13 @@
(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)))
+ (car lists))
+ (apply func elems)))
+
(defun last (x)
(while (consp (cdr x))
(setq x (cdr x)))
@@ -152,9 +190,9 @@
(and (consp (cdr x))
(cons (car x) (butlast (cdr x)))))
-(defun member (x list)
+(defun member (x list &key (key #'identity) (test #'eql))
(while list
- (when (eql x (car list))
+ (when (funcall test x (funcall key (car list)))
(return list))
(setq list (cdr list))))
@@ -162,10 +200,33 @@
(defun assoc (x alist &key (test #'eql))
(while alist
(if (funcall test x (caar alist))
- (return)
- (setq alist (cdr alist))))
+ (return)
+ (setq alist (cdr alist))))
(car alist))
+(defun rassoc (x alist &key (test #'eql))
+ (while alist
+ (if (funcall test x (cdar alist))
+ (return)
+ (setq alist (cdr alist))))
+ (car alist))
+
+(defun acons (key datum alist)
+ (cons (cons key datum) alist))
+
+(defun pairlis (keys data &optional (alist ()))
+ (while keys
+ (setq alist (acons (car keys) (car data) alist))
+ (setq keys (cdr keys))
+ (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)
@@ -222,3 +283,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 x list2 :test test :key key)
+ (push x new-list)))
+ new-list))