X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=7a20475cf6840bb639304aa0788cf17c9c8d92df;hb=c25e4572f5505236faf126f38a74f32a80bf1e8c;hp=472b41b989214944be04f71b32ec434f0d502b16;hpb=b6aa15328871678a3475e82c150b251dffb49ba1;p=sbcl.git diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 472b41b..7a20475 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -56,7 +56,7 @@ :datum vector :expected-type `(vector ,declared-length) :format-control - "Vector length (~D) doesn't match declared length (~D)." + "Vector length (~W) doesn't match declared length (~W)." :format-arguments (list actual-length declared-length)))) vector) (defun sequence-of-checked-length-given-type (sequence result-type) @@ -289,7 +289,17 @@ (list-copy-seq sequence)) (defun vector-copy-seq* (sequence) - (vector-copy-seq sequence (type-of sequence))) + (declare (type vector sequence)) + (vector-copy-seq sequence + (typecase sequence + ;; Pick off the common cases so that we don't have to... + ((vector t) 'simple-vector) + (string 'simple-string) + (bit-vector 'simple-bit-vector) + ((vector single-float) '(simple-array single-float 1)) + ((vector double-float) '(simple-array double-float 1)) + ;; ...do a full call to TYPE-OF. + (t (type-of sequence))))) ;;;; FILL @@ -760,7 +770,7 @@ ;;; 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))) ;; 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,21 +778,21 @@ ;; 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)) + ((nil) (%map-for-effect really-fun sequences)) + (list (%map-to-list really-fun sequences)) ((simple-vector simple-string vector string array simple-array bit-vector simple-bit-vector base-string simple-base-string) - (%map-to-vector result-type really-function sequences)) + (%map-to-vector result-type really-fun sequences)) (t (apply #'map (result-type-or-lose result-type t) - really-function + really-fun sequences))))))) (defun map (result-type function first-sequence &rest more-sequences) @@ -830,7 +840,7 @@ (dotimes (index len) (setf (elt result-sequence index) (apply really-fun - (mapcar #'(lambda (seq) (elt seq index)) + (mapcar (lambda (seq) (elt seq index)) sequences)))))) result-sequence) @@ -879,6 +889,16 @@ ;; obviously correct solution is to make Python smart ;; enough that we can use an inline function instead ;; of a compiler macro (as above). -- WHN 20000410 + ;; + ;; FIXME: The DEFINE-COMPILER-MACRO here can be + ;; important for performance, and it'd be good to have + ;; it be visible throughout the compilation of all the + ;; target SBCL code. That could be done by defining + ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, + ;; moving this DEFQUANTIFIER stuff (and perhaps other + ;; inline definitions in seq.lisp as well) into a new + ;; seq.lisp, and moving remaining target-only stuff + ;; from the old seq.lisp into target-seq.lisp. (define-compiler-macro ,name (pred first-seq &rest more-seqs) (let ((elements (make-gensym-list (1+ (length more-seqs)))) (blockname (gensym "BLOCK"))) @@ -1900,6 +1920,14 @@ (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 @@ -1946,11 +1974,10 @@ (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 +;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We +;;; didn'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 @@ -1971,18 +1998,19 @@ ;;; ;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT ;;; too) 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 &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)))))) + (%find-position-if-not (%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))