X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=64075abc9a171ea3ae6947cbe313d274d3480e49;hb=54e97796e29cb89892dd30c8cb8c5e9d0a870f94;hp=67ade1bf2fd5230046aaad209261f1620e43e308;hpb=9dfd024c6fe1337ae7b76f0fd68b8f3208a6c987;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 67ade1b..64075ab 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.
@@ -1550,14 +1553,14 @@
          (splice result)
          (current list)
          (end (or end (length list)))
-         (hash (and test
+         (hash (and (> (- end start) 20)
+                    test
                     (not key)
                     (not test-not)
                     (or (eql test #'eql)
                         (eql test #'eq)
                         (eql test #'equal)
                         (eql test #'equalp))
-                    ; (> (- end start) 20)
                     (make-hash-table :test test :size (- end start)))))
     (do ((index 0 (1+ index)))
         ((= index start))
@@ -2384,3 +2387,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))))))))