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 (file)
--- 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 (file)
--- 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 (file)
--- 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"