0.9.16.22:

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

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index a43e2f7..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))

@@ -1549,69 +1552,76 @@
   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
          (splice result)
          (current list)
   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
          (splice result)
          (current list)

-        (hash (and test
-                   (not key)
-                   (not test-not)
-                   (or (eql test #'eql)
-                       (eql test #'eq)
-                       (eql test #'equal)
-                       (eql test #'equalp))
-                   ; (> (if end (- end start) (- (length list) start)) 20)
-                   (make-hash-table :test test))))
+         (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))
     (do ((index 0 (1+ index)))
         ((= index start))
       (declare (fixnum index))

-      ;; (if hash (setf (gethash (car current) hash) splice))

       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))
       (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))
-      (cond
-       (hash
-       (let ((prev (gethash (car current) hash)))
-         (cond
-          ((not prev)
-           (setf (gethash (car current) hash) splice)
-           (setq splice (cdr (rplacd splice (list (car current))))))
-          (from-end nil)
-          (t
-           (let ((old (cdr prev)))
-             (let ((next (cdr old)))
-               (when 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)))))))))))))
-       (t
-       (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))))
-               (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))))
-                               (return t))))))
-           (setq splice (cdr (rplacd splice (list (car current))))))))
-      (setq current (cdr current)))
+    (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))))
+                (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))))
+                                (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)))))

@@ -1655,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)

@@ -1716,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))

@@ -2377,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))))))))