0.9.16.22:

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

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

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

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

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