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 (/debug "loading list.lisp!")
  17
  18 ;;;; Various list functions
  19
  20 (defun cons (x y) (cons x y))
  21 (defun consp (x) (consp x))
  22
  23 (defun listp (x)
  24   (or (consp x) (null x)))
  25
  26 (defun null (x)
  27   (eq x nil))
  28
  29 (defun endp (x)
  30   (if (null x)
  31       t
  32       (if (consp x)
  33           nil
  34           (error "The value `~S' is not a type list." x))))
  35
  36 (defun car (x)
  37   "Return the CAR part of a cons, or NIL if X is null."
  38   (car x))
  39
  40 (defun cdr (x) (cdr x))
  41
  42 (defun first   (x) (car    x))
  43 (defun second  (x) (cadr   x))
  44 (defun third   (x) (caddr  x))
  45 (defun fourth  (x) (cadddr x))
  46 (defun fifth   (x) (car    (cddddr x)))
  47 (defun sixth   (x) (cadr   (cddddr x)))
  48 (defun seventh (x) (caddr  (cddddr x)))
  49 (defun eighth  (x) (cadddr (cddddr x)))
  50 (defun ninth   (x) (car  (cddddr (cddddr x))))
  51 (defun tenth   (x) (cadr (cddddr (cddddr x))))
  52 (defun rest    (x) (cdr x))
  53
  54 (defun list (&rest args)
  55   args)
  56
  57 (defun list* (arg &rest others)
  58   (cond ((null others) arg)
  59         ((null (cdr others)) (cons arg (car others)))
  60         (t (do ((x others (cdr x)))
  61                ((null (cddr x)) (rplacd x (cadr x))))
  62            (cons arg others))))
  63
  64 (defun list-length (list)
  65   (let ((l 0))
  66     (while (not (null list))
  67       (incf l)
  68       (setq list (cdr list)))
  69     l))
  70
  71 (defun nthcdr (n list)
  72   (while (and (plusp n) list)
  73     (setq n (1- n))
  74     (setq list (cdr list)))
  75   list)
  76
  77 (defun nth (n list)
  78   (car (nthcdr n list)))
  79
  80 (define-setf-expander nth (n list)
  81   (let ((g!list (gensym))
  82         (g!index (gensym))
  83         (g!value (gensym)))
  84     (values (list g!list g!index)
  85             (list list n)
  86             (list g!value)
  87             `(rplaca (nthcdr ,g!index ,g!list) ,g!value)
  88             `(nth ,g!index ,g!list))))
  89
  90 (defun caar (x) (car (car x)))
  91 (defun cadr (x) (car (cdr x)))
  92 (defun cdar (x) (cdr (car x)))
  93 (defun cddr (x) (cdr (cdr x)))
  94
  95 (defun caaar (x) (car (caar x)))
  96 (defun caadr (x) (car (cadr x)))
  97 (defun cadar (x) (car (cdar x)))
  98 (defun caddr (x) (car (cddr x)))
  99 (defun cdaar (x) (cdr (caar x)))
 100 (defun cdadr (x) (cdr (cadr x)))
 101 (defun cddar (x) (cdr (cdar x)))
 102 (defun cdddr (x) (cdr (cddr x)))
 103
 104 (defun caaaar (x) (car (caaar x)))
 105 (defun caaadr (x) (car (caadr x)))
 106 (defun caadar (x) (car (cadar x)))
 107 (defun caaddr (x) (car (caddr x)))
 108 (defun cadaar (x) (car (cdaar x)))
 109 (defun cadadr (x) (car (cdadr x)))
 110 (defun caddar (x) (car (cddar x)))
 111 (defun cadddr (x) (car (cdddr x)))
 112 (defun cdaaar (x) (cdr (caaar x)))
 113 (defun cdaadr (x) (cdr (caadr x)))
 114 (defun cdadar (x) (cdr (cadar x)))
 115 (defun cdaddr (x) (cdr (caddr x)))
 116 (defun cddaar (x) (cdr (cdaar x)))
 117 (defun cddadr (x) (cdr (cdadr x)))
 118 (defun cdddar (x) (cdr (cddar x)))
 119 (defun cddddr (x) (cdr (cdddr x)))
 120
 121 (defun append-two (list1 list2)
 122   (if (null list1)
 123       list2
 124       (cons (car list1)
 125             (append (cdr list1) list2))))
 126
 127 (defun append (&rest lists)
 128   (!reduce #'append-two lists nil))
 129
 130 (defun revappend (list1 list2)
 131   (while list1
 132     (push (car list1) list2)
 133     (setq list1 (cdr list1)))
 134   list2)
 135
 136 (defun reverse (list)
 137   (revappend list '()))
 138
 139 (defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
 140   (when (and testp test-not-p)
 141     (error "Both test and test-not are set"))
 142   (labels ((s (tree)
 143              (let* ((key-val (if key (funcall key tree) tree))
 144                     (replace (if test-not-p
 145                                  (assoc key-val alist :test-not test-not)
 146                                  (assoc key-val alist :test test)))
 147                     (x (if replace (cdr replace) tree)))
 148                (if (atom x)
 149                    x
 150                    (cons (s (car x)) (s (cdr x)))))))
 151     (s tree)))
 152
 153 (defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
 154   (labels ((s (x)
 155              (cond ((satisfies-test-p old x :key key :test test :testp testp
 156                                       :test-not test-not :test-not-p test-not-p)
 157                     new)
 158                    ((atom x) x)
 159                    (t (let ((a (s (car x)))
 160                             (b (s (cdr x))))
 161                         (if (and (eq a (car x))
 162                                  (eq b (cdr x)))
 163                             x
 164                             (cons a b)))))))
 165     (s tree)))
 166
 167 (defun copy-list (x)
 168   (mapcar #'identity x))
 169
 170 (defun copy-tree (tree)
 171   (if (consp tree)
 172     (cons (copy-tree (car tree))
 173           (copy-tree (cdr tree)))
 174     tree))
 175
 176 (defun tree-equal (tree1 tree2 &key (test #'eql testp)
 177                          (test-not #'eql test-not-p))
 178   (when (and testp test-not-p) (error "Both test and test-not are set"))
 179   (let ((func (if test-not-p (complement test-not) test)))
 180     (labels ((%tree-equal (tree1 tree2)
 181                (if (atom tree1)
 182                  (and (atom tree2) (funcall func tree1 tree2))
 183                  (and (consp tree2)
 184                       (%tree-equal (car tree1) (car tree2))
 185                       (%tree-equal (cdr tree1) (cdr tree2))))))
 186       (%tree-equal tree1 tree2))))
 187
 188 (defun tailp (object list)
 189   (do ((tail list (cdr tail)))
 190     ((atom tail) (eq object tail))
 191     (when (eql tail object)
 192       (return-from tailp t))))
 193
 194 (defun map1 (func list)
 195   (with-collect
 196     (while list
 197       (collect (funcall func (car list)))
 198       (setq list (cdr list)))))
 199
 200 (defun mapcar (func list &rest lists)
 201   (let ((lists (cons list lists)))
 202     (with-collect
 203       (block loop
 204         (loop
 205            (let ((elems (map1 #'car lists)))
 206              (do ((tail lists (cdr tail)))
 207                  ((null tail))
 208                (when (null (car tail)) (return-from loop))
 209                (rplaca tail (cdar tail)))
 210              (collect (apply func elems))))))))
 211
 212 (defun mapn (func list)
 213   (with-collect
 214     (while list
 215       (collect (funcall func list))
 216       (setq list (cdr list)))))
 217
 218 (defun maplist (func list &rest lists)
 219   (let ((lists (cons list lists)))
 220     (with-collect
 221       (block loop
 222         (loop
 223            (let ((elems (mapn #'car lists)))
 224              (do ((tail lists (cdr tail)))
 225                  ((null tail))
 226                (when (null (car tail)) (return-from loop))
 227                (rplaca tail (cdar tail)))
 228              (collect (apply func elems))))))))
 229
 230 (defun mapc (func &rest lists)
 231   (do* ((tails lists (map1 #'cdr tails))
 232         (elems (map1 #'car tails)
 233                (map1 #'car tails)))
 234        ((dolist (x tails) (when (null x) (return t)))
 235         (car lists))
 236     (apply func elems)))
 237
 238 (defun last (x)
 239   (while (consp (cdr x))
 240     (setq x (cdr x)))
 241   x)
 242
 243 (defun butlast (x)
 244   (and (consp (cdr x))
 245        (cons (car x) (butlast (cdr x)))))
 246
 247 (defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
 248   (while list
 249     (when (satisfies-test-p x (car list) :key key :test test :testp testp
 250                             :test-not test-not :test-not-p test-not-p)
 251       (return list))
 252     (setq list (cdr list))))
 253
 254
 255 (defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
 256   (while alist
 257     (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
 258                           :test-not test-not :test-not-p test-not-p)
 259       (return)
 260       (setq alist (cdr alist))))
 261   (car alist))
 262
 263 (defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
 264                  (test-not #'eql test-not-p))
 265   (while alist
 266     (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
 267                           :test-not test-not :test-not-p test-not-p)
 268       (return)
 269       (setq alist (cdr alist))))
 270   (car alist))
 271
 272 (defun acons (key datum alist)
 273   (cons (cons key datum) alist))
 274
 275 (defun pairlis (keys data &optional (alist ()))
 276   (while keys
 277     (setq alist (acons (car keys) (car data) alist))
 278     (setq keys (cdr keys))
 279     (setq data (cdr data)))
 280   alist)
 281
 282 (defun copy-alist (alist)
 283   (let ((new-alist ()))
 284     (while alist
 285       (push (cons (caar alist) (cdar alist)) new-alist)
 286       (setq alist (cdr alist)))
 287     (reverse new-alist)))
 288
 289
 290 (define-setf-expander car (x)
 291   (let ((cons (gensym))
 292         (new-value (gensym)))
 293     (values (list cons)
 294             (list x)
 295             (list new-value)
 296             `(progn (rplaca ,cons ,new-value) ,new-value)
 297             `(car ,cons))))
 298
 299 (define-setf-expander cdr (x)
 300   (let ((cons (gensym))
 301         (new-value (gensym)))
 302     (values (list cons)
 303             (list x)
 304             (list new-value)
 305             `(progn (rplacd ,cons ,new-value) ,new-value)
 306             `(cdr ,cons))))
 307
 308
 309 ;; The NCONC function is based on the SBCL's one.
 310 (defun nconc (&rest lists)
 311   (flet ((fail (object)
 312            (error "type-error in nconc")))
 313     (do ((top lists (cdr top)))
 314         ((null top) nil)
 315       (let ((top-of-top (car top)))
 316         (typecase top-of-top
 317           (cons
 318            (let* ((result top-of-top)
 319                   (splice result))
 320              (do ((elements (cdr top) (cdr elements)))
 321                  ((endp elements))
 322                (let ((ele (car elements)))
 323                  (typecase ele
 324                    (cons (rplacd (last splice) ele)
 325                          (setf splice ele))
 326                    (null (rplacd (last splice) nil))
 327                    (atom (if (cdr elements)
 328                              (fail ele)
 329                              (rplacd (last splice) ele))))))
 330              (return result)))
 331           (null)
 332           (atom
 333            (if (cdr top)
 334                (fail top-of-top)
 335                (return top-of-top))))))))
 336
 337
 338 (defun nreconc (x y)
 339   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 340        (2nd x 1st)                ; 2nd follows first down the list.
 341        (3rd y 2nd))               ;3rd follows 2nd down the list.
 342       ((atom 2nd) 3rd)
 343     (rplacd 2nd 3rd)))
 344
 345
 346 (defun adjoin (item list &key (test #'eql) (key #'identity))
 347   (if (member item list :key key :test test)
 348     list
 349     (cons item list)))
 350
 351 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
 352   (let ((new-list ()))
 353     (dolist (x list1)
 354       (when (member (funcall key x) list2 :test test :key key)
 355         (push x new-list)))
 356     new-list))