Fix MAPC
[jscl.git] / src / list.lisp
1 ;;; list.lisp --- 
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 ;;;; Various list functions
17
18 (defun cons (x y) (cons x y))
19 (defun consp (x) (consp x))
20
21 (defun listp (x)
22   (or (consp x) (null x)))
23
24 (defun null (x)
25   (eq x nil))
26
27 (defun endp (x)
28   (if (null x)
29       t
30       (if (consp x)
31           nil
32           (error "The value `~S' is not a type list." x))))
33
34 (defun car (x)
35   "Return the CAR part of a cons, or NIL if X is null."
36   (car x))
37
38 (defun cdr (x) (cdr x))
39
40 (defun first   (x) (car    x))
41 (defun second  (x) (cadr   x))
42 (defun third   (x) (caddr  x))
43 (defun fourth  (x) (cadddr x))
44 (defun fifth   (x) (car    (cddddr x)))
45 (defun sixth   (x) (cadr   (cddddr x)))
46 (defun seventh (x) (caddr  (cddddr x)))
47 (defun eighth  (x) (cadddr (cddddr x)))
48 (defun ninth   (x) (car  (cddddr (cddddr x))))
49 (defun tenth   (x) (cadr (cddddr (cddddr x))))
50 (defun rest    (x) (cdr x))
51
52 (defun list (&rest args)
53   args)
54
55 (defun list* (arg &rest others)
56   (cond ((null others) arg)
57         ((null (cdr others)) (cons arg (car others)))
58         (t (do ((x others (cdr x)))
59                ((null (cddr x)) (rplacd x (cadr x))))
60            (cons arg others))))
61
62 (defun nthcdr (n list)
63   (while (and (plusp n) list)
64     (setq n (1- n))
65     (setq list (cdr list)))
66   list)
67
68 (defun nth (n list)
69   (car (nthcdr n list)))
70
71 (define-setf-expander nth (n list)
72   (let ((g!list (gensym))
73         (g!index (gensym))
74         (g!value (gensym)))
75     (values (list g!list g!index)
76             (list list n)
77             (list g!value)
78             `(rplaca (nthcdr ,g!index ,g!list) ,g!value)
79             `(nth ,g!index ,g!list))))
80
81 (defun caar (x) (car (car x)))
82 (defun cadr (x) (car (cdr x)))
83 (defun cdar (x) (cdr (car x)))
84 (defun cddr (x) (cdr (cdr x)))
85
86 (defun caaar (x) (car (caar x)))
87 (defun caadr (x) (car (cadr x)))
88 (defun cadar (x) (car (cdar x)))
89 (defun caddr (x) (car (cddr x)))
90 (defun cdaar (x) (cdr (caar x)))
91 (defun cdadr (x) (cdr (cadr x)))
92 (defun cddar (x) (cdr (cdar x)))
93 (defun cdddr (x) (cdr (cddr x)))
94
95 (defun caaaar (x) (car (caaar x)))
96 (defun caaadr (x) (car (caadr x)))
97 (defun caadar (x) (car (cadar x)))
98 (defun caaddr (x) (car (caddr x)))
99 (defun cadaar (x) (car (cdaar x)))
100 (defun cadadr (x) (car (cdadr x)))
101 (defun caddar (x) (car (cddar x)))
102 (defun cadddr (x) (car (cdddr x)))
103 (defun cdaaar (x) (cdr (caaar x)))
104 (defun cdaadr (x) (cdr (caadr x)))
105 (defun cdadar (x) (cdr (cadar x)))
106 (defun cdaddr (x) (cdr (caddr x)))
107 (defun cddaar (x) (cdr (cdaar x)))
108 (defun cddadr (x) (cdr (cdadr x)))
109 (defun cdddar (x) (cdr (cddar x)))
110 (defun cddddr (x) (cdr (cdddr x)))
111
112 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
113   (when (and testp test-not-p)
114     (error "Both test and test-not are set"))
115   (labels ((s (tree)
116              (let* ((key-val (if key (funcall key tree) tree))
117                     (replace (if test-not-p
118                                  (assoc key-val alist :test-not test-not)
119                                  (assoc key-val alist :test test)))
120                     (x (if replace (cdr replace) tree)))
121                (if (atom x)
122                    x
123                    (cons (s (car x)) (s (cdr x)))))))
124     (s tree)))
125
126 (defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
127   (labels ((s (x)
128              (cond ((satisfies-test-p old x :key key :test test :testp testp
129                                       :test-not test-not :test-not-p test-not-p)
130                     new)
131                    ((atom x) x)
132                    (t (let ((a (s (car x)))
133                             (b (s (cdr x))))
134                         (if (and (eq a (car x))
135                                  (eq b (cdr x)))
136                             x
137                             (cons a b)))))))
138     (s tree)))
139
140 (defun copy-list (x)
141   (mapcar #'identity x))
142
143 (defun copy-tree (tree)
144   (if (consp tree)
145     (cons (copy-tree (car tree))
146           (copy-tree (cdr tree)))
147     tree))
148
149 (defun tree-equal (tree1 tree2 &key (test #'eql testp)
150                          (test-not #'eql test-not-p))
151   (when (and testp test-not-p) (error "Both test and test-not are set"))
152   (let ((func (if test-not-p (complement test-not) test)))
153     (labels ((%tree-equal (tree1 tree2)
154                (if (atom tree1)
155                  (and (atom tree2) (funcall func tree1 tree2))
156                  (and (consp tree2)
157                       (%tree-equal (car tree1) (car tree2))
158                       (%tree-equal (cdr tree1) (cdr tree2))))))
159       (%tree-equal tree1 tree2))))
160
161 (defun tailp (object list)
162   (do ((tail list (cdr tail)))
163     ((atom tail) (eq object tail))
164     (when (eql tail object)
165       (return-from tailp t))))
166
167 (defmacro pop (place)
168   (multiple-value-bind (dummies vals newval setter getter)
169     (get-setf-expansion place)
170     (let ((head (gensym)))
171       `(let* (,@(mapcar #'list dummies vals) 
172               (,head ,getter)
173               (,(car newval) (cdr ,head))
174               ,@(cdr newval)) 
175          ,setter
176          (car ,head)))))
177
178
179 (defun map1 (func list)
180   (with-collect
181     (while list
182       (collect (funcall func (car list)))
183       (setq list (cdr list)))))
184
185 (defun mapcar (func list &rest lists)
186   (let ((lists (cons list lists)))
187     (with-collect
188       (block loop
189         (loop
190            (let ((elems (map1 #'car lists)))
191              (do ((tail lists (cdr tail)))
192                  ((null tail))
193                (when (null (car tail)) (return-from loop))
194                (rplaca tail (cdar tail)))
195              (collect (apply func elems))))))))
196
197 (defun mapn (func list)
198   (with-collect
199     (while list
200       (collect (funcall func list))
201       (setq list (cdr list)))))
202
203 (defun maplist (func list &rest lists)
204   (let ((lists (cons list lists)))
205     (with-collect
206       (block loop
207         (loop
208            (let ((elems (mapn #'car lists)))
209              (do ((tail lists (cdr tail)))
210                  ((null tail))
211                (when (null (car tail)) (return-from loop))
212                (rplaca tail (cdar tail)))
213              (collect (apply func elems))))))))
214
215 (defun mapc (func &rest lists)
216   (do* ((tails lists (map1 #'cdr tails))
217         (elems (map1 #'car tails)
218                (map1 #'car tails)))
219        ((dolist (x tails) (when (null x) (return t)))
220         (car lists))
221     (apply func elems)))
222
223 (defun last (x)
224   (while (consp (cdr x))
225     (setq x (cdr x)))
226   x)
227
228 (defun butlast (x)
229   (and (consp (cdr x))
230        (cons (car x) (butlast (cdr x)))))
231
232 (defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p)) 
233   (while list
234     (when (satisfies-test-p x (car list) :key key :test test :testp testp
235                             :test-not test-not :test-not-p test-not-p)
236       (return list))
237     (setq list (cdr list))))
238
239
240 (defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
241   (while alist
242     (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
243                           :test-not test-not :test-not-p test-not-p)
244       (return)
245       (setq alist (cdr alist))))
246   (car alist))
247
248 (defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
249                  (test-not #'eql test-not-p))
250   (while alist
251     (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
252                           :test-not test-not :test-not-p test-not-p)
253       (return)
254       (setq alist (cdr alist))))
255   (car alist))
256
257 (defun acons (key datum alist)
258   (cons (cons key datum) alist))
259
260 (defun pairlis (keys data &optional (alist ()))
261   (while keys
262     (setq alist (acons (car keys) (car data) alist))
263     (setq keys (cdr keys))
264     (setq data (cdr data)))
265   alist)
266
267 (defun copy-alist (alist)
268   (let ((new-alist ()))
269     (while alist
270       (push (cons (caar alist) (cdar alist)) new-alist)
271       (setq alist (cdr alist)))
272     (reverse new-alist)))
273
274
275 (define-setf-expander car (x)
276   (let ((cons (gensym))
277         (new-value (gensym)))
278     (values (list cons)
279             (list x)
280             (list new-value)
281             `(progn (rplaca ,cons ,new-value) ,new-value)
282             `(car ,cons))))
283
284 (define-setf-expander cdr (x)
285   (let ((cons (gensym))
286         (new-value (gensym)))
287     (values (list cons)
288             (list x)
289             (list new-value)
290             `(progn (rplacd ,cons ,new-value) ,new-value)
291             `(cdr ,cons))))
292
293
294 ;; The NCONC function is based on the SBCL's one.
295 (defun nconc (&rest lists)
296   (flet ((fail (object)
297            (error "type-error in nconc")))
298     (do ((top lists (cdr top)))
299         ((null top) nil)
300       (let ((top-of-top (car top)))
301         (typecase top-of-top
302           (cons
303            (let* ((result top-of-top)
304                   (splice result))
305              (do ((elements (cdr top) (cdr elements)))
306                  ((endp elements))
307                (let ((ele (car elements)))
308                  (typecase ele
309                    (cons (rplacd (last splice) ele)
310                          (setf splice ele))
311                    (null (rplacd (last splice) nil))
312                    (atom (if (cdr elements)
313                              (fail ele)
314                              (rplacd (last splice) ele))))))
315              (return result)))
316           (null)
317           (atom
318            (if (cdr top)
319                (fail top-of-top)
320                (return top-of-top))))))))
321
322
323 (defun nreconc (x y)
324   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
325        (2nd x 1st)                ; 2nd follows first down the list.
326        (3rd y 2nd))               ;3rd follows 2nd down the list.
327       ((atom 2nd) 3rd)
328     (rplacd 2nd 3rd)))
329
330
331 (defun adjoin (item list &key (test #'eql) (key #'identity))
332   (if (member item list :key key :test test)
333     list
334     (cons item list)))
335
336 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
337   (let ((new-list ()))
338     (dolist (x list1)
339       (when (member (funcall key x) list2 :test test :key key)
340         (push x new-list)))
341     new-list))