0.pre7.45:

	added test cases for BUTLAST/NBUTLAST functions, rewrote the
		functions (again..) (and fantasized about someday
		learning to write correct code..)

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 55f66c9..9b07696 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -406,24 +406,30 @@
           (declare (type index result)))))
   (declare (ftype (function (t) index) count-conses))
   (defun butlast (list &optional (n 1))
-    (let* ((n-conses-in-list (count-conses list))
-          (n-remaining-to-copy (- n-conses-in-list n)))
-      (declare (type fixnum n-remaining-to-copy))
-      (when (plusp n-remaining-to-copy)
-       (do* ((result (list (first list)))
-             (rest (rest list) (rest rest))
-             (splice result))
-           ((zerop (decf n-remaining-to-copy))
-            result)
-         (setf splice
-               (setf (cdr splice)
-                     (list (first rest))))))))
-  (defun nbutlast (list &optional (n 1))
     (let ((n-conses-in-list (count-conses list)))
-      (unless (< n-conses-in-list n)
-       (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
-             nil)
-       list))))
+      (cond ((zerop n)
+            ;; (We can't use SUBSEQ in this case because LIST isn't
+            ;; necessarily a proper list, but SUBSEQ expects a
+            ;; proper sequence. COPY-LIST isn't so fussy.)
+            (copy-list list))
+           ((>= n n-conses-in-list)
+            nil)
+           (t
+            ;; (LIST isn't necessarily a proper list in this case
+            ;; either, and technically SUBSEQ wants a proper
+            ;; sequence, but no reasonable implementation of SUBSEQ
+            ;; will actually walk down to the end of the list to
+            ;; check, and since we're calling our own implementation
+            ;; we know it's reasonable, so it's OK.)
+            (subseq list 0 (- n-conses-in-list n))))))
+  (defun nbutlast (list &optional (n 1))
+    (if (zerop n)
+       list
+       (let ((n-conses-in-list (count-conses list)))
+         (unless (<= n-conses-in-list n)
+           (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
+                 nil)
+           list)))))
 
 (defun ldiff (list object)
   "Return a new list, whose elements are those of LIST that appear before

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
new file mode 100644 (file)
index 0000000..e898b54
--- /dev/null
+++ b/tests/list.pure.lisp
@@ -0,0 +1,53 @@
+;;;; tests related to lists
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;; 
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+;;; Since *another* BUTLAST problem was reported (anonymously!) on the
+;;; SourceForge summary page magical bugs web interface 2001-09-01, it
+;;; looks as though it's past time to start accumulating regression
+;;; tests for these.
+(dolist (testcase
+        '((:args ((1 2 3 4 5))   :result (1 2 3 4))
+          (:args ((1 2 3 4 5) 6) :result nil)
+          (:args (nil)           :result nil)
+          (:args (t)             :result nil)
+          (:args (foosymbol 0)   :result foosymbol)
+          (:args (foosymbol)     :result nil)
+          (:args (foosymbol 1)   :result nil)
+          (:args (foosymbol 2)   :result nil)
+          (:args ((1 2 3) 0)     :result (1 2 3))
+          (:args ((1 2 3) 1)     :result (1 2))
+          (:args ((1 2 3))       :result (1 2))
+          (:args ((1 2 3) 2)     :result (1))
+          (:args ((1 2 3) 3)     :result nil)
+          (:args ((1 2 3) 4)     :result nil)
+          (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4))
+          (:args ((1 2 3 . 4) 1) :result (1 2))
+          (:args ((1 2 3 . 4))   :result (1 2))
+          (:args ((1 2 3 . 4) 2) :result (1))
+          (:args ((1 2 3 . 4) 3) :result nil)
+          (:args ((1 2 3 . 4) 4) :result nil)))
+  (destructuring-bind (&key args result) testcase
+    (destructuring-bind (list &rest rest) args
+      ;; Test with BUTLAST.
+      (let ((actual-result (apply #'butlast args)))
+       (when (and (consp list) (eq actual-result list))
+         (error "not a copy in BUTLAST for ~S" args))
+       (unless (equal actual-result result)
+         (error "failed BUTLAST for ~S" args)))
+      ;; Test with NBUTLAST.
+      (let* ((copied-list (copy-list list))
+            (actual-result (apply #'nbutlast copied-list rest)))
+       (unless (equal actual-result result)
+         (error "failed NBUTLAST for ~S" args))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 88b435c..d740002 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre7.43"
+"0.pre7.45"