From 8a3bbf707f43fd95bc3025e3f222563c36b599fd Mon Sep 17 00:00:00 2001
From: William Harold Newman <william.newman@airmail.net>
Date: Fri, 5 Oct 2001 20:02:24 +0000
Subject: [PATCH] 0.pre7.45: 	added test cases for BUTLAST/NBUTLAST
 functions, rewrote the 		functions (again..)
 (and fantasized about someday 		learning to write
 correct code..)

---
 src/code/list.lisp   |   40 +++++++++++++++++++++----------------
 tests/list.pure.lisp |   53 ++++++++++++++++++++++++++++++++++++++++++++++++++
 version.lisp-expr    |    2 +-
 3 files changed, 77 insertions(+), 18 deletions(-)
 create mode 100644 tests/list.pure.lisp

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 55f66c9..9b07696 100644
--- 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
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
--- 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"
-- 
1.7.10.4