X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=ccc89a741b3b569c783751a984cfba3eeae0d690;hb=b2ad48f269cd6b9403820588d65eac526e4e32fd;hp=12df112f30dbe957a9b770cf7e100e486cd0d505;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 12df112..ccc89a7 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -22,11 +22,106 @@ (eval-when (:compile-toplevel) +(defparameter *sequence-keyword-info* + ;; (name default supplied-p adjustment new-type) + `((count nil + nil + (etypecase count + (null (1- most-positive-fixnum)) + (fixnum (max 0 count)) + (integer (if (minusp count) + 0 + (1- most-positive-fixnum)))) + (mod #.sb!xc:most-positive-fixnum)) + ,@(mapcan (lambda (names) + (destructuring-bind (start end length sequence) names + (list + `(,start + 0 + nil + (if (<= 0 ,start ,length) + ,start + (signal-bounding-indices-bad-error ,sequence + ,start ,end)) + index) + `(,end + nil + nil + (if (or (null ,end) (<= ,start ,end ,length)) + ;; Defaulting of NIL is done inside the + ;; bodies, for ease of sharing with compiler + ;; transforms. + ;; + ;; FIXME: defend against non-number non-NIL + ;; stuff? + ,end + (signal-bounding-indices-bad-error ,sequence + ,start ,end)) + (or null index))))) + '((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 :doc-string-allowed t) + (collect ((new-args) (new-declarations) (adjustments)) + (dolist (arg args) + (case arg + ;; FIXME: make this robust. And clean. + ((sequence) + (new-args arg) + (adjustments '(length (etypecase sequence + (list (length sequence)) + (vector (length sequence))))) + (new-declarations '(type index length))) + ((sequence1) + (new-args arg) + (adjustments '(length1 (etypecase sequence1 + (list (length sequence1)) + (vector (length sequence1))))) + (new-declarations '(type index length1))) + ((sequence2) + (new-args arg) + (adjustments '(length2 (etypecase sequence2 + (list (length sequence2)) + (vector (length sequence2))))) + (new-declarations '(type index length2))) + ((function predicate) + (new-args arg) + (adjustments `(,arg (%coerce-callable-to-fun ,arg)))) + (t (let ((info (cdr (assoc arg *sequence-keyword-info*)))) + (cond (info + (destructuring-bind (default supplied-p adjuster type) info + (new-args `(,arg ,default ,@(when supplied-p (list supplied-p)))) + (adjustments `(,arg ,adjuster)) + (new-declarations `(type ,type ,arg)))) + (t (new-args arg))))))) + `(defun ,name ,(new-args) + ,@(when docstring (list docstring)) + ,@declarations + (let* (,@(adjustments)) + (declare ,@(new-declarations)) + ,@body))))) + ;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE. ;;; ;;; 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 +131,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,58 +206,25 @@ (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)))))) - +(declaim (ftype (function (sequence index) nil) signal-index-too-large-error)) (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 `(integer 0 ,max-index) ;; 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)))) + '(integer 0 (0)))))) + +(defun signal-bounding-indices-bad-error (sequence start end) + (let ((length (length sequence))) + (error 'bounding-indices-bad-error + :datum (cons start end) + :expected-type `(cons (integer 0 ,length) + (or null (integer ,start ,length))) + :object sequence))) (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -160,90 +264,115 @@ (vector (length (truly-the vector sequence))) (list (length (truly-the list sequence))))) -(defun make-sequence (type length &key (initial-element NIL iep)) +(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)) - (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))) + ((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) - (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)))))) + (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))))) + (t (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))) + (declare (type index start)) + (declare (type (or null index) end)) + (when (null end) + (setf end (length sequence))) + (unless (<= 0 start end (length sequence)) + (signal-bounding-indices-bad-error sequence start 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)) - (declare (type fixnum start)) - (declare (type (or null fixnum) end)) - (if (and end (>= start (the fixnum end))) - () - (let* ((groveled (nthcdr start sequence)) - (result (list (car groveled)))) - (if groveled - (do ((list (cdr groveled) (cdr list)) - (splice result (cdr (rplacd splice (list (car list))))) - (index (1+ start) (1+ index))) - ((or (atom list) (and end (= index (the fixnum end)))) - result) - (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). + ;; the INDEX declaration isn't actually mandatory, but it's true for + ;; all practical purposes. + (declare (type index start)) + (declare (type (or null index) end)) + (do ((list sequence (cdr list)) + (index 0 (1+ index)) + (result nil)) + (nil) + (cond + ((null list) (if (or (and end (> end index)) + (< index start)) + (signal-bounding-indices-bad-error sequence start end) + (return (nreverse result)))) + ((< index start) nil) + ((and end (= index end)) (return (nreverse result))) + (t (push (car list) result))))) + (defun subseq (sequence start &optional end) #!+sb-doc "Return a copy of a subsequence of SEQUENCE starting with element number @@ -256,11 +385,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 +418,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 @@ -324,11 +454,7 @@ (when (null end) (setq end (length sequence))) (vector-fill sequence item start end)) -;;; FILL 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 fill (sequence item &key (start 0) end) +(define-sequence-traverser fill (sequence item &key start end) #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM." (seq-dispatch sequence (list-fill* sequence item start end) @@ -350,6 +476,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)) @@ -358,6 +486,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))))) @@ -442,19 +572,30 @@ (when (null source-end) (setq source-end (length source-sequence))) (mumble-replace-from-mumble)) -;;; REPLACE cannot default END arguments to the length of SEQUENCE since it -;;; is not an error to supply NIL for their values. We must test for ENDs -;;; being NIL in the body of the function. -(defun replace (target-sequence source-sequence &key - ((:start1 target-start) 0) - ((:end1 target-end)) - ((:start2 source-start) 0) - ((:end2 source-end))) +#!+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 "The target sequence is destructively modified by copying successive elements into it from the source sequence." - (let ((target-end (or target-end (length target-sequence))) - (source-end (or source-end (length source-sequence)))) + (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or + ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind + ;; these things here so that legacy code gets the names it's + ;; expecting. We could use &AUX instead :-/. + (target-sequence sequence1) + (source-sequence sequence2) + (target-start start1) + (source-start start2) + (target-end (or end1 length1)) + (source-end (or end2 length2))) (seq-dispatch target-sequence (seq-dispatch source-sequence (list-replace-from-list) @@ -467,12 +608,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) @@ -480,7 +621,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 @@ -498,7 +639,7 @@ (list-reverse-macro sequence)) (defun vector-reverse* (sequence) - (vector-reverse sequence (type-of sequence))) + (vector-reverse sequence)) ;;;; NREVERSE @@ -506,17 +647,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) @@ -571,7 +712,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 +735,43 @@ ) ; 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. + (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)) (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 +891,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 +920,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-function (%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 @@ -768,41 +929,26 @@ ;; there's no consing overhead to dwarf our inefficiency.) (if (and (null more-sequences) (null result-type)) - (%map-for-effect-arity-1 really-function first-sequence) + (%map-for-effect-arity-1 really-fun first-sequence) ;; Otherwise, use the industrial-strength full-generality ;; 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-function sequences)) - (list (%map-to-list really-function sequences)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string simple-base-string) - (%map-to-vector result-type really-function sequences)) + (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-function - 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 @@ -936,8 +1082,7 @@ ref) `(do ((index ,start (1+ index)) (value ,initial-value)) - ((= index (the fixnum ,end)) value) - (declare (fixnum index)) + ((>= index ,end) value) (setq value (funcall ,function value (apply-key ,key (,ref ,sequence index)))))) @@ -951,8 +1096,7 @@ `(do ((index (1- ,end) (1- index)) (value ,initial-value) (terminus (1- ,start))) - ((= index terminus) value) - (declare (fixnum index terminus)) + ((<= index terminus) value) (setq value (funcall ,function (apply-key ,key (,ref ,sequence index)) value)))) @@ -965,14 +1109,13 @@ initial-value ivp) `(let ((sequence (nthcdr ,start ,sequence))) - (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) (sequence (if ,ivp sequence (cdr sequence)) (cdr sequence)) (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) (funcall ,function value (apply-key ,key (car sequence))))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) + ((>= count ,end) value)))) (sb!xc:defmacro list-reduce-from-end (function sequence @@ -981,25 +1124,23 @@ end initial-value ivp) - `(let ((sequence (nthcdr (- (the fixnum (length ,sequence)) - (the fixnum ,end)) + `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence)))) - (do ((count (if ,ivp ,start (1+ (the fixnum ,start))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) (sequence (if ,ivp sequence (cdr sequence)) (cdr sequence)) (value (if ,ivp ,initial-value (apply-key ,key (car sequence))) (funcall ,function (apply-key ,key (car sequence)) value))) - ((= count (the fixnum ,end)) value) - (declare (fixnum count))))) + ((>= count ,end) value)))) ) ; EVAL-WHEN -(defun reduce (function sequence &key key from-end (start 0) - end (initial-value nil ivp)) +(define-sequence-traverser reduce + (function sequence &key key from-end start end (initial-value nil ivp)) (declare (type index start)) (let ((start start) - (end (or end (length sequence)))) + (end (or end length))) (declare (type index start end)) (cond ((= end start) (if ivp initial-value (funcall function))) @@ -1030,7 +1171,7 @@ `(do ((index start (1+ index)) (jndex start) (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + ((or (= index (the fixnum end)) (= number-zapped count)) (do ((index index (1+ index)) ; Copy the rest of the vector. (jndex jndex (1+ jndex))) ((= index (the fixnum length)) @@ -1040,8 +1181,8 @@ (declare (fixnum index jndex number-zapped)) (setf (aref sequence jndex) (aref sequence index)) (if ,pred - (setq number-zapped (1+ number-zapped)) - (setq jndex (1+ jndex))))) + (incf number-zapped) + (incf jndex)))) (sb!xc:defmacro mumble-delete-from-end (pred) `(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers. @@ -1049,7 +1190,7 @@ (losers ()) this-element (terminus (1- start))) - ((or (= index terminus) (= number-zapped (the fixnum count))) + ((or (= index terminus) (= number-zapped count)) (do ((losers losers) ; Delete the losers. (index start (1+ index)) (jndex start)) @@ -1064,11 +1205,11 @@ (setf (aref sequence jndex) (aref sequence index)) (if (= index (the fixnum (car losers))) (pop losers) - (setq jndex (1+ jndex))))) + (incf jndex)))) (declare (fixnum index number-zapped terminus)) (setq this-element (aref sequence index)) (when ,pred - (setq number-zapped (1+ number-zapped)) + (incf number-zapped) (push index losers)))) (sb!xc:defmacro normal-mumble-delete () @@ -1089,12 +1230,12 @@ (previous (nthcdr start handle)) (index start (1+ index)) (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + ((or (= index (the fixnum end)) (= number-zapped count)) (cdr handle)) (declare (fixnum index number-zapped)) (cond (,pred (rplacd previous (cdr current)) - (setq number-zapped (1+ number-zapped))) + (incf number-zapped)) (t (setq previous (cdr previous))))))) @@ -1106,12 +1247,12 @@ (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle)) (index start (1+ index)) (number-zapped 0)) - ((or (= index (the fixnum end)) (= number-zapped (the fixnum count))) + ((or (= index (the fixnum end)) (= number-zapped count)) (nreverse (cdr handle))) (declare (fixnum index number-zapped)) (cond (,pred (rplacd previous (cdr current)) - (setq number-zapped (1+ number-zapped))) + (incf number-zapped)) (t (setq previous (cdr previous))))))) @@ -1129,17 +1270,15 @@ ) ; EVAL-WHEN -(defun delete (item sequence &key from-end (test #'eql) test-not (start 0) - end count key) +(define-sequence-traverser delete + (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 the given SEQUENCE." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (normal-list-delete-from-end) @@ -1168,16 +1307,14 @@ ) ; EVAL-WHEN -(defun delete-if (predicate sequence &key from-end (start 0) key end count) +(define-sequence-traverser delete-if + (predicate sequence &key from-end start key end count) #!+sb-doc "Return a sequence formed by destructively removing the elements satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (if-list-delete-from-end) @@ -1206,16 +1343,14 @@ ) ; EVAL-WHEN -(defun delete-if-not (predicate sequence &key from-end (start 0) end key count) +(define-sequence-traverser delete-if-not + (predicate sequence &key from-end start end key count) #!+sb-doc "Return a sequence formed by destructively removing the elements not satisfying the specified PREDICATE from the given SEQUENCE." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (if-not-list-delete-from-end) @@ -1242,7 +1377,7 @@ (number-zapped 0) (this-element)) ((or (= index (the fixnum ,finish)) - (= number-zapped (the fixnum count))) + (= number-zapped count)) (do ((index index (,bump index)) (new-index new-index (,bump new-index))) ((= index (the fixnum ,right)) (shrink-vector result new-index)) @@ -1250,7 +1385,7 @@ (setf (aref result new-index) (aref sequence index)))) (declare (fixnum index new-index number-zapped)) (setq this-element (aref sequence index)) - (cond (,pred (setq number-zapped (1+ number-zapped))) + (cond (,pred (incf number-zapped)) (t (setf (aref result new-index) this-element) (setq new-index (,bump new-index)))))) @@ -1292,17 +1427,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 count)) (do ((index index (1+ index))) ((null sequence) ,(if reverse? @@ -1352,17 +1489,15 @@ ) ; EVAL-WHEN -(defun remove (item sequence &key from-end (test #'eql) test-not (start 0) - end count key) +(define-sequence-traverser remove + (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 EQL) with ITEM removed." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (normal-list-remove-from-end) @@ -1371,16 +1506,13 @@ (normal-mumble-remove-from-end) (normal-mumble-remove))))) -(defun remove-if (predicate sequence &key from-end (start 0) end count key) +(define-sequence-traverser remove-if + (predicate sequence &key from-end start end count key) #!+sb-doc - "Return a copy of sequence with elements such that predicate(element) - is non-null removed" + "Return a copy of sequence with elements satisfying PREDICATE removed." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (if-list-remove-from-end) @@ -1389,16 +1521,13 @@ (if-mumble-remove-from-end) (if-mumble-remove))))) -(defun remove-if-not (predicate sequence &key from-end (start 0) end count key) +(define-sequence-traverser remove-if-not + (predicate sequence &key from-end start end count key) #!+sb-doc - "Return a copy of sequence with elements such that predicate(element) - is null removed" + "Return a copy of sequence with elements not satisfying PREDICATE removed." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (seq-dispatch sequence (if from-end (if-not-list-remove-from-end) @@ -1425,16 +1554,20 @@ (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)) (if (or (and from-end - (not (member (apply-key key (car current)) - (nthcdr (1+ start) result) - :test test - :test-not test-not - :key key))) + (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)) @@ -1443,7 +1576,9 @@ ()) (declare (fixnum i)) (if (if test-not - (not (funcall test-not it (apply-key key (car l)))) + (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)))))) @@ -1469,12 +1604,20 @@ (do ((elt)) ((= index end)) (setq elt (aref vector index)) + ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT + ;; arguments simultaneously is a little fragile, since ANSI says + ;; we can't depend on it, so we need to remember to keep that + ;; extension in our implementation. It'd probably be better to + ;; rewrite this to avoid passing both (as + ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18). (unless (or (and from-end - (position (apply-key key elt) result :start start - :end jndex :test test :test-not test-not :key key)) + (position (apply-key key elt) result + :start start :end jndex + :test test :test-not test-not :key key)) (and (not from-end) - (position (apply-key key elt) vector :start (1+ index) - :end end :test test :test-not test-not :key key))) + (position (apply-key key elt) vector + :start (1+ index) :end end + :test test :test-not test-not :key key))) (setf (aref result jndex) elt) (setq jndex (1+ jndex))) (setq index (1+ index))) @@ -1485,20 +1628,15 @@ (setq jndex (1+ jndex))) (shrink-vector result jndex))) -(defun remove-duplicates (sequence &key - (test #'eql) - test-not - (start 0) - from-end - end - key) +(define-sequence-traverser remove-duplicates + (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 elements of SEQUENCE are compared pairwise, and if any two match, the one occurring earlier is discarded, unless FROM-END is true, in 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 @@ -1559,23 +1697,18 @@ :end (if from-end jndex end) :test-not test-not) (setq jndex (1+ jndex))))) -(defun delete-duplicates (sequence &key - (test #'eql) - test-not - (start 0) - from-end - end - key) +(define-sequence-traverser delete-duplicates + (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 + "The elements of SEQUENCE are examined, and if any two match, one is 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)) - (vector-delete-duplicates* sequence test test-not key from-end start end))) + (vector-delete-duplicates* sequence test test-not key from-end start end))) ;;;; SUBSTITUTE @@ -1606,7 +1739,7 @@ (funcall test old (apply-key key elt)))) (if (funcall test (apply-key key elt))) (if-not (not (funcall test (apply-key key elt))))) - (setq count (1- count)) + (decf count) new) (t elt)))))) (setq list (cdr list))) @@ -1675,70 +1808,63 @@ ) ; EVAL-WHEN -(defun substitute (new old sequence &key from-end (test #'eql) test-not - (start 0) count end key) +(define-sequence-traverser substitute + (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, - except that all elements equal to OLD are replaced with NEW. See manual - for details." + except that all elements equal to OLD are replaced with NEW." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum))) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length))) + (declare (type index end)) (subst-dispatch 'normal))) ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT -(defun substitute-if (new test sequence &key from-end (start 0) end count key) +(define-sequence-traverser substitute-if + (new predicate 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 - manual for details." + except that all elements satisfying the PRED are replaced with NEW." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum)) - test-not - old) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length)) + (test predicate) + (test-not nil) + old) + (declare (type index length end)) (subst-dispatch 'if))) -(defun substitute-if-not (new test sequence &key from-end (start 0) - end count key) +(define-sequence-traverser substitute-if-not + (new predicate 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. - See manual for details." + except that all elements not satisfying the PRED are replaced with NEW." (declare (fixnum start)) - (let* ((length (length sequence)) - (end (or end length)) - (count (or count most-positive-fixnum)) - test-not - old) - (declare (type index length end) - (fixnum count)) + (let ((end (or end length)) + (test predicate) + (test-not nil) + old) + (declare (type index length end)) (subst-dispatch 'if-not))) ;;;; NSUBSTITUTE -(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not - end count key (start 0)) +(define-sequence-traverser nsubstitute + (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 - except that all elements equal to OLD are replaced with NEW. The SEQUENCE - may be destructively modified. See manual for details." + except that all elements equal to OLD are replaced with NEW. SEQUENCE + may be destructively modified." (declare (fixnum start)) - (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) - (declare (fixnum count)) + (let ((end (or end length))) (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 @@ -1775,26 +1901,27 @@ ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT -(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key) +(define-sequence-traverser nsubstitute-if + (new predicate 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. - SEQUENCE may be destructively modified. See manual for details." + except that all elements satisfying PREDICATE are replaced with NEW. + SEQUENCE may be destructively modified." (declare (fixnum start)) - (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) - (declare (fixnum end count)) + (let ((end (or end length))) + (declare (fixnum end)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if* - new test (nreverse (the list sequence)) - start end count key)) - (nlist-substitute-if* new test sequence + (let ((length (length sequence))) + (nreverse (nlist-substitute-if* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key))) + (nlist-substitute-if* new predicate sequence start end count key)) (if from-end - (nvector-substitute-if* new test sequence -1 + (nvector-substitute-if* new predicate sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if* new test sequence 1 + (nvector-substitute-if* new predicate sequence 1 start end count key))))) (defun nlist-substitute-if* (new test sequence start end count key) @@ -1814,27 +1941,27 @@ (setf (aref sequence index) new) (setq count (1- count))))) -(defun nsubstitute-if-not (new test sequence &key from-end (start 0) - end count key) +(define-sequence-traverser nsubstitute-if-not + (new predicate 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. - SEQUENCE may be destructively modified. See manual for details." + except that all elements not satisfying PREDICATE are replaced with NEW. + SEQUENCE may be destructively modified." (declare (fixnum start)) - (let ((end (or end (length sequence))) - (count (or count most-positive-fixnum))) - (declare (fixnum end count)) + (let ((end (or end length))) + (declare (fixnum end)) (if (listp sequence) (if from-end - (nreverse (nlist-substitute-if-not* - new test (nreverse (the list sequence)) - start end count key)) - (nlist-substitute-if-not* new test sequence + (let ((length (length sequence))) + (nreverse (nlist-substitute-if-not* + new predicate (nreverse (the list sequence)) + (- length end) (- length start) count key))) + (nlist-substitute-if-not* new predicate sequence start end count key)) (if from-end - (nvector-substitute-if-not* new test sequence -1 + (nvector-substitute-if-not* new predicate sequence -1 (1- end) (1- start) count key) - (nvector-substitute-if-not* new test sequence 1 + (nvector-substitute-if-not* new predicate sequence 1 start end count key))))) (defun nlist-substitute-if-not* (new test sequence start end count key) @@ -1844,7 +1971,7 @@ ((or (= index end) (null list) (= count 0)) sequence) (when (not (funcall test (apply-key key (car list)))) (rplaca list new) - (setq count (1- count))))) + (decf count)))) (defun nvector-substitute-if-not* (new test sequence incrementer start end count key) @@ -1852,27 +1979,14 @@ ((or (= index end) (= count 0)) sequence) (when (not (funcall test (apply-key key (aref sequence index)))) (setf (aref sequence index) new) - (setq count (1- count))))) + (decf count)))) ;;;; FIND, POSITION, and their -IF and -IF-NOT variants -;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, -;;; POSITION-IF, etc. -(declaim (inline effective-find-position-test effective-find-position-key)) (defun effective-find-position-test (test test-not) - (cond ((and test test-not) - (error "can't specify both :TEST and :TEST-NOT")) - (test (%coerce-callable-to-fun test)) - (test-not - ;; (Without DYNAMIC-EXTENT, this is potentially horribly - ;; inefficient, but since the TEST-NOT option is deprecated - ;; anyway, we don't care.) - (complement (%coerce-callable-to-fun test-not))) - (t #'eql))) + (effective-find-position-test test test-not)) (defun effective-find-position-key (key) - (if key - (%coerce-callable-to-fun key) - #'identity)) + (effective-find-position-key key)) ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF (macrolet (;; shared logic for defining %FIND-POSITION and @@ -1881,20 +1995,21 @@ (frobs () `(etypecase sequence-arg (list (frob sequence-arg from-end)) - (vector + (vector (with-array-data ((sequence sequence-arg :offset-var offset) (start start) - (end (or end (length sequence-arg)))) + (end (%check-vector-sequence-bounds + sequence-arg start end))) (multiple-value-bind (f p) (macrolet ((frob2 () '(if from-end (frob sequence t) (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 @@ -1910,197 +2025,132 @@ (vector*-frob (sequence) `(%find-position-if-vector-macro predicate ,sequence from-end start end key))) + (frobs))) + (defun %find-position-if-not (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if-not predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-not-vector-macro predicate ,sequence + from-end start end key))) (frobs)))) -;;; the user interface to FIND and POSITION: Get all our ducks in a -;;; row, then call %FIND-POSITION. -(declaim (inline find position)) -(macrolet ((def-find-position (fun-name values-index) - `(defun ,fun-name (item - sequence - &key - from-end - (start 0) - end - key - test - test-not) - (nth-value - ,values-index - (%find-position item - sequence - from-end - start - end - (effective-find-position-key key) - (effective-find-position-test test - test-not)))))) - (def-find-position find 0) - (def-find-position position 1)) +;;; the user interface to FIND and POSITION: just interpreter stubs, +;;; nowadays. +(defun find (item sequence &key from-end (start 0) end key test test-not) + ;; FIXME: this can't be the way to go, surely? + (find item sequence :from-end from-end :start start :end end :key key + :test test :test-not test-not)) +(defun position (item sequence &key from-end (start 0) end key test test-not) + (position item sequence :from-end from-end :start start :end end :key key + :test test :test-not test-not)) ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous ;;; to the interface to FIND and POSITION -(declaim (inline find-if position-if)) -(macrolet ((def-find-position-if (fun-name values-index) - `(defun ,fun-name (predicate sequence - &key from-end (start 0) end key) - (nth-value - ,values-index - (%find-position-if (%coerce-callable-to-fun predicate) - sequence - from-end - start - end - (effective-find-position-key key)))))) - - (def-find-position-if find-if 0) - (def-find-position-if position-if 1)) - -;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We don't -;;; bother to worry about optimizing them. -;;; -;;; (Except note that on Sat, Oct 06, 2001 at 04:22:38PM +0100, -;;; Christophe Rhodes wrote on sbcl-devel -;;; -;;; My understanding is that while the :test-not argument is -;;; deprecated in favour of :test (complement #'foo) because of -;;; semantic difficulties (what happens if both :test and :test-not -;;; are supplied, etc) the -if-not variants, while officially -;;; deprecated, would be undeprecated were X3J13 actually to produce -;;; a revised standard, as there are perfectly legitimate idiomatic -;;; reasons for allowing the -if-not versions equal status, -;;; particularly remove-if-not (== filter). -;;; -;;; This is only an informal understanding, I grant you, but -;;; 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. -(macrolet ((def-find-position-if-not (fun-name values-index) - `(defun ,fun-name (predicate sequence - &key from-end (start 0) end key) - (nth-value - ,values-index - (%find-position-if (complement (%coerce-callable-to-fun - predicate)) - sequence - from-end - start - end - (effective-find-position-key key)))))) - (def-find-position-if-not find-if-not 0) - (def-find-position-if-not position-if-not 1)) +(defun find-if (predicate sequence &key from-end (start 0) end key) + (find-if predicate sequence :from-end from-end :start start + :end end :key key)) +(defun position-if (predicate sequence &key from-end (start 0) end key) + (position-if predicate sequence :from-end from-end :start start + :end end :key key)) + +(defun find-if-not (predicate sequence &key from-end (start 0) end key) + (find-if-not predicate sequence :from-end from-end :start start + :end end :key key)) +(defun position-if-not (predicate sequence &key from-end (start 0) end key) + (position-if-not predicate sequence :from-end from-end :start start + :end end :key key)) -;;;; COUNT +;;;; COUNT-IF, COUNT-IF-NOT, and COUNT (eval-when (:compile-toplevel :execute) -(sb!xc:defmacro vector-count (item sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if test-not - (unless (funcall test-not ,item - (apply-key key (aref ,sequence index))) - (setq count (1+ count))) - (when (funcall test ,item (apply-key key (aref ,sequence index))) - (setq count (1+ count)))))) - -(sb!xc:defmacro list-count (item sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if test-not - (unless (funcall test-not ,item (apply-key key (pop sequence))) - (setq count (1+ count))) - (when (funcall test ,item (apply-key key (pop sequence))) - (setq count (1+ count)))))) +(sb!xc:defmacro vector-count-if (notp from-end-p predicate sequence) + (let ((next-index (if from-end-p '(1- index) '(1+ index))) + (pred `(funcall ,predicate (apply-key key (aref ,sequence index))))) + `(let ((%start ,(if from-end-p '(1- end) 'start)) + (%end ,(if from-end-p '(1- start) 'end))) + (do ((index %start ,next-index) + (count 0)) + ((= index (the fixnum %end)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) + +(sb!xc:defmacro list-count-if (notp from-end-p predicate sequence) + (let ((pred `(funcall ,predicate (apply-key key (pop sequence))))) + `(let ((%start ,(if from-end-p '(- length end) 'start)) + (%end ,(if from-end-p '(- length start) 'end)) + (sequence ,(if from-end-p '(reverse sequence) 'sequence))) + (do ((sequence (nthcdr %start ,sequence)) + (index %start (1+ index)) + (count 0)) + ((or (= index (the fixnum %end)) (null sequence)) count) + (declare (fixnum index count)) + (,(if notp 'unless 'when) ,pred + (setq count (1+ count))))))) + ) ; EVAL-WHEN -(defun count (item sequence &key from-end (test #'eql) test-not (start 0) - 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 a test with ITEM, - which defaults to EQL." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) + "Return the number of elements in SEQUENCE satisfying PRED(el)." + (declare (fixnum start)) + (let ((end (or end length)) + (pred (%coerce-callable-to-fun pred))) (declare (type index end)) (seq-dispatch sequence - (list-count item sequence) - (vector-count item sequence)))) - -;;;; COUNT-IF and COUNT-IF-NOT - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-count-if (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (aref ,sequence index))) - (setq count (1+ count))))) - -(sb!xc:defmacro list-count-if (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (funcall ,predicate (apply-key key (pop sequence))) - (setq count (1+ count))))) - -) ; EVAL-WHEN + (if from-end + (list-count-if nil t pred sequence) + (list-count-if nil nil pred sequence)) + (if from-end + (vector-count-if nil t pred sequence) + (vector-count-if nil nil pred sequence))))) -(defun count-if (test sequence &key from-end (start 0) end key) +(define-sequence-traverser count-if-not + (pred sequence &key from-end start end key) #!+sb-doc - "Return the number of elements in SEQUENCE satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) + "Return the number of elements in SEQUENCE not satisfying TEST(el)." + (declare (fixnum start)) + (let ((end (or end length)) + (pred (%coerce-callable-to-fun pred))) (declare (type index end)) (seq-dispatch sequence - (list-count-if test sequence) - (vector-count-if test sequence)))) - -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-count-if-not (predicate sequence) - `(do ((index start (1+ index)) - (count 0)) - ((= index (the fixnum end)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (aref ,sequence index)))) - (setq count (1+ count))))) - -(sb!xc:defmacro list-count-if-not (predicate sequence) - `(do ((sequence (nthcdr start ,sequence)) - (index start (1+ index)) - (count 0)) - ((or (= index (the fixnum end)) (null sequence)) count) - (declare (fixnum index count)) - (if (not (funcall ,predicate (apply-key key (pop sequence)))) - (setq count (1+ count))))) - -) ; EVAL-WHEN + (if from-end + (list-count-if t t pred sequence) + (list-count-if t nil pred sequence)) + (if from-end + (vector-count-if t t pred sequence) + (vector-count-if t nil pred sequence))))) -(defun count-if-not (test sequence &key from-end (start 0) end key) +(define-sequence-traverser count + (item sequence &key from-end start end + key (test #'eql test-p) (test-not nil test-not-p)) #!+sb-doc - "Return the number of elements in SEQUENCE not satisfying TEST(el)." - (declare (ignore from-end) (fixnum start)) - (let ((end (or end (length sequence)))) + "Return the number of elements in SEQUENCE satisfying a test with ITEM, + which defaults to EQL." + (declare (fixnum start)) + (when (and test-p test-not-p) + ;; ANSI Common Lisp has left the behavior in this situation unspecified. + ;; (CLHS 17.2.1) + (error ":TEST and :TEST-NOT are both present.")) + (let ((end (or end length))) (declare (type index end)) - (seq-dispatch sequence - (list-count-if-not test sequence) - (vector-count-if-not test sequence)))) + (let ((%test (if test-not-p + (lambda (x) + (not (funcall test-not item x))) + (lambda (x) + (funcall test item x))))) + (seq-dispatch sequence + (if from-end + (list-count-if nil t %test sequence) + (list-count-if nil nil %test sequence)) + (if from-end + (vector-count-if nil t %test sequence) + (vector-count-if nil nil %test sequence)))))) + + ;;;; MISMATCH @@ -2176,23 +2226,23 @@ ) ; EVAL-WHEN -(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not - (start1 0) end1 (start2 0) end2 key) +(define-sequence-traverser mismatch + (sequence1 sequence2 + &key from-end test test-not + start1 end1 start2 end2 key) #!+sb-doc "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the - result is Nil. Otherwise, the result is a non-negative integer, the index + result is NIL. Otherwise, the result is a non-negative integer, the index within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within SEQUENCE1 beyond the last position tested is returned. If a non-NIL :FROM-END argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) - (let* ((length1 (length sequence1)) - (end1 (or end1 length1)) - (length2 (length sequence2)) + (let* ((end1 (or end1 length1)) (end2 (or end2 length2))) - (declare (type index length1 end1 length2 end2)) + (declare (type index end1 end2)) (match-vars (seq-dispatch sequence1 (matchify-list (sequence1 start1 length1 end1) @@ -2223,32 +2273,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) @@ -2268,12 +2316,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) @@ -2281,12 +2327,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) @@ -2294,11 +2338,13 @@ ) ; EVAL-WHEN -(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not - (start1 0) end1 (start2 0) end2 key) +(define-sequence-traverser search + (sequence1 sequence2 + &key from-end test test-not + start1 end1 start2 end2 key) (declare (fixnum start1 start2)) - (let ((end1 (or end1 (length sequence1))) - (end2 (or end2 (length sequence2)))) + (let ((end1 (or end1 length1)) + (end2 (or end2 length2))) (seq-dispatch sequence2 (list-search sequence2 sequence1) (vector-search sequence2 sequence1))))