From: William Harold Newman Date: Sun, 23 Feb 2003 22:50:01 +0000 (+0000) Subject: 0.7.12.56: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=12348c1417becbbd24dd3f109ed4040dbdde62dd;p=sbcl.git 0.7.12.56: merged Matthew Danish patch (sbcl-devel Feb 18) fixing eval order and ONCE-ONLYness for function args (my contribution to the "what have we here?" theme of the intercontinental party we're holding to celebrate today's nonrelease:-) --- diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 9e04f7e..eb3f9df 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -187,13 +187,13 @@ ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. -(define-source-transform make-string (length &key - (element-type ''base-char) - (initial-element - '#.*default-init-char-form*)) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element)) +(deftransform make-string ((length &key + (element-type 'base-char) + (initial-element + #.*default-init-char-form*))) + '(make-array (the index length) + :element-type element-type + :initial-element initial-element)) (defstruct (specialized-array-element-type-properties (:conc-name saetp-) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 89b0494..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)))))))) @@ -933,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)) @@ -995,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)) diff --git a/version.lisp-expr b/version.lisp-expr index f24a854..6131f3d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.12.55" +"0.7.12.56"