Merge https://github.com/pnathan/jscl into nbutlast

# Please enter a commit message to explain why this merge is necessary,
# especially if it merges an updated upstream into a topic branch.
#
# Lines starting with '#' will be ignored, and an empty message aborts
# the commit.

diff --git a/src/list.lisp b/src/list.lisp
index 9cb8e45..8b30aec 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -197,6 +197,14 @@
     (when (eql tail object)
       (return-from tailp t))))
 
+(defun make-list (size &key (initial-element nil))
+  "Create a list of size `size` of `initial-element`s."
+  (when (< size 0)
+    (error "Size must be non-negative"))
+  (let ((newlist))
+    (dotimes (i size newlist)
+      (push initial-element newlist))))
+
 (defun map1 (func list)
   (with-collect
     (while list
@@ -246,11 +254,54 @@
     (setq x (cdr x)))
   x)
 
-(defun butlast (x)
-  (and (consp (cdr x))
-       (cons (car x) (butlast (cdr x)))))
+(defun butlast (x &optional (n 1))
+  "Returns x, less the n last elements in the list."
+  (nbutlast (copy-list x) n))
+
+(defun nbutlast (x &optional (n 1))
+  "Destructively returns x, less the n last elements in the list."
+  (cond
+    ((not (and (integerp n)
+               (>= n 0)))
+     ;; TODO: turn this error into a type error, per CLHS spec.
+     (error "n must be a non-negative integer"))
+
+    ;; trivial optimizations
+    ((zerop n) x)
+
+    (t
+     ;; O(n) walk of the linked list, trimming out the link where appropriate
+     (let*
+         ((head x)
+          (trailing x))
+
+       ;; find n in...
+       (do ((i 0 (1+ i)))
+           ((or ( >= i (1- n))
+                (not head)
+                (not (consp (cdr head)))))
+         (setf head (cdr head)))
+
+       (when (consp (cdr head))
+
+       (setf trailing x)
+       (setf head (cdr head))
+
+       ;; walk until the end
+       (do ()
+           ((or
+             (not (consp head))
+             (not (cdr head))))
+
+         (setf head (cdr head))
+         (setf trailing (cdr trailing)))
+
+       ;; snip
+       (rplacd trailing nil)
+
+       x)))))
 
-(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p)) 
+(defun member (x list &key key (test #'eql testp) (test-not #'eql test-not-p))
   (while list
     (when (satisfies-test-p x (car list) :key key :test test :testp testp
                             :test-not test-not :test-not-p test-not-p)

diff --git a/tests/list.lisp b/tests/list.lisp
index b59f662..9580752 100644 (file)
--- a/tests/list.lisp
+++ b/tests/list.lisp
@@ -228,3 +228,23 @@
 (test (equal (multiple-value-list (get-properties '(a b c d) '(b d e))) '(NIL NIL NIL)))
 (test (equal (multiple-value-list (get-properties '(a b c d) '(b a c))) '(a b (a b c d))))
 (test (equal (multiple-value-list (get-properties '(a b c d) '(b c a))) '(a b (a b c d))))
+
+;; BUTLAST
+(test (equal (butlast '()) ()))
+(test (equal (butlast '(1)) ()))
+(test (equal (butlast '(1 2)) '(1)))
+(test (equal (butlast '(1 2 3 4 5)) '(1 2 3 4)))
+(test (equal '(1 2 3 4) (butlast '(1 2 3 4 5))))
+(test (equal (let ((thing '(1 2 3 4 5))) (butlast thing)) '(1 2 3 4)))
+(test (equal (let ((thing '(1 2 3 4 5))) (butlast thing) thing) '(1 2 3 4 5)))
+
+(test (equal (let ((thing '(1 2 3 4 5))) (butlast thing 0)) '(1 2 3 4 5)))
+(test (equal (let ((thing '(1 2 3 4 5))) (butlast thing 1)) '(1 2 3 4)))
+(test (equal (let ((thing '(1 2 3 4 5))) (butlast thing 2)) '(1 2 3)))
+(test (equal (let ((thing '())) (butlast thing 2)) '()))
+(test (equal (let ((thing '(1 2))) (butlast thing 2)) '()))
+(test (equal (let ((thing '())) (butlast thing 0)) '()))
+
+;; MAKE-LIST
+(test (equal (make-list 5) '(nil nil nil nil nil)))
+(test (equal (make-list 3 :initial-element 'rah) '(rah rah rah)))