X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=fe0933880766bfb1463b83d69b832cf92c975296;hb=e43ebe3057bd62a58987b22f53c386ca7f5740f8;hp=adf36dbac74414b14e1a8cface136d7c1004b39a;hpb=9a241987c408980164f71237f7d840265302bbc1;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index adf36db..fe09338 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -26,7 +26,7 @@ ;;; ;;; FIXME: It might be worth making three cases here, LIST, ;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR. -;;; It tend to make code run faster but be bigger; some benchmarking +;;; It tends to make code run faster but be bigger; some benchmarking ;;; is needed to decide. (sb!xc:defmacro seq-dispatch (sequence list-form array-form) `(if (listp ,sequence) @@ -36,12 +36,54 @@ (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc "Return a sequence of the same type as SEQUENCE and the given LENGTH." - `(make-sequence-of-type (type-of ,sequence) ,length)) - -(sb!xc:defmacro type-specifier-atom (type) - #!+sb-doc "Return the broad class of which TYPE is a specific subclass." - `(if (atom ,type) ,type (car ,type))) - + `(if (typep ,sequence 'list) + (make-list ,length) + (progn + ;; This is only called from places which have already deduced + ;; that the SEQUENCE argument is actually a sequence. So + ;; this would be a candidate place for (AVER (TYPEP ,SEQUENCE + ;; 'VECTOR)), except that this seems to be a performance + ;; hotspot. + (make-array ,length + :element-type (array-element-type ,sequence))))) + +(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 + :format-control "~S is a bad type specifier for sequences." + :format-arguments (list ,type-spec))) + +(sb!xc:defmacro sequence-type-length-mismatch-error (type length) + `(error 'simple-type-error + :datum ,length + :expected-type (cond ((array-type-p ,type) + `(eql ,(car (array-type-dimensions ,type)))) + ((type= ,type (specifier-type 'null)) + '(eql 0)) + ((cons-type-p ,type) + '(integer 1)) + (t (bug "weird type in S-T-L-M-ERROR"))) + ;; FIXME: this format control causes ugly printing. There's + ;; probably some ~<~@:_~> incantation that would make it + ;; nicer. -- CSR, 2002-10-18 + :format-control "The length requested (~S) does not match the type restriction in ~S." + :format-arguments (list ,length (type-specifier ,type)))) + +(sb!xc:defmacro sequence-type-too-hairy (type-spec) + ;; FIXME: Should this be a BUG? I'm inclined to think not; there are + ;; words that give some but not total support to this position in + ;; 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 + :format-control "~S is too hairy for sequence functions." + :format-arguments (list ,type-spec))) ) ; EVAL-WHEN ;;; It's possible with some sequence operations to declare the length @@ -69,36 +111,10 @@ (vector-of-checked-length-given-length sequence declared-length)))))) -;;; Given an arbitrary type specifier, return a sane sequence type -;;; specifier that we can directly match. -(defun result-type-or-lose (type &optional nil-ok) - (let ((type (specifier-type type))) - (cond - ((eq type *empty-type*) - (if nil-ok - nil - (error 'simple-type-error - :datum type - :expected-type '(or vector cons) - :format-control - "A NIL output type is invalid for this sequence function." - :format-arguments ()))) - ((dolist (seq-type '(list string simple-vector bit-vector)) - (when (csubtypep type (specifier-type seq-type)) - (return seq-type)))) - ((csubtypep type (specifier-type 'vector)) - (type-specifier type)) - (t - (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control - "~S is not a legal type specifier for sequence functions." - :format-arguments (list type)))))) - (defun signal-index-too-large-error (sequence index) (let* ((length (length sequence)) - (max-index (and (plusp length) (1- length)))) + (max-index (and (plusp length) + (1- length)))) (error 'index-too-large-error :datum index :expected-type (if max-index @@ -106,21 +122,24 @@ ;; This seems silly, is there something better? '(integer (0) (0)))))) -(defun make-sequence-of-type (type length) - #!+sb-doc "Return a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) - (case (type-specifier-atom type) - (list (make-list length)) - ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) - ((string simple-string base-string simple-base-string) - (make-string length)) - (simple-vector (make-array length)) - ((array simple-array vector) - (if (listp type) - (make-array length :element-type (cadr type)) - (make-array length))) - (t - (make-sequence-of-type (result-type-or-lose type) length)))) +(defun signal-end-too-large-error (sequence end) + (let* ((length (length sequence)) + (max-end (and (not (minusp length)) + length))) + (error 'end-too-large-error + :datum end + :expected-type (if max-end + `(integer 0 ,max-end) + ;; This seems silly, is there something better? + '(integer (0) 0))))) + +(declaim (inline adjust-count) + (ftype (function (sequence-count) index) adjust-count)) +(defun adjust-count (count) + (cond ((not count) most-positive-fixnum) + ((< count 0) 0) + (t count))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -167,61 +186,74 @@ (declare (fixnum length)) (let ((type (specifier-type type))) (cond ((csubtypep type (specifier-type 'list)) - (make-list length :initial-element initial-element)) - ((csubtypep type (specifier-type 'string)) - (if iep - (make-string length :initial-element initial-element) - (make-string length))) - ((csubtypep type (specifier-type 'simple-vector)) - (make-array length :initial-element initial-element)) - ((csubtypep type (specifier-type 'bit-vector)) - (if iep - (make-array length :element-type '(mod 2) - :initial-element initial-element) - (make-array length :element-type '(mod 2)))) + (cond + ((type= type (specifier-type 'list)) + (make-list length :initial-element initial-element)) + ((eq type *empty-type*) + (bad-sequence-type-error nil)) + ((type= type (specifier-type 'null)) + (if (= length 0) + 'nil + (sequence-type-length-mismatch-error type length))) + ((csubtypep (specifier-type '(cons nil t)) type) + ;; The above is quite a neat way of finding out if + ;; there's a type restriction on the CDR of the + ;; CONS... if there is, I think it's probably fair to + ;; give up; if there isn't, then the list to be made + ;; must have a length of more than 0. + (if (> length 0) + (make-list length :initial-element initial-element) + (sequence-type-length-mismatch-error type length))) + ;; We'll get here for e.g. (OR NULL (CONS INTEGER *)), + ;; which may seem strange and non-ideal, but then I'd say + ;; it was stranger to feed that type in to MAKE-SEQUENCE. + (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) (if (typep type 'array-type) - (let ((etype (type-specifier - (array-type-specialized-element-type type))) - (vlen (car (array-type-dimensions type)))) - (if (and (numberp vlen) (/= vlen length)) - (error 'simple-type-error - ;; These two are under-specified by ANSI. - :datum (type-specifier type) - :expected-type (type-specifier type) - :format-control - "The length of ~S does not match the specified ~ - length=~S." - :format-arguments - (list (type-specifier type) length))) - (if iep - (make-array length :element-type etype - :initial-element initial-element) - (make-array length :element-type etype))) - (make-array length :initial-element initial-element))) - (t (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control "~S is a bad type specifier for sequences." - :format-arguments (list type)))))) + ;; KLUDGE: the above test essentially asks "Do we know + ;; what the upgraded-array-element-type is?" [consider + ;; (OR STRING BIT-VECTOR)] + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let ((etype (type-specifier + (array-type-specialized-element-type type))) + (type-length (car (array-type-dimensions type)))) + (unless (or (eq type-length '*) + (= type-length length)) + (sequence-type-length-mismatch-error type length)) + ;; FIXME: These calls to MAKE-ARRAY can't be + ;; open-coded, as the :ELEMENT-TYPE argument isn't + ;; constant. Probably we ought to write a + ;; DEFTRANSFORM for MAKE-SEQUENCE. -- CSR, + ;; 2002-07-22 + (if iep + (make-array length :element-type etype + :initial-element initial-element) + (make-array length :element-type etype)))) + (sequence-type-too-hairy (type-specifier type)))) + (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ ;;;; -;;;; The support routines for SUBSEQ are used by compiler transforms, so we -;;;; worry about dealing with END being supplied or defaulting to NIL -;;;; at this level. +;;;; The support routines for SUBSEQ are used by compiler transforms, +;;;; so we worry about dealing with END being supplied or defaulting +;;;; to NIL at this level. (defun vector-subseq* (sequence start &optional end) (declare (type vector sequence)) (declare (type fixnum start)) (declare (type (or null fixnum) end)) - (when (null end) (setf end (length sequence))) + (if (null end) + (setf end (length sequence)) + (unless (<= end (length sequence)) + (signal-end-too-large-error sequence end))) (do ((old-index start (1+ old-index)) (new-index 0 (1+ new-index)) (copy (make-sequence-like sequence (- end start)))) ((= old-index end) copy) (declare (fixnum old-index new-index)) - (setf (aref copy new-index) (aref sequence old-index)))) + (setf (aref copy new-index) + (aref sequence old-index)))) (defun list-subseq* (sequence start &optional end) (declare (type list sequence)) @@ -240,10 +272,10 @@ (declare (fixnum index))) ())))) -;;; SUBSEQ cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil -;;; in the body of the function, and this is actually done in the support -;;; routines for other reasons (see above). +;;; SUBSEQ cannot default END to the length of sequence since it is +;;; not an error to supply NIL for its value. We must test for END +;;; being NIL in the body of the function, and this is actually done +;;; in the support routines for other reasons. (See above.) (defun subseq (sequence start &optional end) #!+sb-doc "Return a copy of a subsequence of SEQUENCE starting with element number @@ -256,11 +288,11 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-copy-seq (sequence type) +(sb!xc:defmacro vector-copy-seq (sequence) `(let ((length (length (the vector ,sequence)))) (declare (fixnum length)) (do ((index 0 (1+ index)) - (copy (make-sequence-of-type ,type length))) + (copy (make-sequence-like ,sequence length))) ((= index length) copy) (declare (fixnum index)) (setf (aref copy index) (aref ,sequence index))))) @@ -289,7 +321,8 @@ (list-copy-seq sequence)) (defun vector-copy-seq* (sequence) - (vector-copy-seq sequence (type-of sequence))) + (declare (type vector sequence)) + (vector-copy-seq sequence)) ;;;; FILL @@ -467,12 +500,12 @@ (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-reverse (sequence type) +(sb!xc:defmacro vector-reverse (sequence) `(let ((length (length ,sequence))) (declare (fixnum length)) (do ((forward-index 0 (1+ forward-index)) (backward-index (1- length) (1- backward-index)) - (new-sequence (make-sequence-of-type ,type length))) + (new-sequence (make-sequence-like sequence length))) ((= forward-index length) new-sequence) (declare (fixnum forward-index backward-index)) (setf (aref new-sequence forward-index) @@ -498,7 +531,7 @@ (list-reverse-macro sequence)) (defun vector-reverse* (sequence) - (vector-reverse sequence (type-of sequence))) + (vector-reverse sequence)) ;;;; NREVERSE @@ -571,7 +604,7 @@ (do ((sequences ,sequences (cdr sequences)) (lengths lengths (cdr lengths)) (index 0) - (result (make-sequence-of-type ,output-type-spec total-length))) + (result (make-sequence ,output-type-spec total-length))) ((= index total-length) result) (declare (fixnum index)) (let ((sequence (car sequences))) @@ -594,24 +627,42 @@ ) ; EVAL-WHEN -;;; FIXME: Make a compiler macro or transform for this which efficiently -;;; handles the case of constant 'STRING first argument. (It's not just time -;;; efficiency, but space efficiency..) (defun concatenate (output-type-spec &rest sequences) #!+sb-doc "Return a new sequence of all the argument sequences concatenated together which shares no structure with the original argument sequences of the specified OUTPUT-TYPE-SPEC." - (case (type-specifier-atom output-type-spec) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) ; FIXME: unifying principle here? - (let ((result (apply #'concat-to-simple* output-type-spec sequences))) - #!+high-security (aver (typep result output-type-spec)) - result)) - (list (apply #'concat-to-list* sequences)) + (let ((type (specifier-type output-type-spec))) + (cond + ((csubtypep type (specifier-type 'list)) + (cond + ((type= type (specifier-type 'list)) + (apply #'concat-to-list* sequences)) + ((eq type *empty-type*) + (bad-sequence-type-error nil)) + ((type= type (specifier-type 'null)) + (if (every (lambda (x) (or (null x) + (and (vectorp x) (= (length x) 0)))) + sequences) + 'nil + (sequence-type-length-mismatch-error type + ;; FIXME: circular + ;; list issues. And + ;; rightward-drift. + (reduce #'+ + (mapcar #'length + sequences))))) + ((csubtypep (specifier-type '(cons nil t)) type) + (if (notevery (lambda (x) (or (null x) + (and (vectorp x) (= (length x) 0)))) + sequences) + (apply #'concat-to-list* sequences) + (sequence-type-length-mismatch-error type 0))) + (t (sequence-type-too-hairy (type-specifier type))))) + ((csubtypep type (specifier-type 'vector)) + (apply #'concat-to-simple* output-type-spec sequences)) (t - (apply #'concatenate (result-type-or-lose output-type-spec) sequences)))) + (bad-sequence-type-error output-type-spec))))) ;;; internal frobs ;;; FIXME: These are weird. They're never called anywhere except in @@ -731,7 +782,7 @@ (declare (type index counter)))))) (declare (type index min-len)) (with-map-state sequences - (let ((result (make-sequence-of-type output-type-spec min-len)) + (let ((result (make-sequence output-type-spec min-len)) (index 0)) (declare (type index index)) (loop with updated-map-apply-args @@ -760,7 +811,8 @@ ;;; length of the output sequence matches any length specified ;;; in RESULT-TYPE. (defun %map (result-type function first-sequence &rest more-sequences) - (let ((really-fun (%coerce-callable-to-fun function))) + (let ((really-fun (%coerce-callable-to-fun function)) + (type (specifier-type result-type))) ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn ;; it into something which can be DEFTRANSFORMed away. (It's ;; fairly important to handle this case efficiently, since @@ -773,36 +825,21 @@ ;; approach, consing O(N-ARGS) temporary storage (which can have ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time. (let ((sequences (cons first-sequence more-sequences))) - (case (type-specifier-atom result-type) - ((nil) (%map-for-effect really-fun sequences)) - (list (%map-to-list really-fun sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) + (cond + ((eq type *empty-type*) (%map-for-effect really-fun sequences)) + ((csubtypep type (specifier-type 'list)) + (%map-to-list really-fun sequences)) + ((csubtypep type (specifier-type 'vector)) (%map-to-vector result-type really-fun sequences)) (t - (apply #'map - (result-type-or-lose result-type t) - really-fun - sequences))))))) + (bad-sequence-type-error result-type))))))) (defun map (result-type function first-sequence &rest more-sequences) - (sequence-of-checked-length-given-type (apply #'%map - result-type - function - first-sequence - more-sequences) - ;; (The RESULT-TYPE isn't - ;; strictly the type of the - ;; result, because when - ;; RESULT-TYPE=NIL, the result - ;; actually has NULL type. But - ;; that special case doesn't - ;; matter here, since we only - ;; look closely at vector - ;; types; so we can just pass - ;; RESULT-TYPE straight through - ;; as a type specifier.) - result-type)) + (apply #'%map + result-type + function + first-sequence + more-sequences)) ;;; KLUDGE: MAP has been rewritten substantially since the fork from ;;; CMU CL in order to give reasonable performance, but this @@ -1137,7 +1174,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1175,7 +1212,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1213,7 +1250,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1292,17 +1329,19 @@ `(let* ((sequence ,(if reverse? '(reverse (the list sequence)) 'sequence)) + (%start ,(if reverse? '(- length end) 'start)) + (%end ,(if reverse? '(- length start) 'end)) (splice (list nil)) (results (do ((index 0 (1+ index)) (before-start splice)) - ((= index (the fixnum start)) before-start) + ((= index (the fixnum %start)) before-start) (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (pop sequence)))))))) - (do ((index start (1+ index)) + (do ((index %start (1+ index)) (this-element) (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + ((or (= index (the fixnum %end)) (= number-zapped (the fixnum count))) (do ((index index (1+ index))) ((null sequence) ,(if reverse? @@ -1360,7 +1399,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1378,7 +1417,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1396,7 +1435,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (seq-dispatch sequence @@ -1498,7 +1537,7 @@ which case the one later in the sequence is discarded. The resulting sequence is returned. - The :TEST-NOT argument is depreciated." + The :TEST-NOT argument is deprecated." (declare (fixnum start)) (seq-dispatch sequence (if sequence @@ -1571,7 +1610,7 @@ discarded. The resulting sequence, which may be formed by destroying the given sequence, is returned. - The :TEST-NOT argument is depreciated." + The :TEST-NOT argument is deprecated." (seq-dispatch sequence (if sequence (list-delete-duplicates* sequence test test-not key from-end start end)) @@ -1684,7 +1723,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (type index length end) (fixnum count)) (subst-dispatch 'normal))) @@ -1699,7 +1738,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum)) + (count (adjust-count count)) test-not old) (declare (type index length end) @@ -1715,7 +1754,7 @@ (declare (fixnum start)) (let* ((length (length sequence)) (end (or end length)) - (count (or count most-positive-fixnum)) + (count (adjust-count count)) test-not old) (declare (type index length end) @@ -1732,13 +1771,15 @@ may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (fixnum count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute* - new old (nreverse (the list sequence)) - test test-not start end count key)) + (let ((length (length sequence))) + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not (- length end) (- length start) + count key))) (nlist-substitute* new old sequence test test-not start end count key)) (if from-end @@ -1782,13 +1823,14 @@ SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (fixnum end count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) - start end count key)) + (let ((length (length sequence))) + (nreverse (nlist-substitute-if* + new test (nreverse (the list sequence)) + (- length end) (- length start) count key))) (nlist-substitute-if* new test sequence start end count key)) (if from-end @@ -1822,13 +1864,14 @@ SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) + (count (adjust-count count))) (declare (fixnum end count)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) - start end count key)) + (let ((length (length sequence))) + (nreverse (nlist-substitute-if-not* + new test (nreverse (the list sequence)) + (- length end) (- length start) count key))) (nlist-substitute-if-not* new test sequence start end count key)) (if from-end @@ -1982,12 +2025,8 @@ ;;; perhaps it's worth optimizing the -if-not versions in the same ;;; way as the others? ;;; -;;; That sounds reasonable, so if someone wants to submit patches to -;;; make the -IF-NOT functions compile as efficiently as the -;;; corresponding -IF variants do, go for it. -- WHN 2001-10-06) -;;; -;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT -;;; too) within the implementation of SBCL. +;;; FIXME: Maybe remove uses of these deprecated functions (and +;;; definitely of :TEST-NOT) within the implementation of SBCL. (declaim (inline find-if-not position-if-not)) (macrolet ((def-find-position-if-not (fun-name values-index) `(defun ,fun-name (predicate sequence