X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Fseq.lisp;h=98d616e7123b68ec537085388ff018cc293935fd;hb=18d4de696bc5063aad026ba62be613c7b07f5fc8;hp=7baeb3c8eede1bcff3b1488886c42fe8f9854625;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 7baeb3c..98d616e 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -17,9 +17,6 @@ ;;;; files for more information. (in-package "SB!IMPL") - -(file-comment - "$Header$") ;;;; utilities @@ -84,7 +81,7 @@ :datum type :expected-type '(or vector cons) :format-control - "NIL output type invalid for this sequence function." + "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)) @@ -96,7 +93,7 @@ :datum type :expected-type 'sequence :format-control - "~S is a bad type specifier for sequence functions." + "~S is not a legal type specifier for sequence functions." :format-arguments (list type)))))) (defun signal-index-too-large-error (sequence index) @@ -158,15 +155,15 @@ (setf (aref sequence index) newval)))) (defun length (sequence) - #!+sb-doc "Returns an integer that is the length of SEQUENCE." + #!+sb-doc "Return an integer that is the length of SEQUENCE." (etypecase sequence (vector (length (truly-the vector sequence))) (list (length (truly-the list sequence))))) (defun make-sequence (type length &key (initial-element NIL iep)) #!+sb-doc - "Returns a sequence of the given Type and Length, with elements initialized - to :Initial-Element." + "Return a sequence of the given TYPE and LENGTH, with elements initialized + to :INITIAL-ELEMENT." (declare (fixnum length)) (let ((type (specifier-type type))) (cond ((csubtypep type (specifier-type 'list)) @@ -189,11 +186,12 @@ (vlen (car (array-type-dimensions type)))) (if (and (numberp vlen) (/= vlen length)) (error 'simple-type-error - ;; these two are under-specified by ANSI + ;; 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 of ~S." + "The length of ~S does not match the specified ~ + length=~S." :format-arguments (list (type-specifier type) length))) (if iep @@ -444,9 +442,9 @@ (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. +;;; 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)) @@ -609,8 +607,7 @@ 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 - (check-type-var result output-type-spec) + #!+high-security (aver (typep result output-type-spec)) result)) (list (apply #'concat-to-list* sequences)) (t @@ -1847,7 +1844,12 @@ (setf (aref sequence index) new) (setq count (1- count))))) -;;; locater macros used by FIND and POSITION + +;;; REMOVEME: old POSITION/FIND stuff + +#| + +;;;; locater macros used by FIND and POSITION (eval-when (:compile-toplevel :execute) @@ -1885,7 +1887,7 @@ `(vector-locater-macro ,sequence (locater-test-not ,item ,sequence :vector ,return-type) ,return-type)) - + (sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense) (let ((seq-ref (case return-type (:position @@ -1912,7 +1914,7 @@ (sb!xc:defmacro vector-locater-if-not (test sequence return-type) `(vector-locater-if-macro ,test ,sequence ,return-type nil)) - + (sb!xc:defmacro list-locater-macro (sequence body-form return-type) `(if from-end (do ((sequence (nthcdr (- (the fixnum (length sequence)) @@ -1955,7 +1957,7 @@ ) ; EVAL-WHEN -;;; POSITION +;;;; POSITION (eval-when (:compile-toplevel :execute) @@ -1968,7 +1970,7 @@ ) ; EVAL-WHEN ;;; POSITION 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 +;;; 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 below). (defun position (item sequence &key from-end (test #'eql) test-not (start 0) @@ -2117,6 +2119,129 @@ (seq-dispatch sequence (list-find-if-not test sequence) (vector-find-if-not test sequence)))) +|# + +;;;; 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-function 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-function test-not))) + (t #'eql))) +(defun effective-find-position-key (key) + (if key + (%coerce-callable-to-function key) + #'identity)) + +;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF +(macrolet (;; shared logic for defining %FIND-POSITION and + ;; %FIND-POSITION-IF in terms of various inlineable cases + ;; of the expression defined in FROB and VECTOR*-FROB + (frobs () + `(etypecase sequence-arg + (list (frob sequence-arg from-end)) + (vector + (with-array-data ((sequence sequence-arg :offset-var offset) + (start start) + (end (or end (length sequence-arg)))) + (multiple-value-bind (f p) + (macrolet ((frob2 () '(if from-end + (frob sequence t) + (frob sequence nil)))) + (typecase sequence + (simple-vector (frob2)) + (simple-string (frob2)) + (t (vector*-frob sequence)))) + (declare (type (or index null) p)) + (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 + ,from-end start end key test)) + (vector*-frob (sequence) + `(%find-position-vector-macro item ,sequence + from-end start end key test))) + (frobs))) + (defun %find-position-if (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-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-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-function 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. +;;; +;;; 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-function + 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)) ;;;; COUNT @@ -2301,14 +2426,14 @@ (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not (start1 0) end1 (start2 0) end2 key) #!+sb-doc - "The specified subsequences of Sequence1 and Sequence2 are compared + "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 - within Sequence1 of the leftmost position at which they fail to match; or, + 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 keyword argument is given, then one plus the index of the - rightmost position in which the sequences differ is returned." + 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))