From 91f0a6ce8769305d1d5c0a285e78ef861d931973 Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Sat, 9 May 1998 22:16:45 +0000
Subject: [PATCH] ldiff, tailp, butlast, nbutlast now handle dotted lists as
 required by ANSI.

---
 code/list.lisp | 74 ++++++++++++++++++++++++++++----------------------
 1 file changed, 42 insertions(+), 32 deletions(-)

diff --git a/code/list.lisp b/code/list.lisp
index b91a0b234..1eb1cb143 100644
--- a/code/list.lisp
+++ b/code/list.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.21 1998/04/03 03:45:39 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/list.lisp,v 1.22 1998/05/09 22:16:45 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -356,42 +356,52 @@
     (rplacd 2nd 3rd)))
 
 (defun butlast (list &optional (n 1))
-  "Returns a new list the same as List without the N last elements."
+  "Returns a new list the same as List without the last N conses.
+   List must not be circular."
   (declare (list list) (type index n))
-  (let ((length (1- (length list))))
+  (let ((length (do ((list list (cdr list))
+		     (i 0 (1+ i)))
+		    ((atom list) (1- i)))))
     (declare (type index length))
-    (if (< length n)
-        ()
-        (do* ((top (cdr list) (cdr top))
-              (result (list (car list)))
-              (splice result)
-              (count length (1- count)))
-             ((= count n) result)
-          (declare (type index count))
-          (setq splice (cdr (rplacd splice (list (car top)))))))))
+    (unless (< length n)
+      (do* ((top (cdr list) (cdr top))
+	    (result (list (car list)))
+	    (splice result)
+	    (count length (1- count)))
+	   ((= count n) result)
+	(declare (type index count))
+	(setq splice (cdr (rplacd splice (list (car top)))))))))
 
 (defun nbutlast (list &optional (n 1))
-  "Modifies List to remove the last N elements."
+  "Modifies List to remove the last N conses. List must not be circular."
   (declare (list list) (type index n))
-  (let ((length (1- (length list))))
+  (let ((length (do ((list list (cdr list))
+		     (i 0 (1+ i)))
+		    ((atom list) (1- i)))))
     (declare (type index length))
-    (if (< length n) ()
-        (do ((1st (cdr list) (cdr 1st))
-             (2nd list 1st)
-             (count length (1- count)))
-            ((= count n)
-             (rplacd 2nd ())
-             list)
-          (declare (type index count))))))
-
-(defun ldiff (list sublist)
+    (unless (< length n)
+      (do ((1st (cdr list) (cdr 1st))
+	   (2nd list 1st)
+	   (count length (1- count)))
+	  ((= count n)
+	   (rplacd 2nd ())
+	   list)
+	(declare (type index count))))))
+
+(defun ldiff (list object)
   "Returns a new list, whose elements are those of List that appear before
-   Sublist.  If Sublist is not a tail of List, a copy of List is returned."
+   Object.  If Object is not a tail of List, a copy of List is returned.
+   List must be a proper list or a dotted list."
   (do* ((list list (cdr list))
 	(result (list ()))
 	(splice result))
-       ((or (null list) (eq list sublist)) (cdr result))
-    (setq splice (cdr (rplacd splice (list (car list)))))))
+       ((atom list)
+	(if (eql list object)
+	    (cdr result)
+	    (progn (rplacd splice list) (cdr result))))
+    (if (eql list object)
+	(return (cdr result))
+	(setq splice (cdr (rplacd splice (list (car list))))))))
 
 ;;; Functions to alter list structure
 
@@ -653,12 +663,12 @@
     (if (not (funcall test (apply-key key (car list))))
 	(return list))))
 
-(defun tailp (sublist list)
-  "Returns T if (EQL Sublist (NTHCDR <n> List)) for some value of <n>, NIL
-  otherwise."
+(defun tailp (object list)
+  "Returns true if Object is the same as some tail of List, otherwise
+   returns false. List must be a proper list or a dotted list."
   (do ((list list (cdr list)))
-      ((atom list) (eql list sublist))
-    (if (eql sublist list)
+      ((atom list) (eql list object))
+    (if (eql object list)
 	(return t))))
 
 (defun adjoin (item list &key key (test #'eql) (test-not nil notp))
-- 
GitLab