X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=4c5e02d34557d7d76222fbeda00acc6ec7d5d344;hb=08fe30555857c1928e00a8267b42740aa739631b;hp=55c4dba90e132d5b005eac3237d2397e0f40ea26;hpb=961c7076f5fba67ddba0e12dd131104834348b1a;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 55c4dba..4c5e02d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -284,14 +284,14 @@ (deftransform %check-vector-sequence-bounds ((vector start end) (vector * *) * :node node) - (if (policy node (< safety speed)) + (if (policy node (= 0 insert-array-bounds-checks)) '(or end (length vector)) '(let ((length (length vector))) - (if (<= 0 start (or end length) length) - (or end length) - (sb!impl::signal-bounding-indices-bad-error vector start end))))) + (if (<= 0 start (or end length) length) + (or end length) + (sequence-bounding-indices-bad-error vector start end))))) -(defun specialized-list-seek-function-name (function-name key-functions) +(defun specialized-list-seek-function-name (function-name key-functions variant) (or (find-symbol (with-output-to-string (s) ;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is ;; this ever so slightly faster then FORMAT, this @@ -301,32 +301,48 @@ (write-string (symbol-name function-name) s) (dolist (f key-functions) (write-char #\- s) - (write-string (symbol-name f) s))) + (write-string (symbol-name f) s)) + (when variant + (write-char #\- s) + (write-string (symbol-name variant) s))) (load-time-value (find-package "SB!KERNEL"))) - (bug "Unknown list item seek transform: name=~S, key-functions=~S" - function-name key-functions))) - -(defun transform-list-item-seek (name list key test test-not node) + (bug "Unknown list item seek transform: name=~S, key-functions=~S variant=~S" + function-name key-functions variant))) + +(defun transform-list-item-seek (name item list key test test-not node) + ;; If TEST is EQL, drop it. + (when (and test (lvar-for-named-function test 'eql)) + (setf test nil)) + ;; Ditto for KEY IDENTITY. + (when (and key (lvar-for-named-function key 'identity)) + (setf key nil)) ;; Key can legally be NIL, but if it's NIL for sure we pretend it's ;; not there at all. If it might be NIL, make up a form to that - ;; ensure it is a function. + ;; ensures it is a function. (multiple-value-bind (key key-form) - (if key - (let ((key-type (lvar-type key)) - (null-type (specifier-type 'null))) - (cond ((csubtypep key-type null-type) - (values nil nil)) - ((csubtypep null-type key-type) - (values key '(if key - (%coerce-callable-to-fun key) - #'identity))) - (t - (values key '(%coerce-callable-to-fun key)))))) - (let* ((funs (remove nil (list (and key 'key) (cond (test 'test) + (when key + (let ((key-type (lvar-type key)) + (null-type (specifier-type 'null))) + (cond ((csubtypep key-type null-type) + (values nil nil)) + ((csubtypep null-type key-type) + (values key '(if key + (%coerce-callable-to-fun key) + #'identity))) + (t + (values key '(%coerce-callable-to-fun key)))))) + (let* ((c-test (cond ((and test (lvar-for-named-function test 'eq)) + (setf test nil) + 'eq) + ((and (not test) (not test-not)) + (when (eq-comparable-type-p (lvar-type item)) + 'eq)))) + (funs (remove nil (list (and key 'key) (cond (test 'test) (test-not 'test-not))))) (target-expr (if key '(%funcall key target) 'target)) (test-expr (cond (test `(%funcall test item ,target-expr)) (test-not `(not (%funcall test-not item ,target-expr))) + (c-test `(,c-test item ,target-expr)) (t `(eql item ,target-expr))))) (labels ((open-code (tail) (when tail @@ -356,14 +372,17 @@ nil) (t ;; specialized out-of-line version - `(,(specialized-list-seek-function-name name funs) + `(,(specialized-list-seek-function-name name funs c-test) item list ,@(mapcar #'ensure-fun funs))))))))) (deftransform member ((item list &key key test test-not) * * :node node) - (transform-list-item-seek 'member list key test test-not node)) + (transform-list-item-seek 'member item list key test test-not node)) (deftransform assoc ((item list &key key test test-not) * * :node node) - (transform-list-item-seek 'assoc list key test test-not node)) + (transform-list-item-seek 'assoc item list key test test-not node)) + +(deftransform adjoin ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'adjoin item list key test test-not node)) (deftransform memq ((item list) (t (constant-arg list))) (labels ((rec (tail) @@ -408,28 +427,44 @@ (rplacd splice (cdr x)))) (t (setq splice x))))) -(deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) +(deftransform fill ((seq item &key (start 0) (end nil)) + (list t &key (:start t) (:end t))) + '(list-fill* seq item start end)) + +(deftransform fill ((seq item &key (start 0) (end nil)) + (vector t &key (:start t) (:end t)) * - :policy (> speed space)) - "open code" - (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - (values - `(with-array-data ((data seq) - (start start) - (end end)) - (declare (type (simple-array ,element-type 1) data)) - (declare (type fixnum start end)) - (do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - ;; WITH-ARRAY-DATA did our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF... - (declare (optimize (safety 0))) - (setf (aref data i) item))) - ;; ... though we still need to check that the new element can fit - ;; into the vector in safe code. -- CSR, 2002-07-05 - `((declare (type ,element-type item)))))) + :node node) + (let ((type (lvar-type seq)) + (element-type (type-specifier (extract-upgraded-element-type seq)))) + (cond ((and (neq '* element-type) (policy node (> speed space))) + (values + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + ;; WITH-ARRAY-DATA did our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF... + (declare (optimize (safety 0) (speed 3))) + (do ((i start (1+ i))) + ((= i end) seq) + (declare (type index i)) + (setf (aref data i) item))) + ;; ... though we still need to check that the new element can fit + ;; into the vector in safe code. -- CSR, 2002-07-05 + `((declare (type ,element-type item))))) + ((csubtypep type (specifier-type 'string)) + '(string-fill* seq item start end)) + (t + '(vector-fill* seq item start end))))) + +(deftransform fill ((seq item &key (start 0) (end nil)) + ((and sequence (not vector) (not list)) t &key (:start t) (:end t))) + `(sb!sequence:fill seq item + :start start + :end (%check-generic-sequence-bounds seq start end))) ;;;; utilities @@ -588,60 +623,74 @@ ;;; you tweak it, make sure that you compare the disassembly, if not the ;;; performance of, the functions implementing string streams ;;; (e.g. SB!IMPL::STRING-OUCH). +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-replace-transform (saetp sequence-type1 sequence-type2) + `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) + (,sequence-type1 ,sequence-type2 &rest t) + ,sequence-type1 + :node node) + ,(cond + ((and saetp (valid-bit-bash-saetp-p saetp)) nil) + ;; If the sequence types are different, SEQ1 and SEQ2 must + ;; be distinct arrays, and we can open code the copy loop. + ((not (eql sequence-type1 sequence-type2)) nil) + ;; If we're not bit-bashing, only allow cases where we + ;; can determine the order of copying up front. (There + ;; are actually more cases we can handle if we know the + ;; amount that we're copying, but this handles the + ;; common cases.) + (t '(unless (= (constant-value-or-lose start1 0) + (constant-value-or-lose start2 0)) + (give-up-ir1-transform)))) + `(let* ((len1 (length seq1)) + (len2 (length seq2)) + (end1 (or end1 len1)) + (end2 (or end2 len2)) + (replace-len1 (- end1 start1)) + (replace-len2 (- end2 start2))) + ,(unless (policy node (= safety 0)) + `(progn + (unless (<= 0 start1 end1 len1) + (sequence-bounding-indices-bad-error seq1 start1 end1)) + (unless (<= 0 start2 end2 len2) + (sequence-bounding-indices-bad-error seq2 start2 end2)))) + ,',(cond + ((and saetp (valid-bit-bash-saetp-p saetp)) + (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) + (bash-function (intern (format nil "UB~D-BASH-COPY" + n-element-bits) + (find-package "SB!KERNEL")))) + `(funcall (function ,bash-function) seq2 start2 + seq1 start1 (min replace-len1 replace-len2)))) + (t + ;; We can expand the loop inline here because we + ;; would have given up the transform (see above) + ;; if we didn't have constant matching start + ;; indices. + '(do ((i start1 (1+ i)) + (j start2 (1+ j)) + (end (+ start1 + (min replace-len1 replace-len2)))) + ((>= i end)) + (declare (optimize (insert-array-bounds-checks 0))) + (setf (aref seq1 i) (aref seq2 j))))) + seq1)))) + (macrolet ((define-replace-transforms () (loop for saetp across sb!vm:*specialized-array-element-type-properties* for sequence-type = `(simple-array ,(sb!vm:saetp-specifier saetp) (*)) unless (= (sb!vm:saetp-typecode saetp) sb!vm::simple-array-nil-widetag) - collect - `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2) - (,sequence-type ,sequence-type &rest t) - ,sequence-type - :node node) - ,(cond - ((valid-bit-bash-saetp-p saetp) nil) - ;; If we're not bit-bashing, only allow cases where we - ;; can determine the order of copying up front. (There - ;; are actually more cases we can handle if we know the - ;; amount that we're copying, but this handles the - ;; common cases.) - (t '(unless (= (constant-value-or-lose start1 0) - (constant-value-or-lose start2 0)) - (give-up-ir1-transform)))) - `(let* ((len1 (length seq1)) - (len2 (length seq2)) - (end1 (or end1 len1)) - (end2 (or end2 len2)) - (replace-len1 (- end1 start1)) - (replace-len2 (- end2 start2))) - ,(unless (policy node (= safety 0)) - `(progn - (unless (<= 0 start1 end1 len1) - (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1)) - (unless (<= 0 start2 end2 len2) - (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2)))) - ,',(cond - ((valid-bit-bash-saetp-p saetp) - (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) - (bash-function (intern (format nil "UB~D-BASH-COPY" n-element-bits) - (find-package "SB!KERNEL")))) - `(funcall (function ,bash-function) seq2 start2 - seq1 start1 (min replace-len1 replace-len2)))) - (t - ;; We can expand the loop inline here because we - ;; would have given up the transform (see above) - ;; if we didn't have constant matching start - ;; indices. - '(do ((i start1 (1+ i)) - (end (+ start1 - (min replace-len1 replace-len2)))) - ((>= i end)) - (declare (optimize (insert-array-bounds-checks 0))) - (setf (aref seq1 i) (aref seq2 i))))) - seq1)) + collect (make-replace-transform saetp sequence-type sequence-type) into forms - finally (return `(progn ,@forms))))) - (define-replace-transforms)) + finally (return `(progn ,@forms)))) + (define-one-transform (sequence-type1 sequence-type2) + (make-replace-transform nil sequence-type1 sequence-type2))) + (define-replace-transforms) + #!+sb-unicode + (progn + (define-one-transform (simple-array base-char (*)) (simple-array character (*))) + (define-one-transform (simple-array character (*)) (simple-array base-char (*))))) ;;; Expand simple cases of UB-BASH-COPY inline. "simple" is ;;; defined as those cases where we are doing word-aligned copies from @@ -706,7 +755,8 @@ (do ((i end (1- i))) ((<= i ,src-word)) (setf (sb!kernel:%vector-raw-bits dst (1- i)) - (sb!kernel:%vector-raw-bits src (1- i))))))))) + (sb!kernel:%vector-raw-bits src (1- i)))) + (values)))))) #.(loop for i = 1 then (* i 2) collect `(deftransform ,(intern (format nil "UB~D-BASH-COPY" i) @@ -768,36 +818,62 @@ (type (integer 0 #.sb!xc:array-dimension-limit) j i)) (setf (aref ,dst (1- j)) (aref ,src (1- i)))))) +;;; SUBSEQ, COPY-SEQ + (deftransform subseq ((seq start &optional end) - ((or (simple-unboxed-array (*)) simple-vector) t &optional t) - * :node node) - (let ((array-type (lvar-type seq))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) - `(let* ((length (length seq)) - (end (or end length))) - ,(unless (policy node (= safety 0)) - '(progn - (unless (<= 0 start end length) - (sb!impl::signal-bounding-indices-bad-error seq start end)))) - (let* ((size (- end start)) - (result (make-array size :element-type ',element-type))) - ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start) - (lvar-value start) - 'start) - 'result 0 'size element-type) - result))))) - -(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *) - (let ((array-type (lvar-type seq))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) - `(let* ((length (length seq)) - (result (make-array length :element-type ',element-type))) - ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) - result)))) + (vector t &optional t) + * + :node node) + (let ((type (lvar-type seq))) + (cond + ((and (array-type-p type) + (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (let ((element-type (type-specifier (array-type-specialized-element-type type)))) + `(let* ((length (length seq)) + (end (or end length))) + ,(unless (policy node (zerop insert-array-bounds-checks)) + '(progn + (unless (<= 0 start end length) + (sequence-bounding-indices-bad-error seq start end)))) + (let* ((size (- end start)) + (result (make-array size :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start) + (lvar-value start) + 'start) + 'result 0 'size element-type) + result)))) + ((csubtypep type (specifier-type 'string)) + '(string-subseq* seq start end)) + (t + '(vector-subseq* seq start end))))) + +(deftransform subseq ((seq start &optional end) + (list t &optional t)) + `(list-subseq* seq start end)) + +(deftransform subseq ((seq start &optional end) + ((and sequence (not vector) (not list)) t &optional t)) + '(sb!sequence:subseq seq start end)) + +(deftransform copy-seq ((seq) (vector)) + (let ((type (lvar-type seq))) + (cond ((and (array-type-p type) + (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (let ((element-type (type-specifier (array-type-specialized-element-type type)))) + `(let* ((length (length seq)) + (result (make-array length :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) + result))) + ((csubtypep type (specifier-type 'string)) + '(string-subseq* seq 0 nil)) + (t + '(vector-subseq* seq 0 nil))))) + +(deftransform copy-seq ((seq) (list)) + '(list-copy-seq* seq)) + +(deftransform copy-seq ((seq) ((and sequence (not vector) (not list)))) + '(sb!sequence:copy-seq seq)) ;;; FIXME: it really should be possible to take advantage of the ;;; macros used in code/seq.lisp here to avoid duplication of code, @@ -808,6 +884,7 @@ from-end) (vector vector &rest t) * + :node node :policy (> speed (max space safety))) "open code" (let ((from-end (when (lvar-p from-end) @@ -815,91 +892,117 @@ (give-up-ir1-transform ":FROM-END is not constant.")) (lvar-value from-end))) (keyp (lvar-p key)) - (testp (lvar-p test))) + (testp (lvar-p test)) + (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) `(block search - (let ((end1 (or end1 (length pattern))) - (end2 (or end2 (length text))) - ,@(when keyp - '((key (coerce key 'function)))) - ,@(when testp - '((test (coerce test 'function))))) - (declare (type index start1 start2 end1 end2)) - (do (,(if from-end - '(index2 (- end2 (- end1 start1)) (1- index2)) - '(index2 start2 (1+ index2)))) - (,(if from-end - '(< index2 start2) - '(>= index2 end2)) - nil) - ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop - ;; terminates is hits -1 when :FROM-END is true and :START2 - ;; is 0. - (declare (type fixnum index2)) - (when (do ((index1 start1 (1+ index1)) - (index2 index2 (1+ index2))) - ((>= index1 end1) t) - (declare (type index index1 index2)) - ,@(unless from-end - '((when (= index2 end2) - (return-from search nil)))) - (unless (,@(if testp - '(funcall test) - '(eql)) - ,(if keyp - '(funcall key (aref pattern index1)) - '(aref pattern index1)) - ,(if keyp - '(funcall key (aref text index2)) - '(aref text index2))) - (return nil))) - (return index2))))))) - -;;; FIXME: It seems as though it should be possible to make a DEFUN -;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to -;;; CTYPE before calling %CONCATENATE) which is comparably efficient, -;;; at least once DYNAMIC-EXTENT works. -;;; -;;; FIXME: currently KLUDGEed because of bug 188 -;;; -;;; FIXME: disabled for sb-unicode: probably want it back -#!-sb-unicode -(deftransform concatenate ((rtype &rest sequences) - (t &rest (or simple-base-string - (simple-array nil (*)))) - simple-base-string - :policy (< safety 3)) - (loop for rest-seqs on sequences - for n-seq = (gensym "N-SEQ") - for n-length = (gensym "N-LENGTH") - for start = 0 then next-start - for next-start = (gensym "NEXT-START") - collect n-seq into args - collect `(,n-length (length ,n-seq)) into lets - collect n-length into all-lengths - collect next-start into starts - collect `(if (and (typep ,n-seq '(simple-array nil (*))) - (> ,n-length 0)) - (error 'nil-array-accessed-error) - (#.(let* ((i (position 'character sb!kernel::*specialized-array-element-types*)) - (saetp (aref sb!vm:*specialized-array-element-type-properties* i)) - (n-bits (sb!vm:saetp-n-bits saetp))) - (intern (format nil "UB~D-BASH-COPY" n-bits) - "SB!KERNEL")) - ,n-seq 0 res ,start ,n-length)) - into forms - collect `(setq ,next-start (+ ,start ,n-length)) into forms - finally - (return - `(lambda (rtype ,@args) - (declare (ignore rtype)) - (let* (,@lets - (res (make-string (the index (+ ,@all-lengths)) - :element-type 'base-char))) - (declare (type index ,@all-lengths)) - (let (,@(mapcar (lambda (name) `(,name 0)) starts)) - (declare (type index ,@starts)) - ,@forms) - res))))) + (flet ((oops (vector start end) + (sequence-bounding-indices-bad-error vector start end))) + (let* ((len1 (length pattern)) + (len2 (length text)) + (end1 (or end1 len1)) + (end2 (or end2 len2)) + ,@(when keyp + '((key (coerce key 'function)))) + ,@(when testp + '((test (coerce test 'function))))) + (declare (type index start1 start2 end1 end2)) + ,@(when check-bounds-p + `((unless (<= start1 end1 len1) + (oops pattern start1 end1)) + (unless (<= start2 end2 len2) + (oops pattern start2 end2)))) + (do (,(if from-end + '(index2 (- end2 (- end1 start1)) (1- index2)) + '(index2 start2 (1+ index2)))) + (,(if from-end + '(< index2 start2) + '(>= index2 end2)) + nil) + ;; INDEX2 is FIXNUM, not an INDEX, as right before the loop + ;; terminates is hits -1 when :FROM-END is true and :START2 + ;; is 0. + (declare (type fixnum index2)) + (when (do ((index1 start1 (1+ index1)) + (index2 index2 (1+ index2))) + ((>= index1 end1) t) + (declare (type index index1 index2) + (optimize (insert-array-bounds-checks 0))) + ,@(unless from-end + '((when (= index2 end2) + (return-from search nil)))) + (unless (,@(if testp + '(funcall test) + '(eql)) + ,(if keyp + '(funcall key (aref pattern index1)) + '(aref pattern index1)) + ,(if keyp + '(funcall key (aref text index2)) + '(aref text index2))) + (return nil))) + (return index2)))))))) + + +;;; Open-code CONCATENATE for strings. It would be possible to extend +;;; this transform to non-strings, but I chose to just do the case that +;;; should cover 95% of CONCATENATE performance complaints for now. +;;; -- JES, 2007-11-17 +(deftransform concatenate ((result-type &rest lvars) + (symbol &rest sequence) + * + :policy (> speed space)) + (unless (constant-lvar-p result-type) + (give-up-ir1-transform)) + (let* ((element-type (let ((type (lvar-value result-type))) + ;; Only handle the simple result type cases. If + ;; somebody does (CONCATENATE '(STRING 6) ...) + ;; their code won't be optimized, but nobody does + ;; that in practice. + (case type + ((string simple-string) 'character) + ((base-string simple-base-string) 'base-char) + (t (give-up-ir1-transform))))) + (vars (loop for x in lvars collect (gensym))) + (lvar-values (loop for lvar in lvars + collect (when (constant-lvar-p lvar) + (lvar-value lvar)))) + (lengths + (loop for value in lvar-values + for var in vars + collect (if value + (length value) + `(sb!impl::string-dispatch ((simple-array * (*)) + sequence) + ,var + (declare (muffle-conditions compiler-note)) + (length ,var)))))) + `(apply + (lambda ,vars + (declare (ignorable ,@vars)) + (let* ((.length. (+ ,@lengths)) + (.pos. 0) + (.string. (make-string .length. :element-type ',element-type))) + (declare (type index .length. .pos.) + (muffle-conditions compiler-note)) + ,@(loop for value in lvar-values + for var in vars + collect (if (stringp value) + ;; Fold the array reads for constant arguments + `(progn + ,@(loop for c across value + collect `(setf (aref .string. + .pos.) ,c) + collect `(incf .pos.))) + `(sb!impl::string-dispatch + (#!+sb-unicode + (simple-array character (*)) + (simple-array base-char (*)) + t) + ,var + (replace .string. ,var :start1 .pos.) + (incf .pos. (length ,var))))) + .string.)) + lvars))) ;;;; CONS accessor DERIVE-TYPE optimizers @@ -953,7 +1056,7 @@ (declare (type index index)) (dolist (i sequence (if (and end (> end index)) - (sb!impl::signal-bounding-indices-bad-error + (sequence-bounding-indices-bad-error sequence start end) (values find position))) (let ((key-i (funcall key i))) @@ -1016,13 +1119,12 @@ end-arg element done-p-expr) - (with-unique-names (offset block index n-sequence sequence n-end end) - `(let ((,n-sequence ,sequence-arg) - (,n-end ,end-arg)) + (with-unique-names (offset block index n-sequence sequence end) + `(let* ((,n-sequence ,sequence-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) (,start ,start) - (,end (%check-vector-sequence-bounds - ,n-sequence ,start ,n-end))) + (,end ,end-arg) + :check-fill-pointer t) (block ,block (macrolet ((maybe-return () ;; WITH-ARRAY-DATA has already performed bounds @@ -1030,10 +1132,10 @@ ;; in the inner loop. '(let ((,element (locally (declare (optimize (insert-array-bounds-checks 0))) (aref ,sequence ,index)))) - (when ,done-p-expr - (return-from ,block - (values ,element - (- ,index ,offset))))))) + (when ,done-p-expr + (return-from ,block + (values ,element + (- ,index ,offset))))))) (if ,from-end (loop for ,index ;; (If we aren't fastidious about declaring that @@ -1044,7 +1146,7 @@ from (1- ,end) downto ,start do (maybe-return)) (loop for ,index of-type index from ,start below ,end do - (maybe-return)))) + (maybe-return)))) (values nil nil)))))) (def!macro %find-position-vector-macro (item sequence @@ -1110,7 +1212,7 @@ "expand inline" (check-inlineability-of-find-position-if sequence from-end) '(%find-position-vector-macro item sequence - from-end start end key test)) + from-end start end key test)) ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, ;;; POSITION-IF, etc. @@ -1195,3 +1297,43 @@ (effective-find-position-key key)))))) (define-find-position-if-not find-if-not 0) (define-find-position-if-not position-if-not 1)) + +(macrolet ((define-trimmer-transform (fun-name leftp rightp) + `(deftransform ,fun-name ((char-bag string) + (t simple-string)) + (let ((find-expr + (if (constant-lvar-p char-bag) + ;; If the bag is constant, use MEMBER + ;; instead of FIND, since we have a + ;; deftransform for MEMBER that can + ;; open-code all of the comparisons when + ;; the list is constant. -- JES, 2007-12-10 + `(not (member (schar string index) + ',(coerce (lvar-value char-bag) 'list) + :test #'char=)) + '(not (find (schar string index) char-bag :test #'char=))))) + `(flet ((char-not-in-bag (index) + ,find-expr)) + (let* ((end (length string)) + (left-end (if ,',leftp + (do ((index 0 (1+ index))) + ((or (= index (the fixnum end)) + (char-not-in-bag index)) + index) + (declare (fixnum index))) + 0)) + (right-end (if ,',rightp + (do ((index (1- end) (1- index))) + ((or (< index left-end) + (char-not-in-bag index)) + (1+ index)) + (declare (fixnum index))) + end))) + (if (and (eql left-end 0) + (eql right-end (length string))) + string + (subseq string left-end right-end)))))))) + (define-trimmer-transform string-left-trim t nil) + (define-trimmer-transform string-right-trim nil t) + (define-trimmer-transform string-trim t t)) +