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 rplaca (cons x)
  43   (rplaca cons x))
  44
  45 (defun rplacd (cons x)
  46   (rplacd cons x))
  47
  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))
  59
  60 (defun list (&rest args)
  61   args)
  62
  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))))
  68            (cons arg others))))
  69
  70 (defun list-length (list)
  71   (let ((l 0))
  72     (while (not (null list))
  73       (incf l)
  74       (setq list (cdr list)))
  75     l))
  76
  77 (defun nthcdr (n list)
  78   (while (and (plusp n) list)
  79     (setq n (1- n))
  80     (setq list (cdr list)))
  81   list)
  82
  83 (defun nth (n list)
  84   (car (nthcdr n list)))
  85
  86 (define-setf-expander nth (n list)
  87   (let ((g!list (gensym))
  88         (g!index (gensym))
  89         (g!value (gensym)))
  90     (values (list g!list g!index)
  91             (list list n)
  92             (list g!value)
  93             `(rplaca (nthcdr ,g!index ,g!list) ,g!value)
  94             `(nth ,g!index ,g!list))))
  95
  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)))
 100
 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)))
 109
 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)))
 126
 127 (defun append-two (list1 list2)
 128   (if (null list1)
 129       list2
 130       (cons (car list1)
 131             (append (cdr list1) list2))))
 132
 133 (defun append (&rest lists)
 134   (!reduce #'append-two lists nil))
 135
 136 (defun revappend (list1 list2)
 137   (while list1
 138     (push (car list1) list2)
 139     (setq list1 (cdr list1)))
 140   list2)
 141
 142 (defun reverse (list)
 143   (revappend list '()))
 144
 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"))
 148   (labels ((s (tree)
 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)))
 154                (if (atom x)
 155                    x
 156                    (cons (s (car x)) (s (cdr x)))))))
 157     (s tree)))
 158
 159 (defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
 160   (labels ((s (x)
 161              (cond ((satisfies-test-p old x :key key :test test :testp testp
 162                                       :test-not test-not :test-not-p test-not-p)
 163                     new)
 164                    ((atom x) x)
 165                    (t (let ((a (s (car x)))
 166                             (b (s (cdr x))))
 167                         (if (and (eq a (car x))
 168                                  (eq b (cdr x)))
 169                             x
 170                             (cons a b)))))))
 171     (s tree)))
 172
 173 (defun copy-list (x)
 174   (mapcar #'identity x))
 175
 176 (defun copy-tree (tree)
 177   (if (consp tree)
 178     (cons (copy-tree (car tree))
 179           (copy-tree (cdr tree)))
 180     tree))
 181
 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)
 187                (if (atom tree1)
 188                  (and (atom tree2) (funcall func tree1 tree2))
 189                  (and (consp tree2)
 190                       (%tree-equal (car tree1) (car tree2))
 191                       (%tree-equal (cdr tree1) (cdr tree2))))))
 192       (%tree-equal tree1 tree2))))
 193
 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))))
 199
 200 (defun make-list (size &key (initial-element nil))
 201   "Create a list of size `size` of `initial-element`s."
 202   (when (< size 0)
 203     (error "Size must be non-negative"))
 204   (let ((newlist))
 205     (dotimes (i size newlist)
 206       (push initial-element newlist))))
 207
 208 (defun map1 (func list)
 209   (with-collect
 210     (while list
 211       (collect (funcall func (car list)))
 212       (setq list (cdr list)))))
 213
 214 (defun mapcar (func list &rest lists)
 215   (let ((lists (cons list lists)))
 216     (with-collect
 217       (block loop
 218         (loop
 219            (let ((elems (map1 #'car lists)))
 220              (do ((tail lists (cdr tail)))
 221                  ((null tail))
 222                (when (null (car tail)) (return-from loop))
 223                (rplaca tail (cdar tail)))
 224              (collect (apply func elems))))))))
 225
 226 (defun mapn (func list)
 227   (with-collect
 228     (while list
 229       (collect (funcall func list))
 230       (setq list (cdr list)))))
 231
 232 (defun maplist (func list &rest lists)
 233   (let ((lists (cons list lists)))
 234     (with-collect
 235       (block loop
 236         (loop
 237            (let ((elems (mapn #'car lists)))
 238              (do ((tail lists (cdr tail)))
 239                  ((null tail))
 240                (when (null (car tail)) (return-from loop))
 241                (rplaca tail (cdar tail)))
 242              (collect (apply func elems))))))))
 243
 244 (defun mapc (func &rest lists)
 245   (do* ((tails lists (map1 #'cdr tails))
 246         (elems (map1 #'car tails)
 247                (map1 #'car tails)))
 248        ((dolist (x tails) (when (null x) (return t)))
 249         (car lists))
 250     (apply func elems)))
 251
 252 (defun last (x)
 253   (while (consp (cdr x))
 254     (setq x (cdr x)))
 255   x)
 256
 257 (defun butlast (x &optional (n 1))
 258   "Returns x, less the n last elements in the list."
 259   (nbutlast (copy-list x) n))
 260
 261 (defun nbutlast (x &optional (n 1))
 262   "Destructively returns x, less the n last elements in the list."
 263   (cond
 264     ((not (and (integerp n)
 265                (>= n 0)))
 266      ;; TODO: turn this error into a type error, per CLHS spec.
 267      (error "n must be a non-negative integer"))
 268
 269     ;; trivial optimizations
 270     ((zerop n) x)
 271
 272     (t
 273      ;; O(n) walk of the linked list, trimming out the link where appropriate
 274      (let*
 275          ((head x)
 276           (trailing x))
 277
 278        ;; find n in...
 279        (do ((i 0 (1+ i)))
 280            ((or ( >= i (1- n))
 281                 (not head)
 282                 (not (consp (cdr head)))))
 283          (setf head (cdr head)))
 284
 285        (when (consp (cdr head))
 286
 287        (setf trailing x)
 288        (setf head (cdr head))
 289
 290        ;; walk until the end
 291        (do ()
 292            ((or
 293              (not (consp head))
 294              (not (cdr head))))
 295
 296          (setf head (cdr head))
 297          (setf trailing (cdr trailing)))
 298
 299        ;; snip
 300        (rplacd trailing nil)
 301
 302        x)))))
 303
 304 (defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
 305   (while list
 306     (when (satisfies-test-p x (car list) :key key :test test :testp testp
 307                             :test-not test-not :test-not-p test-not-p)
 308       (return list))
 309     (setq list (cdr list))))
 310
 311
 312 (defun assoc (x alist &key key (test #'eql testp) (test-not #'eql test-not-p))
 313   (while alist
 314     (if (satisfies-test-p x (caar alist) :key key :test test :testp testp
 315                           :test-not test-not :test-not-p test-not-p)
 316       (return)
 317       (setq alist (cdr alist))))
 318   (car alist))
 319
 320 (defun rassoc (x alist &key key (test #'eql) (test #'eql testp)
 321                  (test-not #'eql test-not-p))
 322   (while alist
 323     (if (satisfies-test-p x (cdar alist) :key key :test test :testp testp
 324                           :test-not test-not :test-not-p test-not-p)
 325       (return)
 326       (setq alist (cdr alist))))
 327   (car alist))
 328
 329 (defun acons (key datum alist)
 330   (cons (cons key datum) alist))
 331
 332 (defun pairlis (keys data &optional (alist ()))
 333   (while keys
 334     (setq alist (acons (car keys) (car data) alist))
 335     (setq keys (cdr keys))
 336     (setq data (cdr data)))
 337   alist)
 338
 339 (defun copy-alist (alist)
 340   (let ((new-alist ()))
 341     (while alist
 342       (push (cons (caar alist) (cdar alist)) new-alist)
 343       (setq alist (cdr alist)))
 344     (reverse new-alist)))
 345
 346
 347 (define-setf-expander car (x)
 348   (let ((cons (gensym))
 349         (new-value (gensym)))
 350     (values (list cons)
 351             (list x)
 352             (list new-value)
 353             `(progn (rplaca ,cons ,new-value) ,new-value)
 354             `(car ,cons))))
 355
 356 (define-setf-expander cdr (x)
 357   (let ((cons (gensym))
 358         (new-value (gensym)))
 359     (values (list cons)
 360             (list x)
 361             (list new-value)
 362             `(progn (rplacd ,cons ,new-value) ,new-value)
 363             `(cdr ,cons))))
 364
 365
 366 ;; The NCONC function is based on the SBCL's one.
 367 (defun nconc (&rest lists)
 368   (flet ((fail (object)
 369            (error "type-error in nconc")))
 370     (do ((top lists (cdr top)))
 371         ((null top) nil)
 372       (let ((top-of-top (car top)))
 373         (typecase top-of-top
 374           (cons
 375            (let* ((result top-of-top)
 376                   (splice result))
 377              (do ((elements (cdr top) (cdr elements)))
 378                  ((endp elements))
 379                (let ((ele (car elements)))
 380                  (typecase ele
 381                    (cons (rplacd (last splice) ele)
 382                          (setf splice ele))
 383                    (null (rplacd (last splice) nil))
 384                    (atom (if (cdr elements)
 385                              (fail ele)
 386                              (rplacd (last splice) ele))))))
 387              (return result)))
 388           (null)
 389           (atom
 390            (if (cdr top)
 391                (fail top-of-top)
 392                (return top-of-top))))))))
 393
 394
 395 (defun nreconc (x y)
 396   (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 397        (2nd x 1st)                ; 2nd follows first down the list.
 398        (3rd y 2nd))               ;3rd follows 2nd down the list.
 399       ((atom 2nd) 3rd)
 400     (rplacd 2nd 3rd)))
 401
 402
 403 (defun adjoin (item list &key (test #'eql) (key #'identity))
 404   (if (member item list :key key :test test)
 405     list
 406     (cons item list)))
 407
 408 (defun intersection (list1 list2 &key (test #'eql) (key #'identity))
 409   (let ((new-list ()))
 410     (dolist (x list1)
 411       (when (member (funcall key x) list2 :test test :key key)
 412         (push x new-list)))
 413     new-list))
 414
 415 (defun get-properties (plist indicator-list)
 416   (do* ((plist plist (cddr plist))
 417         (cdr (cdr plist) (cdr plist))
 418         (car (car plist) (car plist)))
 419       ((null plist) (values nil nil nil))
 420     (when (null cdr)
 421       (error "malformed property list ~S" plist))
 422     (let ((found (member car indicator-list :test #'eq)))
 423       (when found
 424         (return (values car (cadr plist) plist))))))
 425
 426 (defun getf (plist indicator &optional default)
 427   (do* ((plist plist (cddr plist))
 428         (cdr (cdr plist) (cdr plist))
 429         (car (car plist) (car plist)))
 430       ((null plist) default)
 431     (when (null cdr)
 432       (error "malformed property list ~S" plist))
 433     (when (eq indicator car)
 434       (return (cadr plist)))))
 435
 436 (defun %putf (plist indicator new-value)
 437   (do* ((tail plist (cddr tail))
 438         (cdr (cdr tail) (cdr tail))
 439         (car (car tail) (car tail)))
 440       ((null tail) (list* indicator new-value plist))
 441     (when (null cdr)
 442       (error "malformed property list ~S" tail))
 443     (when (eq indicator car)
 444       ;; TODO: should be cadr, needs a defsetf for that
 445       (setf (car (cdr tail)) new-value)
 446       (return tail))))
 447
 448 (define-setf-expander getf (plist indicator &optional default)
 449   (multiple-value-bind (dummies vals newval setter getter)
 450       (get-setf-expansion plist)
 451     (let ((store (gensym))
 452           (indicator-sym (gensym))
 453           (default-sym (and default (gensym))))
 454       (values `(,indicator-sym ,@(and default `(,default-sym)) ,@dummies)
 455               `(,indicator ,@(and default `(,default)) ,@vals)
 456               `(,store)
 457               `(let ((,(car newval) (%putf ,getter ,indicator-sym ,store))
 458                      ,@(cdr newval))
 459                  ,setter
 460                  ,store)
 461               `(getf ,getter ,indicator-sym ,@(and default `(,default-sym)))))))