X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fseq.lisp;h=64075abc9a171ea3ae6947cbe313d274d3480e49;hb=7ebe82f662f0fd0038479cbb057ec77867ab6f7e;hp=e88cb37141317e9f83f4d84608852fef1aba2c63;hpb=c906a1440506a4133adf3e77371bde75ad7721ee;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index e88cb37..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. @@ -1549,76 +1552,76 @@ (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))))) @@ -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))))))))