X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=b05450e915a3b5bfb6619aba36a93bea9f6f1ba2;hb=0d3d3a78055fa485985cda2df688f3cd7e9adb18;hp=a2c9d661ad54fe86d85a5beae54e68fb37068909;hpb=33b3c0e45a34f035fa918682832f1affa6747930;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index a2c9d66..b05450e 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -61,11 +61,23 @@ '((start end length sequence) (start1 end1 length1 sequence1) (start2 end2 length2 sequence2))) + (key nil + nil + (and key (%coerce-callable-to-fun key)) + (or null function)) + (test #'eql + nil + (%coerce-callable-to-fun test) + function) + (test-not nil + nil + (and test-not (%coerce-callable-to-fun test-not)) + (or null function)) )) (sb!xc:defmacro define-sequence-traverser (name args &body body) (multiple-value-bind (body declarations docstring) - (parse-body body t) + (parse-body body :doc-string-allowed t) (collect ((new-args) (new-declarations) (adjustments)) (dolist (arg args) (case arg @@ -252,9 +264,23 @@ (defun make-sequence (type length &key (initial-element nil iep)) #!+sb-doc "Return a sequence of the given TYPE and LENGTH, with elements initialized - to :INITIAL-ELEMENT." + to INITIAL-ELEMENT." (declare (fixnum length)) - (let ((type (specifier-type type))) + (let* ((adjusted-type + (typecase type + (atom (cond + ((eq type 'string) '(vector character)) + ((eq type 'simple-string) '(simple-array character (*))) + (t type))) + (cons (cond + ((eq (car type) 'string) `(vector character ,@(cdr type))) + ((eq (car type) 'simple-string) + `(simple-array character ,(if (cdr type) + (cdr type) + '(*)))) + (t type))) + (t type))) + (type (specifier-type adjusted-type))) (cond ((csubtypep type (specifier-type 'list)) (cond ((type= type (specifier-type 'list)) @@ -265,42 +291,42 @@ (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))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (make-list length :initial-element initial-element))) ;; 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 - ;; what the upgraded-array-element-type is?" [consider - ;; (OR STRING BIT-VECTOR)] - (progn - (aver (= (length (array-type-dimensions type)) 1)) - (let ((etype (type-specifier + (cond + (;; is it immediately obvious what the result type is? + (typep type 'array-type) + (progn + (aver (= (length (array-type-dimensions type)) 1)) + (let* ((etype (type-specifier (array-type-specialized-element-type type))) + (etype (if (eq etype '*) t etype)) (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)))) + (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))))) + (t (sequence-type-too-hairy (type-specifier type))))) (t (bad-sequence-type-error (type-specifier type)))))) ;;;; SUBSEQ @@ -447,6 +473,8 @@ (1- source-index))) ((= target-index (the fixnum (1- target-start))) target-sequence) (declare (fixnum target-index source-index)) + ;; disable bounds checking + (declare (optimize (safety 0))) (setf (aref target-sequence target-index) (aref source-sequence source-index)))) (do ((target-index target-start (1+ target-index)) @@ -455,6 +483,8 @@ (= source-index (the fixnum source-end))) target-sequence) (declare (fixnum target-index source-index)) + ;; disable bounds checking + (declare (optimize (safety 0))) (setf (aref target-sequence target-index) (aref source-sequence source-index))))) @@ -539,6 +569,15 @@ (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) +#!+sb-unicode +(defun simple-character-string-replace-from-simple-character-string* + (target-sequence source-sequence + target-start target-end source-start source-end) + (declare (type (simple-array character (*)) target-sequence source-sequence)) + (when (null target-end) (setq target-end (length target-sequence))) + (when (null source-end) (setq source-end (length source-sequence))) + (mumble-replace-from-mumble)) + (define-sequence-traverser replace (sequence1 sequence2 &key start1 end1 start2 end2) #!+sb-doc @@ -579,7 +618,7 @@ (sb!xc:defmacro list-reverse-macro (sequence) `(do ((new-list ())) - ((atom ,sequence) new-list) + ((endp ,sequence) new-list) (push (pop ,sequence) new-list))) ) ; EVAL-WHEN @@ -605,17 +644,17 @@ (sb!xc:defmacro vector-nreverse (sequence) `(let ((length (length (the vector ,sequence)))) - (declare (fixnum length)) - (do ((left-index 0 (1+ left-index)) - (right-index (1- length) (1- right-index)) - (half-length (truncate length 2))) - ((= left-index half-length) ,sequence) - (declare (fixnum left-index right-index half-length)) - (rotatef (aref ,sequence left-index) - (aref ,sequence right-index))))) + (when (>= length 2) + (do ((left-index 0 (1+ left-index)) + (right-index (1- length) (1- right-index))) + ((<= right-index left-index)) + (declare (type index left-index right-index)) + (rotatef (aref ,sequence left-index) + (aref ,sequence right-index)))) + ,sequence)) (sb!xc:defmacro list-nreverse-macro (list) - `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st))) + `(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st))) (2nd ,list 1st) (3rd '() 2nd)) ((atom 2nd) 3rd) @@ -711,19 +750,20 @@ (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))) + (sequence-type-length-mismatch-error + type + ;; FIXME: circular list issues. + (reduce #'+ sequences :key #'length)))) + ((cons-type-p type) + (multiple-value-bind (min exactp) + (sb!kernel::cons-type-length-info type) + (let ((length (reduce #'+ sequences :key #'length))) + (if exactp + (unless (= length min) + (sequence-type-length-mismatch-error type length)) + (unless (>= length min) + (sequence-type-length-mismatch-error type length))) + (apply #'concat-to-list* sequences)))) (t (sequence-type-too-hairy (type-specifier type))))) ((csubtypep type (specifier-type 'vector)) (apply #'concat-to-simple* output-type-spec sequences)) @@ -1233,7 +1273,7 @@ ) ; EVAL-WHEN (define-sequence-traverser delete - (item sequence &key from-end (test #'eql) test-not start + (item sequence &key from-end test test-not start end count key) #!+sb-doc "Return a sequence formed by destructively removing the specified ITEM from @@ -1452,7 +1492,7 @@ ) ; EVAL-WHEN (define-sequence-traverser remove - (item sequence &key from-end (test #'eql) test-not start + (item sequence &key from-end test test-not start end count key) #!+sb-doc "Return a copy of SEQUENCE with elements satisfying the test (default is @@ -1518,7 +1558,7 @@ (declare (fixnum index)) (setq splice (cdr (rplacd splice (list (car current))))) (setq current (cdr current))) - (do ((index 0 (1+ index))) + (do ((index start (1+ index))) ((or (and end (= index (the fixnum end))) (atom current))) (declare (fixnum index)) @@ -1593,7 +1633,7 @@ (shrink-vector result jndex))) (define-sequence-traverser remove-duplicates - (sequence &key (test #'eql) test-not (start 0) end from-end key) + (sequence &key test test-not start end from-end key) #!+sb-doc "The elements of SEQUENCE are compared pairwise, and if any two match, the one occurring earlier is discarded, unless FROM-END is true, in @@ -1662,7 +1702,7 @@ (setq jndex (1+ jndex))))) (define-sequence-traverser delete-duplicates - (sequence &key (test #'eql) test-not (start 0) end from-end key) + (sequence &key test test-not start end from-end key) #!+sb-doc "The elements of SEQUENCE are examined, and if any two match, one is discarded. The resulting sequence, which may be formed by destroying the @@ -1773,7 +1813,7 @@ ) ; EVAL-WHEN (define-sequence-traverser substitute - (new old sequence &key from-end (test #'eql) test-not + (new old sequence &key from-end test test-not start count end key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements, @@ -1787,26 +1827,28 @@ ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT (define-sequence-traverser substitute-if - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements satisfying the TEST are replaced with NEW. See + except that all elements satisfying the PRED are replaced with NEW. See manual for details." (declare (fixnum start)) (let ((end (or end length)) + (test pred) test-not old) (declare (type index length end)) (subst-dispatch 'if))) (define-sequence-traverser substitute-if-not - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements not satisfying the TEST are replaced with NEW. + except that all elements not satisfying the PRED are replaced with NEW. See manual for details." (declare (fixnum start)) (let ((end (or end length)) + (test pred) test-not old) (declare (type index length end)) @@ -1815,7 +1857,7 @@ ;;;; NSUBSTITUTE (define-sequence-traverser nsubstitute - (new old sequence &key from-end (test #'eql) test-not + (new old sequence &key from-end test test-not end count key start) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements @@ -1867,10 +1909,10 @@ ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT (define-sequence-traverser nsubstitute-if - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements - except that all elements satisfying the TEST are replaced with NEW. + except that all elements satisfying the PRED are replaced with NEW. SEQUENCE may be destructively modified. See manual for details." (declare (fixnum start)) (let ((end (or end length))) @@ -1879,14 +1921,14 @@ (if from-end (let ((length (length sequence))) (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) + new pred (nreverse (the list sequence)) (- length end) (- length start) count key))) - (nlist-substitute-if* new test sequence + (nlist-substitute-if* new pred sequence start end count key)) (if from-end - (nvector-substitute-if* new test sequence -1 + (nvector-substitute-if* new pred sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if* new test sequence 1 + (nvector-substitute-if* new pred sequence 1 start end count key))))) (defun nlist-substitute-if* (new test sequence start end count key) @@ -1907,7 +1949,7 @@ (setq count (1- count))))) (define-sequence-traverser nsubstitute-if-not - (new test sequence &key from-end start end count key) + (new pred sequence &key from-end start end count key) #!+sb-doc "Return a sequence of the same kind as SEQUENCE with the same elements except that all elements not satisfying the TEST are replaced with NEW. @@ -1919,14 +1961,14 @@ (if from-end (let ((length (length sequence))) (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) + new pred (nreverse (the list sequence)) (- length end) (- length start) count key))) - (nlist-substitute-if-not* new test sequence + (nlist-substitute-if-not* new pred sequence start end count key)) (if from-end - (nvector-substitute-if-not* new test sequence -1 + (nvector-substitute-if-not* new pred sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if-not* new test sequence 1 + (nvector-substitute-if-not* new pred sequence 1 start end count key))))) (defun nlist-substitute-if-not* (new test sequence start end count key) @@ -1971,10 +2013,10 @@ (frob sequence nil)))) (typecase sequence (simple-vector (frob2)) - (simple-string (frob2)) + (simple-base-string (frob2)) (t (vector*-frob sequence)))) (declare (type (or index null) p)) - (values f (and p (the index (+ p offset)))))))))) + (values f (and p (the index (- p offset)))))))))) (defun %find-position (item sequence-arg from-end start end key test) (macrolet ((frob (sequence from-end) `(%find-position item ,sequence @@ -2058,22 +2100,22 @@ ) ; EVAL-WHEN -(define-sequence-traverser count-if (test sequence &key from-end start end key) +(define-sequence-traverser count-if (pred sequence &key from-end start end key) #!+sb-doc - "Return the number of elements in SEQUENCE satisfying TEST(el)." + "Return the number of elements in SEQUENCE satisfying PRED(el)." (declare (fixnum start)) (let ((end (or end length))) (declare (type index end)) (seq-dispatch sequence (if from-end - (list-count-if nil t test sequence) - (list-count-if nil nil test sequence)) + (list-count-if nil t pred sequence) + (list-count-if nil nil pred sequence)) (if from-end - (vector-count-if nil t test sequence) - (vector-count-if nil nil test sequence))))) + (vector-count-if nil t pred sequence) + (vector-count-if nil nil pred sequence))))) (define-sequence-traverser count-if-not - (test sequence &key from-end start end key) + (pred sequence &key from-end start end key) #!+sb-doc "Return the number of elements in SEQUENCE not satisfying TEST(el)." (declare (fixnum start)) @@ -2081,11 +2123,11 @@ (declare (type index end)) (seq-dispatch sequence (if from-end - (list-count-if t t test sequence) - (list-count-if t nil test sequence)) + (list-count-if t t pred sequence) + (list-count-if t nil pred sequence)) (if from-end - (vector-count-if t t test sequence) - (vector-count-if t nil test sequence))))) + (vector-count-if t t pred sequence) + (vector-count-if t nil pred sequence))))) (define-sequence-traverser count (item sequence &key from-end start end @@ -2191,7 +2233,7 @@ (define-sequence-traverser mismatch (sequence1 sequence2 - &key from-end (test #'eql) test-not + &key from-end test test-not start1 end1 start2 end2 key) #!+sb-doc "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared @@ -2236,32 +2278,30 @@ `(do ((main ,main (cdr main)) (jndex start1 (1+ jndex)) (sub (nthcdr start1 ,sub) (cdr sub))) - ((or (null main) (null sub) (= (the fixnum end1) jndex)) + ((or (endp main) (endp sub) (<= end1 jndex)) t) - (declare (fixnum jndex)) - (compare-elements (car main) (car sub)))) + (declare (type (integer 0) jndex)) + (compare-elements (car sub) (car main)))) (sb!xc:defmacro search-compare-list-vector (main sub) `(do ((main ,main (cdr main)) (index start1 (1+ index))) - ((or (null main) (= index (the fixnum end1))) t) - (declare (fixnum index)) - (compare-elements (car main) (aref ,sub index)))) + ((or (endp main) (= index end1)) t) + (compare-elements (aref ,sub index) (car main)))) (sb!xc:defmacro search-compare-vector-list (main sub index) `(do ((sub (nthcdr start1 ,sub) (cdr sub)) (jndex start1 (1+ jndex)) (index ,index (1+ index))) - ((or (= (the fixnum end1) jndex) (null sub)) t) - (declare (fixnum jndex index)) - (compare-elements (aref ,main index) (car sub)))) + ((or (<= end1 jndex) (endp sub)) t) + (declare (type (integer 0) jndex)) + (compare-elements (car sub) (aref ,main index)))) (sb!xc:defmacro search-compare-vector-vector (main sub index) `(do ((index ,index (1+ index)) (sub-index start1 (1+ sub-index))) - ((= sub-index (the fixnum end1)) t) - (declare (fixnum sub-index index)) - (compare-elements (aref ,main index) (aref ,sub sub-index)))) + ((= sub-index end1) t) + (compare-elements (aref ,sub sub-index) (aref ,main index)))) (sb!xc:defmacro search-compare (main-type main sub index) (if (eq main-type 'list) @@ -2281,12 +2321,10 @@ (sb!xc:defmacro list-search (main sub) `(do ((main (nthcdr start2 ,main) (cdr main)) (index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) + (terminus (- end2 (the (integer 0) (- end1 start1)))) (last-match ())) ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) + (declare (type (integer 0) index2)) (if (search-compare list main ,sub index2) (if from-end (setq last-match index2) @@ -2294,12 +2332,10 @@ (sb!xc:defmacro vector-search (main sub) `(do ((index2 start2 (1+ index2)) - (terminus (- (the fixnum end2) - (the fixnum (- (the fixnum end1) - (the fixnum start1))))) + (terminus (- end2 (the (integer 0) (- end1 start1)))) (last-match ())) ((> index2 terminus) last-match) - (declare (fixnum index2 terminus)) + (declare (type (integer 0) index2)) (if (search-compare vector ,main ,sub index2) (if from-end (setq last-match index2) @@ -2309,7 +2345,7 @@ (define-sequence-traverser search (sequence1 sequence2 - &key from-end (test #'eql) test-not + &key from-end test test-not start1 end1 start2 end2 key) (declare (fixnum start1 start2)) (let ((end1 (or end1 length1))