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 (defun caar (x) (car (car x)))
  72 (defun cadr (x) (car (cdr x)))
  73 (defun cdar (x) (cdr (car x)))
  74 (defun cddr (x) (cdr (cdr x)))
  75
  76 (defun caaar (x) (car (caar x)))
  77 (defun caadr (x) (car (cadr x)))
  78 (defun cadar (x) (car (cdar x)))
  79 (defun caddr (x) (car (cddr x)))
  80 (defun cdaar (x) (cdr (caar x)))
  81 (defun cdadr (x) (cdr (cadr x)))
  82 (defun cddar (x) (cdr (cdar x)))
  83 (defun cdddr (x) (cdr (cddr x)))
  84
  85 (defun caaaar (x) (car (caaar x)))
  86 (defun caaadr (x) (car (caadr x)))
  87 (defun caadar (x) (car (cadar x)))
  88 (defun caaddr (x) (car (caddr x)))
  89 (defun cadaar (x) (car (cdaar x)))
  90 (defun cadadr (x) (car (cdadr x)))
  91 (defun caddar (x) (car (cddar x)))
  92 (defun cadddr (x) (car (cdddr x)))
  93 (defun cdaaar (x) (cdr (caaar x)))
  94 (defun cdaadr (x) (cdr (caadr x)))
  95 (defun cdadar (x) (cdr (cadar x)))
  96 (defun cdaddr (x) (cdr (caddr x)))
  97 (defun cddaar (x) (cdr (cdaar x)))
  98 (defun cddadr (x) (cdr (cdadr x)))
  99 (defun cdddar (x) (cdr (cddar x)))
 100 (defun cddddr (x) (cdr (cdddr x)))
 101
 102 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
 103   (labels ((s (tree)
 104              (when (and testp test-not-p)
 105                (error "Both test and test-not are set"))
 106              (let* ((key-val (if key (funcall key tree) tree))
 107                     (replace (if test-not-p
 108                                  (assoc key-val alist :test-not test-not)
 109                                  (assoc key-val alist :test test)))
 110                     (x (if replace (cdr replace) tree)))
 111                (if (atom x)
 112                    x
 113                    (cons (s (car x)) (s (cdr x)))))))
 114     (s tree)))
 115
 116 (defun copy-list (x)
 117   (mapcar #'identity x))
 118
 119 (defun copy-tree (tree)
 120   (if (consp tree)
 121     (cons (copy-tree (car tree))
 122           (copy-tree (cdr tree)))
 123     tree))
 124
 125 (defun tree-equal (tree1 tree2 &key (test #'eql))
 126   (if (atom tree1)
 127     (and (atom tree2) (funcall test tree1 tree2))
 128     (and (consp tree2)
 129          (tree-equal (car tree1) (car tree2) :test test)
 130          (tree-equal (cdr tree1) (cdr tree2) :test test))))
 131
 132 (defun tailp (object list)
 133   (do ((tail list (cdr tail)))
 134     ((atom tail) (eq object tail))
 135     (when (eql tail object)
 136       (return-from tailp t))))
 137
 138 (defun subst (new old tree &key (key #'identity) (test #'eql))
 139   (cond
 140     ((funcall test (funcall key tree) (funcall key old))
 141      new)
 142     ((consp tree)
 143      (cons (subst new old (car tree) :key key :test test)
 144            (subst new old (cdr tree) :key key :test test)))
 145     (t tree)))
 146
 147 (defmacro pop (place)
 148   (multiple-value-bind (dummies vals newval setter getter)
 149     (get-setf-expansion place)
 150     (let ((head (gensym)))
 151       `(let* (,@(mapcar #'list dummies vals)
 152               (,head ,getter)
 153               (,(car newval) (cdr ,head))
 154               ,@(cdr newval))
 155          ,setter
 156          (car ,head)))))
 157
 158
 159 (defun map1 (func list)
 160   (with-collect
 161     (while list
 162       (collect (funcall func (car list)))
 163       (setq list (cdr list)))))
 164
 165 (defun mapcar (func list &rest lists)
 166   (let ((lists (cons list lists)))
 167     (with-collect
 168       (block loop
 169         (loop
 170            (let ((elems (map1 #'car lists)))
 171              (do ((tail lists (cdr tail)))
 172                  ((null tail))
 173                (when (null (car tail)) (return-from loop))
 174                (rplaca tail (cdar tail)))
 175              (collect (apply func elems))))))))
 176
 177 (defun mapc (func &rest lists)
 178   (do* ((elems (map1 #'car lists) (map1 #'car lists-rest))
 179         (lists-rest (map1 #'cdr lists) (map1 #'cdr lists-rest)))
 180        ((dolist (x elems) (when (null x) (return t)))
 181         (car lists))
 182     (apply func elems)))
 183
 184 (defun last (x)
 185   (while (consp (cdr x))
 186     (setq x (cdr x)))
 187   x)
 188
 189 (defun butlast (x)
 190   (and (consp (cdr x))
 191        (cons (car x) (butlast (cdr x)))))
 192
 193 (defun member (x list &key (key #'identity) (test #'eql))
 194   (while list
 195     (when (funcall test x (funcall key (car list)))
 196       (return list))
 197     (setq list (cdr list))))
 198
 199
 200 (defun assoc (x alist &key (test #'eql))
 201   (while alist
 202     (if (funcall test x (caar alist))
 203       (return)
 204       (setq alist (cdr alist))))
 205   (car alist))
 206
 207 (defun rassoc (x alist &key (test #'eql))
 208   (while alist
 209     (if (funcall test x (cdar alist))
 210       (return)
 211       (setq alist (cdr alist))))
 212   (car alist))
 213
 214 (defun acons (key datum alist)
 215   (cons (cons key datum) alist))
 216
 217 (defun pairlis (keys data &optional (alist ()))
 218   (while keys
 219     (setq alist (acons (car keys) (car data) alist))
 220     (setq keys (cdr keys))
 221     (setq data (cdr data)))
 222   alist)
 223
 224 (defun copy-alist (alist)
 225   (let ((new-alist ()))
 226     (while alist
 227       (push (cons (caar alist) (cdar alist)) new-alist)
 228       (setq alist (cdr alist)))
 229     (reverse new-alist)))
 230
 231
 232 (define-setf-expander car (x)
 233   (let ((cons (gensym))
 234         (new-value (gensym)))
 235     (values (list cons)
 236             (list x)
 237             (list new-value)
 238             `(progn (rplaca ,cons ,new-value) ,new-value)
 239             `(car ,cons))))
 240
 241 (define-setf-expander cdr (x)
 242   (let ((cons (gensym))
 243         (new-value (gensym)))
 244     (values (list cons)
 245             (list x)
 246             (list new-value)
 247             `(progn (rplacd ,cons ,new-value) ,new-value)
 248             `(car ,cons))))
 249
 250
 251 ;; The NCONC function is based on the SBCL's one.
 252 (defun nconc (&rest lists)
 253   (flet ((fail (object)
 254            (error "type-error in nconc")))
 255     (do ((top lists (cdr top)))
 256         ((null top) nil)
 257       (let ((top-of-top (car top)))
 258         (typecase top-of-top
 259           (cons
 260            (let* ((result top-of-top)
 261                   (splice result))
 262              (do ((elements (cdr top) (cdr elements)))
 263                  ((endp elements))
 264                (let ((ele (car elements)))
 265                  (typecase ele
 266                    (cons (rplacd (last splice) ele)
 267                          (setf splice ele))
 268                    (null (rplacd (last splice) nil))
 269                    (atom (if (cdr elements)
 270                              (fail ele)
 271                              (rplacd (last splice) ele))))))
 272              (return result)))
 273           (null)
 274           (atom
 275            (if (cdr top)
 276                (fail top-of-top)
 277                (return top-of-top))))))))
 278
 279
 280 (defun nreconc (x y)
 281   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 282        (2nd x 1st)                ; 2nd follows first down the list.
 283        (3rd y 2nd))               ;3rd follows 2nd down the list.
 284       ((atom 2nd) 3rd)
 285     (rplacd 2nd 3rd)))
 286
 287
 288 (defun adjoin (item list &key (test #'eql) (key #'identity))
 289   (if (member item list :key key :test test)
 290     list
 291     (cons item list)))
 292
 293 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
 294   (let ((new-list ()))
 295     (dolist (x list1)
 296       (when (member x list2 :test test :key key)
 297         (push x new-list)))
 298     new-list))