0.8.16.2: TYPE-ERROR for ERROR

[sbcl.git] / src / code / list.lisp

diff --git a/src/code/list.lisp b/src/code/list.lisp
index cacffe8..0454ffc 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -11,6 +11,8 @@
 
 (in-package "SB!IMPL")
 
 
 (in-package "SB!IMPL")
 

+;;; Limitation: no list might have more than INDEX conses.
+

 ;;;; KLUDGE: comment from CMU CL, what does it mean?
 ;;;;   NSUBLIS, things at the beginning broken.
 ;;;; -- WHN 20000127
 ;;;; KLUDGE: comment from CMU CL, what does it mean?
 ;;;;   NSUBLIS, things at the beginning broken.
 ;;;; -- WHN 20000127

@@ -211,25 +213,35 @@
   (cdr list))
 
 (defun nthcdr (n list)
   (cdr list))
 
 (defun nthcdr (n list)

-  (declare (type index n))

   #!+sb-doc
   "Performs the cdr function n times on a list."
   #!+sb-doc
   "Performs the cdr function n times on a list."

-  (do ((i n (1- i))
-       (result list (cdr result)))
-      ((not (plusp i)) result)
-      (declare (type index i))))
+  (flet ((fast-nthcdr (n list)
+           (declare (type index n))
+           (do ((i n (1- i))
+                (result list (cdr result)))
+               ((not (plusp i)) result)
+             (declare (type index i)))))
+    (typecase n
+      (index (fast-nthcdr n list))
+      (t (do ((i 0 (1+ i))
+              (r-i list (cdr r-i))
+              (r-2i list (cddr r-2i)))
+             ((and (eq r-i r-2i) (not (zerop i)))
+              (fast-nthcdr (mod n i) r-i))
+           (declare (type index i)))))))

 
 (defun last (list &optional (n 1))
   #!+sb-doc
   "Return the last N conses (not the last element!) of a list."
 
 (defun last (list &optional (n 1))
   #!+sb-doc
   "Return the last N conses (not the last element!) of a list."

-  (declare (type index n))
-  (do ((checked-list list (cdr checked-list))
-       (returned-list list)
-       (index 0 (1+ index)))
-      ((atom checked-list) returned-list)
-    (declare (type index index))
-    (if (>= index n)
-       (pop returned-list))))
+  (if (typep n 'index)
+      (do ((checked-list list (cdr checked-list))
+           (returned-list list)
+           (index 0 (1+ index)))
+          ((atom checked-list) returned-list)
+        (declare (type index index))
+        (if (>= index n)
+            (pop returned-list)))
+      list))

 
 (defun list (&rest args)
   #!+sb-doc
 
 (defun list (&rest args)
   #!+sb-doc

@@ -257,45 +269,36 @@
       ((zerop count) result)
     (declare (type index count))))
 \f
       ((zerop count) result)
     (declare (type index count))))
 \f

-;;; The outer loop finds the first non-null list and the result is
-;;; started. The remaining lists in the arguments are tacked to the
-;;; end of the result using splice which cdr's down the end of the new
-;;; list.

 (defun append (&rest lists)
   #!+sb-doc
   "Construct a new list by concatenating the list arguments"
 (defun append (&rest lists)
   #!+sb-doc
   "Construct a new list by concatenating the list arguments"

-  (flet ((fail (object)
-           (error 'type-error
-                  :datum object
-                  :expected-type 'list)))
-    (do ((top lists (cdr top))) ; CDR to first non-null list.
-        ((atom top) '())
-      (cond ((null (car top)))          ; NIL -> Keep looping
-            ((not (consp (car top)))    ; Non CONS
-             (if (cdr top)
-                 (fail (car top))
-                 (return (car top))))
-            (t                          ; Start appending
-             (return
-               (if (atom (cdr top))
-                   (car top)            ; Special case.
-                   (let* ((result (cons (caar top) '()))
-                          (splice result))
-                     (do ((x (cdar top) (cdr x))) ; Copy first list
-                         ((atom x))
-                       (setq splice
-                             (cdr (rplacd splice (cons (car x) ()) ))) )
-                     (do ((y (cdr top) (cdr y))) ; Copy rest of lists.
-                         ((atom (cdr y))
-                          (setq splice (rplacd splice (car y)))
-                          result)
-                       (if (listp (car y))
-                           (do ((x (car y) (cdr x))) ; Inner copy loop.
-                               ((atom x))
-                             (setq
-                              splice
-                              (cdr (rplacd splice (cons (car x) ())))))
-                           (fail (car y))))))))))))
+  (labels ((fail (object)
+             (error 'type-error
+                    :datum object
+                    :expected-type 'list))
+           (append-into (last-cons current rest)
+             "Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST)."
+             (declare (cons last-cons rest))
+             (cond ((consp current)
+                    (append-into (setf (cdr last-cons) (list (car current)))
+                                (cdr current)
+                                rest))
+                   ((not (null current)) (fail current))
+                   ((null (cdr rest)) (setf (cdr last-cons) (car rest)))
+                   (t (append-into last-cons (car rest) (cdr rest)))))
+           (append1 (lists)
+             (let ((current (car lists))
+                   (rest (cdr lists)))
+               (cond ((null rest) current)
+                     ((consp current)
+                      (let ((result (truly-the cons (list (car current)))))
+                        (append-into result
+                                    (cdr current)
+                                    rest)
+                        result))
+                     ((null current) (append1 rest))
+                     (t (fail current))))))
+    (append1 lists)))

 \f
 ;;;; list copying functions
 
 \f
 ;;;; list copying functions
 

@@ -310,7 +313,7 @@
       (let ((result (list (car list))))
        (do ((x (cdr list) (cdr x))
             (splice result
       (let ((result (list (car list))))
        (do ((x (cdr list) (cdr x))
             (splice result

-                    (cdr (rplacd splice (cons (car x) '() ))) ))
+                    (cdr (rplacd splice (cons (car x) '())))))

            ((atom x)
             (unless (null x)
               (rplacd splice x))))
            ((atom x)
             (unless (null x)
               (rplacd splice x))))

@@ -319,12 +322,12 @@
 (defun copy-alist (alist)
   #!+sb-doc
   "Return a new association list which is EQUAL to ALIST."
 (defun copy-alist (alist)
   #!+sb-doc
   "Return a new association list which is EQUAL to ALIST."

-  (if (atom alist)
+  (if (endp alist)

       alist
       (let ((result
             (cons (if (atom (car alist))
                       (car alist)
       alist
       (let ((result
             (cons (if (atom (car alist))
                       (car alist)

-                      (cons (caar alist) (cdar alist)) )
+                      (cons (caar alist) (cdar alist)))

                   nil)))
        (do ((x (cdr alist) (cdr x))
             (splice result
                   nil)))
        (do ((x (cdr alist) (cdr x))
             (splice result

@@ -334,10 +337,7 @@
                                       (car x)
                                       (cons (caar x) (cdar x)))
                                   nil)))))
                                       (car x)
                                       (cons (caar x) (cdar x)))
                                   nil)))))

-           ;; Non-null terminated alist done here.
-           ((atom x)
-            (unless (null x)
-              (rplacd splice x))))
+           ((endp x)))

        result)))
 
 (defun copy-tree (object)
        result)))
 
 (defun copy-tree (object)

@@ -403,7 +403,7 @@
 (defun nreconc (x y)
   #!+sb-doc
   "Return (NCONC (NREVERSE X) Y)."
 (defun nreconc (x y)
   #!+sb-doc
   "Return (NCONC (NREVERSE X) Y)."

-  (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st)))
+  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))

        (2nd x 1st)              ;2nd follows first down the list.
        (3rd y 2nd))             ;3rd follows 2nd down the list.
       ((atom 2nd) 3rd)
        (2nd x 1st)              ;2nd follows first down the list.
        (3rd y 2nd))             ;3rd follows 2nd down the list.
       ((atom 2nd) 3rd)

@@ -420,30 +420,34 @@
           (declare (type index result)))))
   (declare (ftype (function (t) index) count-conses))
   (defun butlast (list &optional (n 1))
           (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)))
-      (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))))))
+    (if (typep n 'index)
+        (let ((n-conses-in-list (count-conses 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)))))
+        nil))

   (defun nbutlast (list &optional (n 1))
   (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)))))
+    (cond ((zerop n)
+           list)
+          ((not (typep n 'index))
+           nil)
+          (t (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
 
 (defun ldiff (list object)
   "Return a new list, whose elements are those of LIST that appear before

@@ -480,15 +484,21 @@
 
 ;;; Set the Nth element of LIST to NEWVAL.
 (defun %setnth (n list newval)
 
 ;;; Set the Nth element of LIST to NEWVAL.
 (defun %setnth (n list newval)

-  (declare (type index n))
-  (do ((count n (1- count))
-       (list list (cdr list)))
-      ((endp list)
-       (error "~S is too large an index for SETF of NTH." n))
-    (declare (type fixnum count))
-    (when (<= count 0)
-      (rplaca list newval)
-      (return newval))))
+  (typecase n
+    (index
+     (do ((count n (1- count))
+          (list list (cdr list)))
+         ((endp list)
+          (error "~S is too large an index for SETF of NTH." n))
+       (declare (type fixnum count))
+       (when (<= count 0)
+         (rplaca list newval)
+         (return newval))))
+    (t (let ((cons (nthcdr n list)))
+         (when (endp cons)
+           (error "~S is too large an index for SETF of NTH." n))
+         (rplaca cons newval)
+         newval))))

 \f
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 
 \f
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 

@@ -649,7 +659,7 @@
                        ((atom subtree) subtree)
                        (t (let ((car (s (car subtree)))
                                 (cdr (s (cdr subtree))))
                        ((atom subtree) subtree)
                        (t (let ((car (s (car subtree)))
                                 (cdr (s (cdr subtree))))

-                            (if (and (eq car (car subtreE))
+                            (if (and (eq car (car subtree))

                                      (eq cdr (cdr subtree)))
                                 subtree
                                 (cons car cdr))))))))
                                      (eq cdr (cdr subtree)))
                                 subtree
                                 (cons car cdr))))))))

@@ -898,32 +908,48 @@
     ;; reached, what is left of LIST2 is tacked onto what is left of
     ;; LIST1. The splicing operation ensures that the correct
     ;; operation is performed depending on whether splice is at the
     ;; reached, what is left of LIST2 is tacked onto what is left of
     ;; LIST1. The splicing operation ensures that the correct
     ;; operation is performed depending on whether splice is at the

-    ;; top of the list or not
+    ;; top of the list or not.

     (do ((list1 list1)
          (list2 list2)
          (x list1 (cdr x))
     (do ((list1 list1)
          (list2 list2)
          (x list1 (cdr x))

-         (splicex ()))
+         (splicex ())
+         (deleted-y ())
+         ;; elements of LIST2, which are "equal" to some processed
+         ;; earlier elements of LIST1
+         )

         ((endp x)
          (if (null splicex)
              (setq list1 list2)
              (rplacd splicex list2))
          list1)
         ((endp x)
          (if (null splicex)
              (setq list1 list2)
              (rplacd splicex list2))
          list1)

-      (do ((y list2 (cdr y))
-           (splicey ()))
-          ((endp y) (setq splicex x))
-        (cond ((let ((key-val-x (apply-key key (car x)))
-                     (key-val-y (apply-key key (Car y))))
-                 (if notp
-                     (not (funcall test-not key-val-x key-val-y))
-                     (funcall test key-val-x key-val-y)))
-               (if (null splicex)
-                   (setq list1 (cdr x))
-                   (rplacd splicex (cdr x)))
-               (if (null splicey)
-                   (setq list2 (cdr y))
-                   (rplacd splicey (cdr y)))
-               (return ())) ; assume lists are really sets
-              (t (setq splicey y)))))))
+      (let ((key-val-x (apply-key key (car x)))
+            (found-duplicate nil))
+
+        ;; Move all elements from LIST2, which are "equal" to (CAR X),
+        ;; to DELETED-Y.
+        (do* ((y list2 next-y)
+              (next-y (cdr y) (cdr y))
+              (splicey ()))
+             ((endp y))
+          (cond ((let ((key-val-y (apply-key key (car y))))
+                   (if notp
+                       (not (funcall test-not key-val-x key-val-y))
+                       (funcall test key-val-x key-val-y)))
+                 (if (null splicey)
+                     (setq list2 (cdr y))
+                     (rplacd splicey (cdr y)))
+                 (setq deleted-y (rplacd y deleted-y))
+                 (setq found-duplicate t))
+                (t (setq splicey y))))
+
+        (unless found-duplicate
+          (setq found-duplicate (with-set-keys (member key-val-x deleted-y))))
+
+        (if found-duplicate
+            (if (null splicex)
+                (setq list1 (cdr x))
+                (rplacd splicex (cdr x)))
+            (setq splicex x))))))

 
 (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
 
 (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc