-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; setting up for POSITION/FIND stuff
-
-(defknown %find-position
- (t sequence t index sequence-end function function)
- (values t (or index null))
- (flushable call))
-(defknown %find-position-if
- (function sequence t index sequence-end function)
- (values t (or index null))
- (call))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper
-
-;;; FIXME: Blow away old CMU CL implementation:
-;;; * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT
-;;; * matches to 'find' and 'position' in seq.lisp
-
-;;; 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 for LIST data
-(deftransform %find-position-if ((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)
- (when (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))))
-
-;;; %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-function test)))
- (lambda (i)
- (funcall test-fun i item)))
- sequence
- from-end
- start
- end
- (%coerce-callable-to-function 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))))))
-(defmacro %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
- `(funcall ,test ,item (funcall ,key ,element)))))
-(defmacro %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)))))
-
-;;; %FIND-POSITION and %FIND-POSITION-IF 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 ((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))
-\f
-;;;; optimizations for floating point FLOOR, CEILING, TRUNCATE, and
-;;;; ROUND, lifted from CMU CL 18c
-;;;;
-;;;; (Without these optimizations, these functions cons!)
-
-;;; Convert (TRUNCATE x y) to the obvious implementation. We only want
-;;; this when under certain conditions and let the generic TRUNCATE
-;;; handle the rest. (Note: if Y = 1, the divide and multiply by Y
-;;; should be removed by other DEFTRANSFORMs.)
-(deftransform truncate ((x &optional y)
- (float &optional (or float integer)))
- '(let ((res (%unary-truncate (/ x y))))
- (values res (- x (* y res)))))
-
-(deftransform floor ((number &optional divisor)
- (float &optional (or integer float)))
- '(multiple-value-bind (tru rem) (truncate number divisor)
- (if (and (not (zerop rem))
- (if (minusp divisor)
- (plusp number)
- (minusp number)))
- (values (1- tru) (+ rem divisor))
- (values tru rem))))
-
-(deftransform ceiling ((number &optional divisor)
- (float &optional (or integer float)))
- '(multiple-value-bind (tru rem) (truncate number divisor)
- (if (and (not (zerop rem))
- (if (minusp divisor)
- (minusp number)
- (plusp number)))
- (values (1+ tru) (- rem divisor))
- (values tru rem))))