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.
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.
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/>.
16 (/debug "loading list.lisp!")
18 ;;;; Various list functions
20 (defun cons (x y) (cons x y))
21 (defun consp (x) (consp x))
24 (or (consp x) (null x)))
34 (error "The value `~S' is not a type list." x))))
37 "Return the CAR part of a cons, or NIL if X is null."
40 (defun cdr (x) (cdr x))
42 (defun rplaca (cons x)
45 (defun rplacd (cons x)
48 (defun first (x) (car x))
49 (defun second (x) (cadr x))
50 (defun third (x) (caddr x))
51 (defun fourth (x) (cadddr x))
52 (defun fifth (x) (car (cddddr x)))
53 (defun sixth (x) (cadr (cddddr x)))
54 (defun seventh (x) (caddr (cddddr x)))
55 (defun eighth (x) (cadddr (cddddr x)))
56 (defun ninth (x) (car (cddddr (cddddr x))))
57 (defun tenth (x) (cadr (cddddr (cddddr x))))
58 (defun rest (x) (cdr x))
60 (defun list (&rest args)
63 (defun list* (arg &rest others)
64 (cond ((null others) arg)
65 ((null (cdr others)) (cons arg (car others)))
66 (t (do ((x others (cdr x)))
67 ((null (cddr x)) (rplacd x (cadr x))))
70 (defun list-length (list)
72 (while (not (null list))
74 (setq list (cdr list)))
77 (defun nthcdr (n list)
78 (while (and (plusp n) list)
80 (setq list (cdr list)))
84 (car (nthcdr n list)))
86 (define-setf-expander nth (n list)
87 (let ((g!list (gensym))
90 (values (list g!list g!index)
93 `(rplaca (nthcdr ,g!index ,g!list) ,g!value)
94 `(nth ,g!index ,g!list))))
96 (defun caar (x) (car (car x)))
97 (defun cadr (x) (car (cdr x)))
98 (defun cdar (x) (cdr (car x)))
99 (defun cddr (x) (cdr (cdr x)))
101 (defun caaar (x) (car (caar x)))
102 (defun caadr (x) (car (cadr x)))
103 (defun cadar (x) (car (cdar x)))
104 (defun caddr (x) (car (cddr x)))
105 (defun cdaar (x) (cdr (caar x)))
106 (defun cdadr (x) (cdr (cadr x)))
107 (defun cddar (x) (cdr (cdar x)))
108 (defun cdddr (x) (cdr (cddr x)))
110 (defun caaaar (x) (car (caaar x)))
111 (defun caaadr (x) (car (caadr x)))
112 (defun caadar (x) (car (cadar x)))
113 (defun caaddr (x) (car (caddr x)))
114 (defun cadaar (x) (car (cdaar x)))
115 (defun cadadr (x) (car (cdadr x)))
116 (defun caddar (x) (car (cddar x)))
117 (defun cadddr (x) (car (cdddr x)))
118 (defun cdaaar (x) (cdr (caaar x)))
119 (defun cdaadr (x) (cdr (caadr x)))
120 (defun cdadar (x) (cdr (cadar x)))
121 (defun cdaddr (x) (cdr (caddr x)))
122 (defun cddaar (x) (cdr (cdaar x)))
123 (defun cddadr (x) (cdr (cdadr x)))
124 (defun cdddar (x) (cdr (cddar x)))
125 (defun cddddr (x) (cdr (cdddr x)))
127 (defun append-two (list1 list2)
131 (append (cdr list1) list2))))
133 (defun append (&rest lists)
134 (!reduce #'append-two lists nil))
136 (defun revappend (list1 list2)
138 (push (car list1) list2)
139 (setq list1 (cdr list1)))
142 (defun reverse (list)
143 (revappend list '()))
145 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
146 (when (and testp test-not-p)
147 (error "Both test and test-not are set"))
149 (let* ((key-val (if key (funcall key tree) tree))
150 (replace (if test-not-p
151 (assoc key-val alist :test-not test-not)
152 (assoc key-val alist :test test)))
153 (x (if replace (cdr replace) tree)))
156 (cons (s (car x)) (s (cdr x)))))))
159 (defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
161 (cond ((satisfies-test-p old x :key key :test test :testp testp
162 :test-not test-not :test-not-p test-not-p)
165 (t (let ((a (s (car x)))
167 (if (and (eq a (car x))
174 (mapcar #'identity x))
176 (defun copy-tree (tree)
178 (cons (copy-tree (car tree))
179 (copy-tree (cdr tree)))
182 (defun tree-equal (tree1 tree2 &key (test #'eql testp)
183 (test-not #'eql test-not-p))
184 (when (and testp test-not-p) (error "Both test and test-not are set"))
185 (let ((func (if test-not-p (complement test-not) test)))
186 (labels ((%tree-equal (tree1 tree2)
188 (and (atom tree2) (funcall func tree1 tree2))
190 (%tree-equal (car tree1) (car tree2))
191 (%tree-equal (cdr tree1) (cdr tree2))))))
192 (%tree-equal tree1 tree2))))
194 (defun tailp (object list)
195 (do ((tail list (cdr tail)))
196 ((atom tail) (eq object tail))
197 (when (eql tail object)
198 (return-from tailp t))))
200 (defun make-list (size &key (initial-element nil))
201 "Create a list of size `size` of `initial-element`s."
203 (error "Size must be non-negative"))
205 (dotimes (i size newlist)
206 (push initial-element newlist))))
208 (defun map1 (func list)
211 (collect (funcall func (car list)))
212 (setq list (cdr list)))))
214 (defun mapcar (func list &rest lists)
215 (let ((lists (cons list lists)))
219 (let ((elems (map1 #'car lists)))
220 (do ((tail lists (cdr tail)))
222 (when (null (car tail)) (return-from loop))
223 (rplaca tail (cdar tail)))
224 (collect (apply func elems))))))))
226 (defun mapn (func list)
229 (collect (funcall func list))
230 (setq list (cdr list)))))
232 (defun maplist (func list &rest lists)
233 (let ((lists (cons list lists)))
237 (let ((elems (mapn #'car lists)))
238 (do ((tail lists (cdr tail)))
240 (when (null (car tail)) (return-from loop))
241 (rplaca tail (cdar tail)))
242 (collect (apply func elems))))))))
244 (defun mapc (func &rest lists)
245 (do* ((tails lists (map1 #'cdr tails))
246 (elems (map1 #'car tails)
248 ((dolist (x tails) (when (null x) (return t)))
253 (while (consp (cdr x))
257 (defun butlast (x &optional (n 1))
258 "Returns x, less the n last elements in the list."
259 (nbutlast (copy-list x) n))
261 (defun nbutlast (x &optional (n 1))
262 "Destructively returns x, less the n last elements in the list."
264 ((not (and (integerp n) (>= n 0)))
265 ;; TODO: turn this error into a type error, per CLHS spec.
266 (error "n must be a non-negative integer"))
267 ;; trivial optimizations
270 ;; O(n) walk of the linked list, trimming out the link where appropriate
272 (trailing (nthcdr n x)))
273 ;; If there are enough conses
274 (when (consp trailing)
275 (while (consp (cdr trailing))
276 (setq head (cdr head))
277 (setq trailing (cdr trailing)))
282 (defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
284 (when (satisfies-test-p x (car list) :key key :test test :testp testp
285 :test-not test-not :test-not-p test-not-p)
287 (setq list (cdr list))))
290 (defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
292 (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
293 :test-not test-not :test-not-p test-not-p)
295 (setq alist (cdr alist))))
298 (defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
299 (test-not #'eql test-not-p))
301 (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
302 :test-not test-not :test-not-p test-not-p)
304 (setq alist (cdr alist))))
307 (defun acons (key datum alist)
308 (cons (cons key datum) alist))
310 (defun pairlis (keys data &optional (alist ()))
312 (setq alist (acons (car keys) (car data) alist))
313 (setq keys (cdr keys))
314 (setq data (cdr data)))
317 (defun copy-alist (alist)
318 (let ((new-alist ()))
320 (push (cons (caar alist) (cdar alist)) new-alist)
321 (setq alist (cdr alist)))
322 (reverse new-alist)))
325 (define-setf-expander car (x)
326 (let ((cons (gensym))
327 (new-value (gensym)))
331 `(progn (rplaca ,cons ,new-value) ,new-value)
334 (define-setf-expander cdr (x)
335 (let ((cons (gensym))
336 (new-value (gensym)))
340 `(progn (rplacd ,cons ,new-value) ,new-value)
344 ;; The NCONC function is based on the SBCL's one.
345 (defun nconc (&rest lists)
346 (flet ((fail (object)
347 (error "type-error in nconc")))
348 (do ((top lists (cdr top)))
350 (let ((top-of-top (car top)))
353 (let* ((result top-of-top)
355 (do ((elements (cdr top) (cdr elements)))
357 (let ((ele (car elements)))
359 (cons (rplacd (last splice) ele)
361 (null (rplacd (last splice) nil))
362 (atom (if (cdr elements)
364 (rplacd (last splice) ele))))))
370 (return top-of-top))))))))
374 (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
375 (2nd x 1st) ; 2nd follows first down the list.
376 (3rd y 2nd)) ;3rd follows 2nd down the list.
381 (defun adjoin (item list &key (test #'eql) (key #'identity))
382 (if (member item list :key key :test test)
386 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
389 (when (member (funcall key x) list2 :test test :key key)
393 (defun get-properties (plist indicator-list)
394 (do* ((plist plist (cddr plist))
395 (cdr (cdr plist) (cdr plist))
396 (car (car plist) (car plist)))
397 ((null plist) (values nil nil nil))
399 (error "malformed property list ~S" plist))
400 (let ((found (member car indicator-list :test #'eq)))
402 (return (values car (cadr plist) plist))))))
404 (defun getf (plist indicator &optional default)
405 (do* ((plist plist (cddr plist))
406 (cdr (cdr plist) (cdr plist))
407 (car (car plist) (car plist)))
408 ((null plist) default)
410 (error "malformed property list ~S" plist))
411 (when (eq indicator car)
412 (return (cadr plist)))))
414 (defun %putf (plist indicator new-value)
415 (do* ((tail plist (cddr tail))
416 (cdr (cdr tail) (cdr tail))
417 (car (car tail) (car tail)))
418 ((null tail) (list* indicator new-value plist))
420 (error "malformed property list ~S" tail))
421 (when (eq indicator car)
422 ;; TODO: should be cadr, needs a defsetf for that
423 (setf (car (cdr tail)) new-value)
426 (define-setf-expander getf (plist indicator &optional default)
427 (multiple-value-bind (dummies vals newval setter getter)
428 (get-setf-expansion plist)
429 (let ((store (gensym))
430 (indicator-sym (gensym))
431 (default-sym (and default (gensym))))
432 (values `(,indicator-sym ,@(and default `(,default-sym)) ,@dummies)
433 `(,indicator ,@(and default `(,default)) ,@vals)
435 `(let ((,(car newval) (%putf ,getter ,indicator-sym ,store))
439 `(getf ,getter ,indicator-sym ,@(and default `(,default-sym)))))))