(tests `(endp ,v))
(args-to-fn (if take-car `(car ,v) v))))
- (let ((call `(funcall ,fn . ,(args-to-fn)))
- (endtest `(or ,@(tests))))
+ (let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes
+ (call `(funcall ,fn-sym . ,(args-to-fn)))
+ (endtest `(or ,@(tests))))
(ecase accumulate
(:nconc
(let ((temp (gensym))
(map-result (gensym)))
- `(let ((,map-result (list nil)))
+ `(let ((,fn-sym ,fn)
+ (,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
(,endtest (cdr ,map-result))
(setq ,temp (last (nconc ,temp ,call)))))))
(:list
(let ((temp (gensym))
(map-result (gensym)))
- `(let ((,map-result (list nil)))
+ `(let ((,fn-sym ,fn)
+ (,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
(,endtest (cdr ,map-result))
(rplacd ,temp (setq ,temp (list ,call)))))))
((nil)
- `(let ((,n-first ,(first arglists)))
+ `(let ((,fn-sym ,fn)
+ (,n-first ,(first arglists)))
(do-anonymous ,(do-clauses)
(,endtest ,n-first) ,call))))))))
(let ((dacc (funcall really-fun ,@values)))
(declare (ignorable dacc))
,push-dacc))))))))))
+
+;;; MAP-INTO
+(deftransform map-into ((result fun &rest seqs)
+ (vector * &rest *)
+ *)
+ "open code"
+ (let ((seqs-names (mapcar (lambda (x)
+ (declare (ignore x))
+ (gensym))
+ seqs)))
+ `(lambda (result fun ,@seqs-names)
+ (let ((length (array-dimension result 0))
+ (i 0))
+ (declare (type index i))
+ (declare (ignorable i))
+ ,(cond ((null seqs)
+ `(dotimes (j length (setq i length))
+ (setf (aref result j) (funcall fun))))
+ (t
+ `(block nil
+ (map nil
+ (lambda (,@seqs-names)
+ (when (= i length) (return))
+ (setf (aref result i)
+ (funcall fun ,@seqs-names))
+ (incf i))
+ ,@seqs-names))))
+ (when (array-has-fill-pointer-p result)
+ (setf (fill-pointer result) i))
+ result))))
+
\f
;;; FIXME: once the confusion over doing transforms with known-complex
;;; arrays is over, we should also transform the calls to (AND (ARRAY
: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)
+ ;; The order of arguments for asymmetric tests
+ ;; (e.g. #'<, as opposed to order-independent
+ ;; tests like #'=) is specified in the spec
+ ;; section 17.2.1 -- the O/Zi stuff there.
(lambda (i)
(funcall test-fun item i)))
sequence
;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
;;; POSITION-IF, etc.
(define-source-transform effective-find-position-test (test test-not)
- `(cond
- ((and ,test ,test-not)
- (error "can't specify both :TEST and :TEST-NOT"))
- (,test (%coerce-callable-to-fun ,test))
- (,test-not
- ;; (Without DYNAMIC-EXTENT, this is potentially horribly
- ;; inefficient, but since the TEST-NOT option is deprecated
- ;; anyway, we don't care.)
- (complement (%coerce-callable-to-fun ,test-not)))
- (t #'eql)))
+ (once-only ((test test)
+ (test-not test-not))
+ `(cond
+ ((and ,test ,test-not)
+ (error "can't specify both :TEST and :TEST-NOT"))
+ (,test (%coerce-callable-to-fun ,test))
+ (,test-not
+ ;; (Without DYNAMIC-EXTENT, this is potentially horribly
+ ;; inefficient, but since the TEST-NOT option is deprecated
+ ;; anyway, we don't care.)
+ (complement (%coerce-callable-to-fun ,test-not)))
+ (t #'eql))))
(define-source-transform effective-find-position-key (key)
- `(if ,key
- (%coerce-callable-to-fun ,key)
- #'identity))
+ (once-only ((key key))
+ `(if ,key
+ (%coerce-callable-to-fun ,key)
+ #'identity)))
(macrolet ((define-find-position (fun-name values-index)
- `(define-source-transform ,fun-name (item sequence &key
- from-end (start 0) end
- key test test-not)
- `(nth-value ,,values-index
- (%find-position ,item ,sequence
- ,from-end ,start
- ,end
- (effective-find-position-key ,key)
- (effective-find-position-test ,test ,test-not))))))
+ `(deftransform ,fun-name ((item sequence &key
+ from-end (start 0) end
+ key test test-not))
+ '(nth-value ,values-index
+ (%find-position item sequence
+ from-end start
+ end
+ (effective-find-position-key key)
+ (effective-find-position-test
+ test test-not))))))
(define-find-position find 0)
(define-find-position position 1))
(macrolet ((define-find-position-if (fun-name values-index)
- `(define-source-transform ,fun-name (predicate sequence &key
- from-end (start 0)
- end key)
- `(nth-value
- ,,values-index
- (%find-position-if (%coerce-callable-to-fun ,predicate)
- ,sequence ,from-end
- ,start ,end
- (effective-find-position-key ,key))))))
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key))
+ '(nth-value
+ ,values-index
+ (%find-position-if (%coerce-callable-to-fun predicate)
+ sequence from-end
+ start end
+ (effective-find-position-key key))))))
(define-find-position-if find-if 0)
(define-find-position-if position-if 1))
;;; FIXME: Maybe remove uses of these deprecated functions (and
;;; definitely of :TEST-NOT) within the implementation of SBCL.
(macrolet ((define-find-position-if-not (fun-name values-index)
- `(define-source-transform ,fun-name (predicate sequence &key
- from-end (start 0)
- end key)
- `(nth-value
- ,,values-index
- (%find-position-if-not (%coerce-callable-to-fun ,predicate)
- ,sequence ,from-end
- ,start ,end
- (effective-find-position-key ,key))))))
+ `(deftransform ,fun-name ((predicate sequence &key
+ from-end (start 0)
+ end key))
+ '(nth-value
+ ,values-index
+ (%find-position-if-not (%coerce-callable-to-fun predicate)
+ sequence from-end
+ start end
+ (effective-find-position-key key))))))
(define-find-position-if-not find-if-not 0)
(define-find-position-if-not position-if-not 1))
projects / sbcl.git / blobdiff