+(macrolet ((def (fun pred*)
+ `(deftransform ,fun ((string1 string2 &key (start1 0) end1
+ (start2 0) end2)
+ * *)
+ `(,',pred* string1 string2 start1 end1 start2 end2))))
+ (def string< string<*)
+ (def string> string>*)
+ (def string<= string<=*)
+ (def string>= string>=*)
+ (def string= string=*)
+ (def string/= string/=*))
+
+;;; Return a form that tests the free variables STRING1 and STRING2
+;;; for the ordering relationship specified by LESSP and EQUALP. The
+;;; start and end are also gotten from the environment. Both strings
+;;; must be SIMPLE-STRINGs.
+(macrolet ((def (name lessp equalp)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
+ `(let* ((end1 (if (not end1) (length string1) end1))
+ (end2 (if (not end2) (length string2) end2))
+ (index (sb!impl::%sp-string-compare
+ string1 start1 end1 string2 start2 end2)))
+ (if index
+ (cond ((= index ,(if ',lessp 'end1 'end2)) index)
+ ((= index ,(if ',lessp 'end2 'end1)) nil)
+ ((,(if ',lessp 'char< 'char>)
+ (schar string1 index)
+ (schar string2
+ (truly-the index
+ (+ index
+ (truly-the fixnum
+ (- start2
+ start1))))))
+ index)
+ (t nil))
+ ,(if ',equalp 'end1 nil))))))
+ (def string<* t nil)
+ (def string<=* t t)
+ (def string>* nil nil)
+ (def string>=* nil t))
+
+(macrolet ((def (name result-fun)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
+ `(,',result-fun
+ (sb!impl::%sp-string-compare
+ string1 start1 (or end1 (length string1))
+ string2 start2 (or end2 (length string2)))))))
+ (def string=* not)
+ (def string/=* identity))
+
+\f
+;;;; string-only transforms for sequence functions
+;;;;
+;;;; Note: CMU CL had more of these, including transforms for
+;;;; functions which cons. In SBCL, we've gotten rid of most of the
+;;;; transforms for functions which cons, since our GC overhead is
+;;;; sufficiently large that it doesn't seem worth it to try to
+;;;; economize on function call overhead or on the overhead of runtime
+;;;; type dispatch in AREF. The exception is CONCATENATE, since
+;;;; a full call to CONCATENATE would have to look up the sequence
+;;;; type, which can be really slow.
+;;;;
+;;;; FIXME: It would be nicer for these transforms to work for any
+;;;; calls when all arguments are vectors with the same element type,
+;;;; rather than restricting them to STRINGs only.
+
+;;; Moved here from generic/vm-tran.lisp to satisfy clisp
+;;;
+;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+;;; use that here, so that the compiler is born knowing this value.
+;;; FIXME: Add a comment telling whether this holds for all vectors
+;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+(def!constant vector-data-bit-offset
+ (* sb!vm:vector-data-offset sb!vm:n-word-bits))
+
+;;; FIXME: Shouldn't we be testing for legality of
+;;; * START1, START2, END1, and END2 indices?
+;;; * size of copied string relative to destination string?
+;;; (Either there should be tests conditional on SAFETY>=SPEED, or
+;;; the transform should be conditional on SPEED>SAFETY.)
+;;;
+;;; FIXME: Also, the transform should probably be dependent on
+;;; SPEED>SPACE.
+(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
+ end1 end2)
+ (simple-string simple-string &rest t))
+ `(locally
+ (declare (optimize (safety 0)))
+ (bit-bash-copy string2
+ (the index
+ (+ (the index (* start2 sb!vm:n-byte-bits))
+ ,vector-data-bit-offset))
+ string1
+ (the index
+ (+ (the index (* start1 sb!vm:n-byte-bits))
+ ,vector-data-bit-offset))
+ (the index
+ (* (min (the index (- (or end1 (length string1))
+ start1))
+ (the index (- (or end2 (length string2))
+ start2)))
+ sb!vm:n-byte-bits)))
+ string1))
+
+;;; 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
+(deftransform concatenate ((rtype &rest sequences)
+ (t &rest simple-string)
+ simple-string
+ :policy (< safety 3))
+ (collect ((lets)
+ (forms)
+ (all-lengths)
+ (args))
+ (dolist (seq sequences)
+ (declare (ignorable seq))
+ (let ((n-seq (gensym))
+ (n-length (gensym)))
+ (args n-seq)
+ (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
+ (all-lengths n-length)
+ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res start
+ ,n-length))
+ (forms `(setq start (opaque-identity (+ start ,n-length))))))
+ `(lambda (rtype ,@(args))
+ (declare (ignore rtype))
+ ;; KLUDGE
+ (flet ((opaque-identity (x) x))
+ (declare (notinline opaque-identity))
+ (let* (,@(lets)
+ (res (make-string (truncate (the index (+ ,@(all-lengths)))
+ sb!vm:n-byte-bits)))
+ (start ,vector-data-bit-offset))
+ (declare (type index start ,@(all-lengths)))
+ ,@(forms)
+ res)))))
+\f
+;;;; CONS accessor DERIVE-TYPE optimizers
+
+(defoptimizer (car derive-type) ((cons))
+ (let ((type (continuation-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-car-type type)))))
+
+(defoptimizer (cdr derive-type) ((cons))
+ (let ((type (continuation-type cons))
+ (null-type (specifier-type 'null)))
+ (cond ((eq type null-type)
+ null-type)
+ ((cons-type-p type)
+ (cons-type-cdr-type type)))))
+\f
+;;;; FIND, POSITION, and their -IF and -IF-NOT variants
+
+;;; We want to make sure that %FIND-POSITION is inline-expanded into
+;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
+;;; expansion, so we factor out the condition into this function.
+(defun check-inlineability-of-find-position-if (sequence from-end)
+ (let ((ctype (continuation-type sequence)))
+ (cond ((csubtypep ctype (specifier-type 'vector))
+ ;; It's not worth trying to inline vector code unless we
+ ;; know a fair amount about it at compile time.
+ (upgraded-element-type-specifier-or-give-up sequence)
+ (unless (constant-continuation-p from-end)
+ (give-up-ir1-transform
+ "FROM-END argument value not known at compile time")))
+ ((csubtypep ctype (specifier-type 'list))
+ ;; Inlining on lists is generally worthwhile.
+ )
+ (t
+ (give-up-ir1-transform
+ "sequence type not known at compile time")))))
+
+;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
+(macrolet ((def (name condition)
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ `(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (dolist (i sequence (values find position))
+ (let ((key-i (funcall key i)))
+ (when (and end (>= index end))
+ (return (values find position)))
+ (when (>= index start)
+ (,',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))))))
+ (incf index))))))
+ (def %find-position-if when)
+ (def %find-position-if-not unless))
+
+;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
+;;; without loss of efficiency. (I.e., the optimizer should be able
+;;; to straighten everything out.)
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t list t t t t t)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
+ ;; I'm having difficulty believing I'm
+ ;; reading it right, but as far as I can see,
+ ;; the only guidance that ANSI gives for the
+ ;; order of arguments to asymmetric tests is
+ ;; the character-set dependent example from
+ ;; the definition of FIND,
+ ;; (find #\d "here are some.." :test #'char>)
+ ;; => #\Space
+ ;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.)
+ ;; (Neither the POSITION definition page nor
+ ;; section 17.2 ("Rules about Test Functions")
+ ;; seem to consider the possibility of
+ ;; asymmetry.)
+ ;;
+ ;; So, judging from the example, we want to
+ ;; do (FUNCALL TEST-FUN ITEM I), because
+ ;; (FUNCALL #'CHAR> #\d #\SPACE)=>T.
+ ;;
+ ;; -- WHN (whose attention was drawn to it by
+ ;; Alexey Dejneka's bug report/fix)
+ (lambda (i)
+ (funcall test-fun item i)))
+ sequence
+ from-end
+ start
+ end
+ (%coerce-callable-to-fun key)))
+
+;;; The inline expansions for the VECTOR case are saved as macros so
+;;; that we can share them between the DEFTRANSFORMs and the default
+;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
+;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
+(defun %find-position-or-find-position-if-vector-expansion (sequence-arg
+ from-end
+ start
+ end-arg
+ element
+ done-p-expr)
+ (let ((offset (gensym "OFFSET"))
+ (block (gensym "BLOCK"))
+ (index (gensym "INDEX"))
+ (n-sequence (gensym "N-SEQUENCE-"))
+ (sequence (gensym "SEQUENCE"))
+ (n-end (gensym "N-END-"))
+ (end (gensym "END-")))
+ `(let ((,n-sequence ,sequence-arg)
+ (,n-end ,end-arg))
+ (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
+ (,start ,start)
+ (,end (or ,n-end (length ,n-sequence))))
+ (block ,block
+ (macrolet ((maybe-return ()
+ '(let ((,element (aref ,sequence ,index)))
+ (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
+ ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
+ ;; can send us off into never-never land, since
+ ;; INDEX is initialized to -1.)
+ of-type index-or-minus-1
+ from (1- ,end) downto ,start do
+ (maybe-return))
+ (loop for ,index of-type index from ,start below ,end do
+ (maybe-return))))
+ (values nil nil))))))
+
+(def!macro %find-position-vector-macro (item sequence
+ from-end start end key test)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ ;; (See the LIST transform for a discussion of the correct
+ ;; argument order, i.e. whether the searched-for ,ITEM goes before
+ ;; or after the checked sequence element.)
+ `(funcall ,test ,item (funcall ,key ,element)))))
+
+(def!macro %find-position-if-vector-macro (predicate sequence
+ from-end start end key)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(funcall ,predicate (funcall ,key ,element)))))
+
+(def!macro %find-position-if-not-vector-macro (predicate sequence
+ from-end start end key)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(not (funcall ,predicate (funcall ,key ,element))))))
+
+;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
+;;; VECTOR data
+(deftransform %find-position-if ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-vector-macro predicate sequence
+ from-end start end key))
+
+(deftransform %find-position-if-not ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-not-vector-macro predicate sequence
+ from-end start end key))
+
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t vector t t t function function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-vector-macro item sequence
+ from-end start end key test))