(or end length)
(sequence-bounding-indices-bad-error vector start end)))))
-(defun specialized-list-seek-function-name (function-name key-functions)
+(deftype eq-comparable-type ()
+ '(or fixnum (not number)))
+
+;;; True if EQL comparisons involving type can be simplified to EQ.
+(defun eq-comparable-type-p (type)
+ (csubtypep type (specifier-type 'eq-comparable-type)))
+
+(defun specialized-list-seek-function-name (function-name key-functions &optional 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
(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-fun-is test '(eql)))
+ (setf test nil))
+ ;; Ditto for KEY IDENTITY.
+ (when (and key (lvar-fun-is 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)
- (test-not 'test-not)))))
+ (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 (ensure-lvar-fun-form key 'key))))))
+ (let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))
+ (setf test nil)
+ 'eq)
+ ((and (not test) (not test-not))
+ (when (eq-comparable-type-p (lvar-type item))
+ 'eq))))
+ (funs (delete nil (list (when key (list key 'key))
+ (when test (list test 'test))
+ (when test-not (list 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
`(if (let ((this ',(car tail)))
,(ecase name
- (assoc
- `(and this (let ((target (car this)))
- ,test-expr)))
+ ((assoc rassoc)
+ (let ((cxx (if (eq name 'assoc) 'car 'cdr)))
+ `(and this (let ((target (,cxx this)))
+ ,test-expr))))
(member
`(let ((target this))
,test-expr))))
',(ecase name
- (assoc (car tail))
+ ((assoc rassoc) (car tail))
(member tail))
,(open-code (cdr tail)))))
- (ensure-fun (fun)
- (if (eq 'key fun)
+ (ensure-fun (args)
+ (if (eq 'key (second args))
key-form
- `(%coerce-callable-to-fun ,fun))))
+ (apply #'ensure-lvar-fun-form args))))
+ (let* ((cp (constant-lvar-p list))
+ (c-list (when cp (lvar-value list))))
+ (cond ((and cp c-list (member name '(assoc rassoc member))
+ (policy node (>= speed space)))
+ `(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
+ ,(open-code c-list)))
+ ((and cp (not c-list))
+ ;; constant nil list
+ (if (eq name 'adjoin)
+ '(list item)
+ nil))
+ (t
+ ;; specialized out-of-line version
+ `(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test)
+ item list ,@(mapcar #'ensure-fun funs)))))))))
+
+(defun transform-list-pred-seek (name pred list key node)
+ ;; If KEY is IDENTITY, drop it.
+ (when (and key (lvar-fun-is 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
+ ;; ensures it is a function.
+ (multiple-value-bind (key key-form)
+ (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 (ensure-lvar-fun-form key 'key))))))
+ (let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
+ (pred-expr (ensure-lvar-fun-form pred 'pred)))
+ (when (member name '(member-if-not assoc-if-not rassoc-if-not))
+ (setf test-expr `(not ,test-expr)))
+ (labels ((open-code (tail)
+ (when tail
+ `(if (let ((this ',(car tail)))
+ ,(ecase name
+ ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+ (let ((cxx (if (member name '(assoc-if assoc-if-not)) 'car 'cdr)))
+ `(and this (let ((target (,cxx this)))
+ ,test-expr))))
+ ((member-if member-if-not)
+ `(let ((target this))
+ ,test-expr))))
+ ',(ecase name
+ ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+ (car tail))
+ ((member-if member-if-not)
+ tail))
+ ,(open-code (cdr tail))))))
(let* ((cp (constant-lvar-p list))
(c-list (when cp (lvar-value list))))
(cond ((and cp c-list (policy node (>= speed space)))
- `(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
+ `(let ((pred ,pred-expr)
+ ,@(when key `((key ,key-form))))
,(open-code c-list)))
((and cp (not c-list))
;; constant nil list -- nothing to find!
nil)
(t
;; specialized out-of-line version
- `(,(specialized-list-seek-function-name name funs)
- 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))
-
-(deftransform assoc ((item list &key key test test-not) * * :node node)
- (transform-list-item-seek 'assoc list key test test-not node))
+ `(,(specialized-list-seek-function-name name (when key '(key)))
+ ,pred-expr list ,@(when key (list key-form))))))))))
+
+(macrolet ((def (name &optional if/if-not)
+ (let ((basic (symbolicate "%" name))
+ (basic-eq (symbolicate "%" name "-EQ"))
+ (basic-key (symbolicate "%" name "-KEY"))
+ (basic-key-eq (symbolicate "%" name "-KEY-EQ")))
+ `(progn
+ (deftransform ,name ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek ',name item list key test test-not node))
+ (deftransform ,basic ((item list) (eq-comparable-type t))
+ `(,',basic-eq item list))
+ (deftransform ,basic-key ((item list) (eq-comparable-type t))
+ `(,',basic-key-eq item list))
+ ,@(when if/if-not
+ (let ((if-name (symbolicate name "-IF"))
+ (if-not-name (symbolicate name "-IF-NOT")))
+ `((deftransform ,if-name ((pred list &key key) * * :node node)
+ (transform-list-pred-seek ',if-name pred list key node))
+ (deftransform ,if-not-name ((pred list &key key) * * :node node)
+ (transform-list-pred-seek ',if-not-name pred list key node)))))))))
+ (def adjoin)
+ (def assoc t)
+ (def member t)
+ (def rassoc t))
(deftransform memq ((item list) (t (constant-arg list)))
(labels ((rec (tail)
(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))
- *
- :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)
- :check-fill-pointer t)
- (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))))))
-\f
-;;;; utilities
-
-;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
-;;; global function with one of the specified NAMES.
-(defun lvar-fun-is (lvar names)
- (declare (type lvar lvar) (list names))
- (let ((use (lvar-uses lvar)))
- (and (ref-p use)
- (let ((leaf (ref-leaf use)))
- (and (global-var-p leaf)
- (eq (global-var-kind leaf) :global-function)
- (not (null (member (leaf-source-name leaf) names
- :test #'equal))))))))
-
-;;; If LVAR is a constant lvar, the return the constant value. If it
-;;; is null, then return default, otherwise quietly give up the IR1
-;;; transform.
-;;;
-;;; ### Probably should take an ARG and flame using the NAME.
-(defun constant-value-or-lose (lvar &optional default)
- (declare (type (or lvar null) lvar))
- (cond ((not lvar) default)
- ((constant-lvar-p lvar)
- (lvar-value lvar))
- (t
- (give-up-ir1-transform))))
+(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))
+ *
+ :node node)
+ (let* ((element-ctype (extract-upgraded-element-type seq))
+ (element-type (type-specifier element-ctype))
+ (type (lvar-type seq))
+ (saetp (unless (eq *wild-type* element-ctype)
+ (find-saetp-by-ctype element-ctype))))
+ (cond ((eq *wild-type* element-ctype)
+ (delay-ir1-transform node :constraint)
+ `(vector-fill* seq item start end))
+ ((and saetp (sb!vm::valid-bit-bash-saetp-p saetp))
+ (let* ((n-bits (sb!vm:saetp-n-bits saetp))
+ (basher-name (format nil "UB~D-BASH-FILL" n-bits))
+ (basher (or (find-symbol basher-name
+ (load-time-value (find-package :sb!kernel)))
+ (abort-ir1-transform
+ "Unknown fill basher, please report to sbcl-devel: ~A"
+ basher-name)))
+ (kind (cond ((sb!vm:saetp-fixnum-p saetp) :tagged)
+ ((member element-type '(character base-char)) :char)
+ ((eq element-type 'single-float) :single-float)
+ ((eq element-type 'double-float) :double-float)
+ (t :bits)))
+ ;; BASH-VALUE is a word that we can repeatedly smash
+ ;; on the array: for less-than-word sized elements it
+ ;; contains multiple copies of the fill item.
+ (bash-value
+ (if (constant-lvar-p item)
+ (let ((tmp (lvar-value item)))
+ (unless (ctypep tmp element-ctype)
+ (abort-ir1-transform "~S is not ~S" tmp element-type))
+ (let* ((bits
+ (ldb (byte n-bits 0)
+ (ecase kind
+ (:tagged
+ (ash tmp sb!vm:n-fixnum-tag-bits))
+ (:char
+ (char-code tmp))
+ (:bits
+ tmp)
+ (:single-float
+ (single-float-bits tmp))
+ (:double-float
+ (logior (ash (double-float-high-bits tmp) 32)
+ (double-float-low-bits tmp))))))
+ (res bits))
+ (loop for i of-type sb!vm:word from n-bits by n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res (ldb (byte sb!vm:n-word-bits 0)
+ (logior res (ash bits i)))))
+ res))
+ `(let* ((bits (ldb (byte ,n-bits 0)
+ ,(ecase kind
+ (:tagged
+ `(ash item ,sb!vm:n-fixnum-tag-bits))
+ (:char
+ `(char-code item))
+ (:bits
+ `item)
+ (:single-float
+ `(single-float-bits item))
+ (:double-float
+ `(logior (ash (double-float-high-bits item) 32)
+ (double-float-low-bits item))))))
+ (res bits))
+ (declare (type sb!vm:word res))
+ ,@(unless (= sb!vm:n-word-bits n-bits)
+ `((loop for i of-type sb!vm:word from ,n-bits by ,n-bits
+ until (= i sb!vm:n-word-bits)
+ do (setf res
+ (ldb (byte ,sb!vm:n-word-bits 0)
+ (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
+ res))))
+ (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))
+ (declare (optimize (safety 0) (speed 3))
+ (muffle-conditions compiler-note))
+ (,basher ,bash-value data start (- end start))
+ seq)
+ `((declare (type ,element-type item))))))
+ ((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)))
+\f
;;;; hairy sequence transforms
;;; FIXME: no hairy sequence transforms in SBCL?
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-(eval-when (:compile-toplevel)
-(defun valid-bit-bash-saetp-p (saetp)
- ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
- (and (not (eq t (sb!vm:saetp-specifier saetp)))
- ;; Disallowing (VECTOR NIL) also means that we won't transform
- ;; sequence functions into bit-bashing code and we let the
- ;; generic sequence functions signal errors if necessary.
- (not (zerop (sb!vm:saetp-n-bits saetp)))
- ;; Due to limitations with the current BIT-BASHing code, we can't
- ;; BIT-BASH reliably on arrays whose element types are larger
- ;; than the word size.
- (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
-) ; EVAL-WHEN
-
;;; FIXME: In the copy loops below, we code the loops in a strange
;;; fashion:
;;;
;;; 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)
+(eval-when (#-sb-xc :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)))
+ (replace-len (min (- end1 start1) (- 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))))
+ (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)))))
+ ((and saetp (sb!vm: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 replace-len)))
+ (t
+ `(if (and
+ ;; If the sequence types are different, SEQ1 and
+ ;; SEQ2 must be distinct arrays.
+ ,(eql sequence-type1 sequence-type2)
+ (eq seq1 seq2) (> start1 start2))
+ (do ((i (truly-the index (+ start1 replace-len -1))
+ (1- i))
+ (j (truly-the index (+ start2 replace-len -1))
+ (1- j)))
+ ((< i start1))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref seq1 i) (aref seq2 j)))
+ (do ((i start1 (1+ i))
+ (j start2 (1+ j))
+ (end (+ start1 replace-len)))
+ ((>= i end))
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (setf (aref seq1 i) (aref seq2 j))))))
seq1))))
(macrolet
(define-one-transform (sequence-type1 sequence-type2)
(make-replace-transform nil sequence-type1 sequence-type2)))
(define-replace-transforms)
- (define-one-transform simple-base-string (simple-array character (*)))
- (define-one-transform (simple-array character (*)) simple-base-string))
+ #!+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<SIZE>-BASH-COPY inline. "simple" is
;;; defined as those cases where we are doing word-aligned copies from
(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)
'start)
'result 0 'size element-type)
result))))
+ ((csubtypep type (specifier-type 'string))
+ '(string-subseq* seq start end))
(t
'(vector-subseq* seq start end)))))
((and sequence (not vector) (not list)) t &optional t))
'(sb!sequence:subseq seq start end))
-(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))))
+(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,
;;;; CONS accessor DERIVE-TYPE optimizers
(defoptimizer (car derive-type) ((cons))
- (let ((type (lvar-type cons))
+ ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference
+ ;; gets confused by things like (SETF CAR).
+ (let ((type (lvar-conservative-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
(cons-type-car-type type)))))
(defoptimizer (cdr derive-type) ((cons))
- (let ((type (lvar-type cons))
+ (let ((type (lvar-conservative-type cons))
(null-type (specifier-type 'null)))
(cond ((eq type null-type)
null-type)
(sequence-bounding-indices-bad-error
sequence start end)
(values find position)))
- (let ((key-i (funcall key i)))
- (when (and end (>= index end))
- (return (values find position)))
- (when (>= index start)
+ (when (and end (>= index end))
+ (return (values find position)))
+ (when (>= index start)
+ (let ((key-i (funcall key i)))
(,',condition (funcall predicate key-i)
- ;; This hack of dealing with non-NIL
- ;; FROM-END for list data by iterating
- ;; forward through the list and keeping
- ;; track of the last time we found a match
- ;; might be more screwy than what the user
- ;; expects, but it seems to be allowed by
- ;; the ANSI standard. (And if the user is
- ;; screwy enough to ask for FROM-END
- ;; behavior on list data, turnabout is
- ;; fair play.)
- ;;
- ;; It's also not enormously efficient,
- ;; calling PREDICATE and KEY more often
- ;; than necessary; but all the
- ;; alternatives seem to have their own
- ;; efficiency problems.
- (if from-end
- (setf find i
- position index)
- (return (values i index))))))
+ ;; This hack of dealing with non-NIL
+ ;; FROM-END for list data by iterating
+ ;; forward through the list and keeping
+ ;; track of the last time we found a
+ ;; match might be more screwy than what
+ ;; the user expects, but it seems to be
+ ;; allowed by the ANSI standard. (And
+ ;; if the user is screwy enough to ask
+ ;; for FROM-END behavior on list data,
+ ;; turnabout is fair play.)
+ ;;
+ ;; It's also not enormously efficient,
+ ;; calling PREDICATE and KEY more often
+ ;; than necessary; but all the
+ ;; alternatives seem to have their own
+ ;; efficiency problems.
+ (if from-end
+ (setf find i
+ position index)
+ (return (values i index))))))
(incf index))))))
(def %find-position-if when)
(def %find-position-if-not unless))
(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))
+
projects / sbcl.git / blobdiff