X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=0c9448b4b82d48a3634bf6f5880a50483dee60cf;hb=967c14df90ace8b868280d93deabfd6742fb769d;hp=68753f0150ac6928bedbac8e3886bd24b4470fb4;hpb=f569125f053885898e83203324a72e11c9de0f85;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 68753f0..0c9448b 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -36,19 +36,16 @@ (sb!xc:defmacro make-sequence-like (sequence length) #!+sb-doc "Return a sequence of the same type as SEQUENCE and the given LENGTH." - (let ((type (gensym "TYPE-"))) - `(if *type-system-initialized* - (let ((,type (specifier-type (type-of ,sequence)))) - (if (csubtypep ,type (specifier-type 'list)) - (make-sequence 'list ,length) - (progn - (aver (csubtypep ,type (specifier-type 'vector))) - (aver (array-type-p ,type)) - (setf (array-type-dimensions ,type) (list '*)) - (make-sequence (type-specifier ,type) ,length)))) - (if (typep ,sequence 'string) - (make-string ,length) - (error "MAKE-SEQUENCE-LIKE on non-STRING too early in cold-init"))))) + `(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 @@ -59,6 +56,34 @@ :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 @@ -107,6 +132,14 @@ `(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." @@ -153,7 +186,28 @@ (declare (fixnum length)) (let ((type (specifier-type type))) (cond ((csubtypep type (specifier-type 'list)) - (make-list length :initial-element initial-element)) + (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) ;; KLUDGE: the above test essentially asks "Do we know @@ -166,13 +220,7 @@ (type-length (car (array-type-dimensions type)))) (unless (or (eq type-length '*) (= type-length length)) - (error 'simple-type-error - :datum length - :expected-type `(eql ,type-length) - :format-control "The length requested (~S) ~ - does not match the length type restriction in ~S." - :format-arguments (list length - (type-specifier type)))) + (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 @@ -182,13 +230,7 @@ (make-array length :element-type etype :initial-element initial-element) (make-array length :element-type etype)))) - ;; We have a subtype of VECTOR, but it isn't an array - ;; type. Maybe this should be a BUG instead? - (error 'simple-type-error - :datum type - :expected-type 'sequence - :format-control "~S is too hairy for MAKE-SEQUENCE." - :format-arguments (list (type-specifier type))))) + (sequence-type-too-hairy (type-specifier type)))) (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ @@ -458,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 ,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) @@ -489,7 +531,7 @@ (list-reverse-macro sequence)) (defun vector-reverse* (sequence) - (vector-reverse sequence (type-of sequence))) + (vector-reverse sequence)) ;;;; NREVERSE @@ -592,10 +634,33 @@ specified OUTPUT-TYPE-SPEC." (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)) - ((csubtypep type (specifier-type 'list)) - (apply #'concat-to-list* sequences)) (t (bad-sequence-type-error output-type-spec))))) @@ -1109,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 @@ -1147,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 @@ -1185,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 @@ -1264,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? @@ -1332,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 @@ -1350,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 @@ -1368,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 @@ -1470,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 @@ -1543,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)) @@ -1656,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))) @@ -1671,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) @@ -1687,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) @@ -1704,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 @@ -1754,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 @@ -1794,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 @@ -1954,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