--- /dev/null
+;;; list.lisp ---
+
+;; This program 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
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;;; Various list functions
+
+
+;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
+(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 caaaar (x) (car (caaar x)))
+(defun caaadr (x) (car (caadr x)))
+(defun caadar (x) (car (cadar x)))
+(defun caaddr (x) (car (caddr x)))
+(defun cadaar (x) (car (cdaar x)))
+(defun cadadr (x) (car (cdadr x)))
+(defun caddar (x) (car (cddar x)))
+(defun cdaaar (x) (cdr (caaar x)))
+(defun cdaadr (x) (cdr (caadr x)))
+(defun cdadar (x) (cdr (cadar x)))
+(defun cdaddr (x) (cdr (caddr x)))
+(defun cddaar (x) (cdr (cdaar x)))
+(defun cddadr (x) (cdr (cdadr x)))
+(defun cdddar (x) (cdr (cddar x)))
+(defun cddddr (x) (cdr (cdddr x)))
+
+
+(defun copy-tree (tree)
+ (if (consp tree)
+ (cons (copy-tree (car tree))
+ (copy-tree (cdr tree)))
+ tree))
+
+(defun subst (new old tree &key (key #'identity) (test #'eql))
+ (cond
+ ((funcall test (funcall key tree) (funcall key old))
+ new)
+ ((consp tree)
+ (cons (subst new old (car tree) :key key :test test)
+ (subst new old (cdr tree) :key key :test test)))
+ (t tree)))
+
+(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)))))
(values-list /))
(export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
- +++ - / // /// 1+ 1- < <= = = > >= and append apply aref
- arrayp assoc atom block boundp butlast caar cadddr caddr
+ +++ - / // /// 1+ 1- < <= = = > >= and append apply aref arrayp
+ assoc atom block boundp butlast cadar caaar caadr cdaar cdadr
+ cddar caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caar cadddr caddr
cadr car car case catch cdar cdddr cddr cdr cdr char
char-code char= code-char cond cons consp constantly
- copy-list decf declaim defconstant define-setf-expander
+ copy-list copy-tree decf declaim defconstant define-setf-expander
define-symbol-macro defmacro defparameter defun defvar
digit-char digit-char-p disassemble do do* documentation
dolist dotimes ecase eq eql equal error eval every export expt
make-symbol mapcar member minusp mod multiple-value-bind
multiple-value-call multiple-value-list multiple-value-prog1
nconc nil not nreconc nth nthcdr null numberp or
- package-name package-use-list packagep parse-integer plusp
+ package-name package-use-list packagep parse-integer plusp pop
prin1-to-string print proclaim prog1 prog2 progn psetq push
quote read-from-string remove remove-if remove-if-not return
return-from revappend reverse rplaca rplacd second set setf
- setq some string string-upcase string= stringp subseq
+ setq some string string-upcase string= stringp subseq subst
symbol-function symbol-name symbol-package symbol-plist
symbol-value symbolp t tagbody third throw truncate unless
unwind-protect values values-list variable warn when write-line
--- /dev/null
+;; Tests for list functions
+
+;; TODO: EQUAL doesn't compare lists correctly at the moment.
+;; Once it does the lists can be compared directly in many of these tests
+
+; COPY-TREE
+(test (let* ((foo '((1 2) (3 4)))
+ (bar (copy-tree foo)))
+ ;; (SETF (CAR (CAR FOO)) 0) doesn't work in the test for some reason,
+ ;; despite working fine in the REPL
+ (rplaca (car foo) 0)
+ (not (= (car (car foo))
+ (car (car bar))))))
+
+; SUBST
+; Can't really test this until EQUAL works properly on lists
+
+; POP
+(test (let* ((foo '(1 2 3))
+ (bar (pop foo)))
+ (and (= bar 1)
+ (= (car foo) 2))))