src/list.lisp

   1 ;;; list.lisp ---
   2
   3 ;; This program 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 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 ;;;; Various list functions
  17
  18
  19 ;;; The rest of the C[AD]*R functions; only a few were defined in boot.lisp
  20 (defun cadar  (x) (car (cdar  x)))
  21 (defun caaar  (x) (car (caar  x)))
  22 (defun caadr  (x) (car (cadr  x)))
  23 (defun cdaar  (x) (cdr (caar  x)))
  24 (defun cdadr  (x) (cdr (cadr  x)))
  25 (defun cddar  (x) (cdr (cdar  x)))
  26 (defun caaaar (x) (car (caaar x)))
  27 (defun caaadr (x) (car (caadr x)))
  28 (defun caadar (x) (car (cadar x)))
  29 (defun caaddr (x) (car (caddr x)))
  30 (defun cadaar (x) (car (cdaar x)))
  31 (defun cadadr (x) (car (cdadr x)))
  32 (defun caddar (x) (car (cddar x)))
  33 (defun cdaaar (x) (cdr (caaar x)))
  34 (defun cdaadr (x) (cdr (caadr x)))
  35 (defun cdadar (x) (cdr (cadar x)))
  36 (defun cdaddr (x) (cdr (caddr x)))
  37 (defun cddaar (x) (cdr (cdaar x)))
  38 (defun cddadr (x) (cdr (cdadr x)))
  39 (defun cdddar (x) (cdr (cddar x)))
  40 (defun cddddr (x) (cdr (cdddr x)))
  41
  42
  43 (defun copy-tree (tree)
  44   (if (consp tree)
  45     (cons (copy-tree (car tree))
  46           (copy-tree (cdr tree)))
  47     tree))
  48
  49 (defun subst (new old tree &key (key #'identity) (test #'eql))
  50   (cond
  51     ((funcall test (funcall key tree) (funcall key old))
  52      new)
  53     ((consp tree)
  54      (cons (subst new old (car tree) :key key :test test)
  55            (subst new old (cdr tree) :key key :test test)))
  56     (t tree)))
  57
  58 (defmacro pop (place)
  59   (multiple-value-bind (dummies vals newval setter getter)
  60     (get-setf-expansion place)
  61     (let ((head (gensym)))
  62       `(let* (,@(mapcar #'list dummies vals)
  63               (,head ,getter)
  64               (,(car newval) (cdr ,head))
  65               ,@(cdr newval))
  66          ,setter
  67          (car ,head)))))