0.9.8.5:

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

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 92fc34a..4c80140 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -145,9 +145,7 @@
 (sb!xc:defmacro bad-sequence-type-error (type-spec)
   `(error 'simple-type-error
           :datum ,type-spec
 (sb!xc:defmacro bad-sequence-type-error (type-spec)
   `(error 'simple-type-error
           :datum ,type-spec

-          ;; FIXME: This is actually wrong, and should be something
-          ;; like (SATISFIES IS-A-VALID-SEQUENCE-TYPE-SPECIFIER-P).
-          :expected-type 'sequence
+          :expected-type '(satisfies is-a-valid-sequence-type-specifier-p)

           :format-control "~S is a bad type specifier for sequences."
           :format-arguments (list ,type-spec)))
 
           :format-control "~S is a bad type specifier for sequences."
           :format-arguments (list ,type-spec)))
 

@@ -173,14 +171,19 @@
   ;; ANSI.  Essentially, we are justified in throwing this on
   ;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI)
   ;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18
   ;; ANSI.  Essentially, we are justified in throwing this on
   ;; e.g. '(OR SIMPLE-VECTOR (VECTOR FIXNUM)), but maybe not (by ANSI)
   ;; on '(CONS * (CONS * NULL)) -- CSR, 2002-10-18

-  `(error 'simple-type-error
-          :datum ,type-spec
-          ;; FIXME: as in BAD-SEQUENCE-TYPE-ERROR, this is wrong.
-          :expected-type 'sequence
+
+  ;; On the other hand, I'm not sure it deserves to be a type-error,
+  ;; either. -- bem, 2005-08-10
+  `(error 'simple-program-error

           :format-control "~S is too hairy for sequence functions."
           :format-arguments (list ,type-spec)))
 ) ; EVAL-WHEN
 
           :format-control "~S is too hairy for sequence functions."
           :format-arguments (list ,type-spec)))
 ) ; EVAL-WHEN
 

+(defun is-a-valid-sequence-type-specifier-p (type)
+  (let ((type (specifier-type type)))
+    (or (csubtypep type (specifier-type 'list))
+        (csubtypep type (specifier-type 'vector)))))
+

 ;;; It's possible with some sequence operations to declare the length
 ;;; of a result vector, and to be safe, we really ought to verify that
 ;;; the actual result has the declared length.
 ;;; It's possible with some sequence operations to declare the length
 ;;; of a result vector, and to be safe, we really ought to verify that
 ;;; the actual result has the declared length.

@@ -1380,7 +1383,7 @@
             (= number-zapped count))
         (do ((index index (,bump index))
              (new-index new-index (,bump new-index)))
             (= number-zapped count))
         (do ((index index (,bump index))
              (new-index new-index (,bump new-index)))

-            ((= index (the fixnum ,right)) (shrink-vector result new-index))
+            ((= index (the fixnum ,right)) (%shrink-vector result new-index))

           (declare (fixnum index new-index))
           (setf (aref result new-index) (aref sequence index))))
      (declare (fixnum index new-index number-zapped))
           (declare (fixnum index new-index))
           (setf (aref result new-index) (aref sequence index))))
      (declare (fixnum index new-index number-zapped))

@@ -1548,41 +1551,77 @@
   (declare (fixnum start))
   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
          (splice result)
   (declare (fixnum start))
   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
          (splice result)

-         (current list))
+         (current list)
+         (end (or end (length list)))
+         (hash (and (> (- end start) 20)
+                    test
+                    (not key)
+                    (not test-not)
+                    (or (eql test #'eql)
+                        (eql test #'eq)
+                        (eql test #'equal)
+                        (eql test #'equalp))
+                    (make-hash-table :test test :size (- end start)))))

     (do ((index 0 (1+ index)))
         ((= index start))
       (declare (fixnum index))
       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))
     (do ((index 0 (1+ index)))
         ((= index start))
       (declare (fixnum index))
       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))

-    (do ((index start (1+ index)))
-        ((or (and end (= index (the fixnum end)))
-             (atom current)))
-      (declare (fixnum index))
-      (if (or (and from-end
-                   (not (if test-not
-                            (member (apply-key key (car current))
-                                    (nthcdr (1+ start) result)
-                                    :test-not test-not
-                                    :key key)
+    (if hash
+        (do ((index start (1+ index)))
+            ((or (and end (= index (the fixnum end)))
+                 (atom current)))
+          (declare (fixnum index))
+          ;; The hash table contains links from values that are
+          ;; already in result to the cons cell *preceding* theirs
+          ;; in the list.  That is, for each value v in the list,
+          ;; v and (cadr (gethash v hash)) are equal under TEST.
+          (let ((prev (gethash (car current) hash)))
+            (cond
+             ((not prev)
+              (setf (gethash (car current) hash) splice)
+              (setq splice (cdr (rplacd splice (list (car current))))))
+             ((not from-end)
+              (let* ((old (cdr prev))
+                     (next (cdr old)))
+                (if next
+                  (let ((next-val (car next)))
+                    ;; (assert (eq (gethash next-val hash) old))
+                    (setf (cdr prev) next
+                          (gethash next-val hash) prev
+                          (gethash (car current) hash) splice
+                          splice (cdr (rplacd splice (list (car current))))))
+                  (setf (car old) (car current)))))))
+          (setq current (cdr current)))
+      (do ((index start (1+ index)))
+          ((or (and end (= index (the fixnum end)))
+               (atom current)))
+        (declare (fixnum index))
+        (if (or (and from-end
+                     (not (if test-not
+                              (member (apply-key key (car current))
+                                      (nthcdr (1+ start) result)
+                                      :test-not test-not
+                                      :key key)

                             (member (apply-key key (car current))
                                     (nthcdr (1+ start) result)
                                     :test test
                                     :key key))))
                             (member (apply-key key (car current))
                                     (nthcdr (1+ start) result)
                                     :test test
                                     :key key))))

-              (and (not from-end)
-                   (not (do ((it (apply-key key (car current)))
-                             (l (cdr current) (cdr l))
-                             (i (1+ index) (1+ i)))
-                            ((or (atom l) (and end (= i (the fixnum end))))
-                             ())
-                          (declare (fixnum i))
-                          (if (if test-not
-                                  (not (funcall test-not
-                                                it
-                                                (apply-key key (car l))))
+                (and (not from-end)
+                     (not (do ((it (apply-key key (car current)))
+                               (l (cdr current) (cdr l))
+                               (i (1+ index) (1+ i)))
+                              ((or (atom l) (and end (= i (the fixnum end))))
+                               ())
+                            (declare (fixnum i))
+                            (if (if test-not
+                                    (not (funcall test-not
+                                                  it
+                                                  (apply-key key (car l))))

                                   (funcall test it (apply-key key (car l))))
                                   (funcall test it (apply-key key (car l))))

-                              (return t))))))
-          (setq splice (cdr (rplacd splice (list (car current))))))
-      (setq current (cdr current)))
+                                (return t))))))
+            (setq splice (cdr (rplacd splice (list (car current))))))
+        (setq current (cdr current))))

     (do ()
         ((atom current))
       (setq splice (cdr (rplacd splice (list (car current)))))
     (do ()
         ((atom current))
       (setq splice (cdr (rplacd splice (list (car current)))))

@@ -1626,7 +1665,7 @@
       (setf (aref result jndex) (aref vector index))
       (setq index (1+ index))
       (setq jndex (1+ jndex)))
       (setf (aref result jndex) (aref vector index))
       (setq index (1+ index))
       (setq jndex (1+ jndex)))

-    (shrink-vector result jndex)))
+    (%shrink-vector result jndex)))

 
 (define-sequence-traverser remove-duplicates
     (sequence &key test test-not start end from-end key)
 
 (define-sequence-traverser remove-duplicates
     (sequence &key test test-not start end from-end key)

@@ -1687,8 +1726,7 @@
        (do ((index index (1+ index))            ; copy the rest of the vector
             (jndex jndex (1+ jndex)))
            ((= index length)
        (do ((index index (1+ index))            ; copy the rest of the vector
             (jndex jndex (1+ jndex)))
            ((= index length)

-            (shrink-vector vector jndex)
-            vector)
+            (shrink-vector vector jndex))

          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))

@@ -2348,3 +2386,12 @@
     (seq-dispatch sequence2
                   (list-search sequence2 sequence1)
                   (vector-search sequence2 sequence1))))
     (seq-dispatch sequence2
                   (list-search sequence2 sequence1)
                   (vector-search sequence2 sequence1))))

+
+(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
+  (let ((fun (gensym "STRING-DISPATCH-FUN-")))
+    `(flet ((,fun (,var)
+              ,@body))
+       (declare (inline ,fun))
+       (etypecase ,var
+         ,@(loop for type in types
+                 collect `(,type (,fun (the ,type ,var))))))))