X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=bfea7221c7e159c72fd2925fd298b614e187e7e9;hb=40bf78b47ea89b15698adb9c550efa4cbacafeb7;hp=f92cd13cba2f17b9cf6029d878ce4eca92681ab1;hpb=1bbb76fcfb9baddf0dc96412c87575d8aeb69c6d;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index f92cd13..bfea722 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -26,25 +26,29 @@ (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)))))))) @@ -807,26 +811,10 @@ :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 @@ -949,44 +937,48 @@ ;;; 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)) @@ -1011,14 +1003,14 @@ ;;; 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))