Remove references to non-symbol literals
[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 rest (x) (cdr x))
45
46 (defun list (&rest args)
47   args)
48
49 (defun list* (arg &rest others)
50   (cond ((null others) arg)
51         ((null (cdr others)) (cons arg (car others)))
52         (t (do ((x others (cdr x)))
53                ((null (cddr x)) (rplacd x (cadr x))))
54            (cons arg others))))
55
56 (defun nthcdr (n list)
57   (while (and (plusp n) list)
58     (setq n (1- n))
59     (setq list (cdr list)))
60   list)
61
62 (defun nth (n list)
63   (car (nthcdr n list)))
64
65 ;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
66 (defun caar (x) (car (car x)))
67 (defun cadr (x) (car (cdr x)))
68 (defun cdar (x) (cdr (car x)))
69 (defun cddr (x) (cdr (cdr x)))
70 (defun cadar (x) (car (cdr (car x))))
71 (defun caddr (x) (car (cdr (cdr x))))
72 (defun cdddr (x) (cdr (cdr (cdr x))))
73 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
74
75 (defun cadar  (x) (car (cdar  x)))
76 (defun caaar  (x) (car (caar  x)))
77 (defun caadr  (x) (car (cadr  x)))
78 (defun cdaar  (x) (cdr (caar  x)))
79 (defun cdadr  (x) (cdr (cadr  x)))
80 (defun cddar  (x) (cdr (cdar  x)))
81 (defun caaaar (x) (car (caaar x)))
82 (defun caaadr (x) (car (caadr x)))
83 (defun caadar (x) (car (cadar x)))
84 (defun caaddr (x) (car (caddr x)))
85 (defun cadaar (x) (car (cdaar x)))
86 (defun cadadr (x) (car (cdadr x)))
87 (defun caddar (x) (car (cddar x)))
88 (defun cdaaar (x) (cdr (caaar x)))
89 (defun cdaadr (x) (cdr (caadr x)))
90 (defun cdadar (x) (cdr (cadar x)))
91 (defun cdaddr (x) (cdr (caddr x)))
92 (defun cddaar (x) (cdr (cdaar x)))
93 (defun cddadr (x) (cdr (cdadr x)))
94 (defun cdddar (x) (cdr (cddar x)))
95 (defun cddddr (x) (cdr (cdddr x)))
96
97
98 (defun copy-list (x)
99   (mapcar #'identity x))
100
101 (defun copy-tree (tree)
102   (if (consp tree)
103     (cons (copy-tree (car tree))
104           (copy-tree (cdr tree)))
105     tree))
106
107 (defun subst (new old tree &key (key #'identity) (test #'eql))
108   (cond 
109     ((funcall test (funcall key tree) (funcall key old))
110      new) 
111     ((consp tree)
112      (cons (subst new old (car tree) :key key :test test)
113            (subst new old (cdr tree) :key key :test test))) 
114     (t tree)))
115
116 (defmacro pop (place)
117   (multiple-value-bind (dummies vals newval setter getter)
118     (get-setf-expansion place)
119     (let ((head (gensym)))
120       `(let* (,@(mapcar #'list dummies vals) 
121               (,head ,getter)
122               (,(car newval) (cdr ,head))
123               ,@(cdr newval)) 
124          ,setter
125          (car ,head)))))
126
127
128 (defun map1 (func list)
129   (with-collect
130     (while list
131       (collect (funcall func (car list)))
132       (setq list (cdr list)))))
133
134 (defun mapcar (func list &rest lists)
135   (let ((lists (cons list lists)))
136     (with-collect
137       (block loop
138         (loop
139            (let ((elems (map1 #'car lists)))
140              (do ((tail lists (cdr tail)))
141                  ((null tail))
142                (when (null (car tail)) (return-from loop))
143                (rplaca tail (cdar tail)))
144              (collect (apply func elems))))))))
145
146 (defun last (x)
147   (while (consp (cdr x))
148     (setq x (cdr x)))
149   x)
150
151 (defun butlast (x)
152   (and (consp (cdr x))
153        (cons (car x) (butlast (cdr x)))))
154
155 (defun member (x list)
156   (while list
157     (when (eql x (car list))
158       (return list))
159     (setq list (cdr list))))
160
161
162 (defun assoc (x alist &key (test #'eql))
163   (while alist
164     (if (funcall test x (caar alist))
165         (return)
166         (setq alist (cdr alist))))
167   (car alist))
168
169
170
171 (define-setf-expander car (x)
172   (let ((cons (gensym))
173         (new-value (gensym)))
174     (values (list cons)
175             (list x)
176             (list new-value)
177             `(progn (rplaca ,cons ,new-value) ,new-value)
178             `(car ,cons))))
179
180 (define-setf-expander cdr (x)
181   (let ((cons (gensym))
182         (new-value (gensym)))
183     (values (list cons)
184             (list x)
185             (list new-value)
186             `(progn (rplacd ,cons ,new-value) ,new-value)
187             `(car ,cons))))
188
189
190 ;; The NCONC function is based on the SBCL's one.
191 (defun nconc (&rest lists)
192   (flet ((fail (object)
193            (error "type-error in nconc")))
194     (do ((top lists (cdr top)))
195         ((null top) nil)
196       (let ((top-of-top (car top)))
197         (typecase top-of-top
198           (cons
199            (let* ((result top-of-top)
200                   (splice result))
201              (do ((elements (cdr top) (cdr elements)))
202                  ((endp elements))
203                (let ((ele (car elements)))
204                  (typecase ele
205                    (cons (rplacd (last splice) ele)
206                          (setf splice ele))
207                    (null (rplacd (last splice) nil))
208                    (atom (if (cdr elements)
209                              (fail ele)
210                              (rplacd (last splice) ele))))))
211              (return result)))
212           (null)
213           (atom
214            (if (cdr top)
215                (fail top-of-top)
216                (return top-of-top))))))))
217
218
219 (defun nreconc (x y)
220   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
221        (2nd x 1st)                ; 2nd follows first down the list.
222        (3rd y 2nd))               ;3rd follows 2nd down the list.
223       ((atom 2nd) 3rd)
224     (rplacd 2nd 3rd)))