(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)))
;; 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.
(= 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))
(let* ((result (list ())) ; Put a marker on the beginning to splice with.
(splice result)
(current list)
- (end (or end (length list)))
- (hash (and 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)))))
+ (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)))
(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))
+ ;; 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))))
+ ((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)))))
(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)
(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))
(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))))))))