X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=4c801406d9ba33da2892ce1ed173b6367a53dbb2;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=5fe1f9787935b48a56528e08564e1eebbbae0f48;hpb=92d8ab5b9274e73e50eb21feacbed396a9b24897;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 5fe1f97..4c80140 100644
--- 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
-          ;; 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)))
 
@@ -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
-  `(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
 
+(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.
@@ -1380,7 +1383,7 @@
             (= 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))
@@ -1662,7 +1665,7 @@
       (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)
@@ -1723,8 +1726,7 @@
        (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))
@@ -2384,3 +2386,12 @@
     (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))))))))