--- a/lisp/ChangeLog	Mon Jun 17 10:23:00 2013 -0600
+++ b/lisp/ChangeLog	Mon Jun 17 19:54:02 2013 +0100
@@ -1,3 +1,10 @@
+2013-06-17  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el:
+	* cl-macs.el (apply-partially):
+	Be more intelligent about constructing (or not) compiled functions
+	at runtime or compile time when making these closures.
+
 2013-03-02  Michael Sperber  <mike@xemacs.org>
 
 	* bytecomp.el (byte-compile-if): Port this patch from GNU Emacs:

--- a/lisp/cl-macs.el	Mon Jun 17 10:23:00 2013 -0600
+++ b/lisp/cl-macs.el	Mon Jun 17 19:54:02 2013 +0100
@@ -3517,28 +3517,87 @@
 
 (define-compiler-macro apply-partially (&whole form &rest args)
   "Generate a #'make-byte-code call for #'apply-partially, if appropriate."
-  (if (< (length args) 1)
-      form
-    (if (cl-const-exprs-p args)
-        `#'(lambda (&rest args) (apply ,@args args))
-      (let* ((placeholders (mapcar 'quote-maybe (mapcar 'gensym args)))
-             (compiled (byte-compile-sexp
-                        `#'(lambda (&rest args) (apply ,@placeholders args)))))
-        (assert (equal (intersection
-                        (mapcar 'quote-maybe (compiled-function-constants
-                                              compiled))
-                        placeholders :test 'equal :stable t)
-                       placeholders)
-                t "This macro requires that the relative order is the same\
-in the constants vector and in the arguments")
+  (when (< (length args) 1)
+    (return-from apply-partially form))
+  (let* ((values (cdr args)) (count (length values))
+         (placeholders (mapcar #'quote-maybe (mapcar #'gensym values)))
+         (sublis (pairlis placeholders values))
+         restp lambda arglist bindings compiled)
+    (when (and (eq 'function (car-safe (nth 0 args)))
+               (eq 'lambda (car-safe (nth 1 (nth 0 args)))))
+      (setq lambda (nth 1 (nth 0 args))
+            arglist (nth 1 lambda))
+      (when (> count (function-max-args lambda))
+        (byte-compile-warn
+         "attempt to apply-partially %S with too many arguments" lambda)
+        (return-from apply-partially form))
+      (while (and arglist placeholders)
+	(cond ((eq (car arglist) '&optional)
+	       (if restp
+                   (error 'syntax-error
+                          "&optional found after &rest in %S" lambda))
+	       (if (null (cdr arglist))
+		   (error 'syntax-error "nothing after &optional in %S"
+                          lambda)))
+	      ((eq (car arglist) '&rest)
+	       (if (null (cdr arglist))
+		   (error 'syntax-error "nothing after &rest in %S" lambda))
+	       (if (cdr (cdr arglist))
+		   (error 'syntax-error "multiple vars after &rest in %S"
+                          lambda))
+	       (setq restp t))
+	      (restp
+	       (setq bindings (cons (list (car arglist)
+					  (and placeholders
+                                               (cons 'list placeholders)))
+				    bindings)
+		     placeholders nil))
+	      (t
+	       (setq bindings (cons (list (car arglist) (car placeholders))
+				    bindings)
+		     placeholders (cdr placeholders))))
+	(setq arglist (cdr arglist)))
+      (when (cl-const-exprs-p values)
+        ;; Values are constant, no need to construct the compiled function
+        ;; at runtime.
+        (return-from apply-partially
+          (byte-compile-lambda
+           `(lambda ,arglist (let ,(sublis sublis (nreverse bindings)
+                                           :test #'equal)
+                               ,@(cddr lambda))))))
+      (setq compiled (byte-compile-lambda
+                      `(lambda ,arglist (let ,(nreverse bindings)
+                                          ,@(cddr lambda)))))
+      (return-from apply-partially
         `(make-byte-code
           ',(compiled-function-arglist compiled)
           ,(compiled-function-instructions compiled)
-          (vector ,@(sublis (pairlis placeholders args)
+          (vector ,@(sublis sublis
                             (mapcar 'quote-maybe
                                     (compiled-function-constants compiled))
                             :test 'equal))
-          ,(compiled-function-stack-depth compiled))))))
+          ,(compiled-function-stack-depth compiled))))
+    (if (cl-const-exprs-p args)
+        `#'(lambda (&rest args) (apply ,@args args))
+        (let* ((placeholders (mapcar 'quote-maybe (mapcar 'gensym args)))
+               (compiled (byte-compile-sexp
+                          `#'(lambda (&rest args)
+                               (apply ,@placeholders args)))))
+          (assert (equal (intersection
+                          (mapcar 'quote-maybe (compiled-function-constants
+                                                compiled))
+                          placeholders :test 'equal :stable t)
+                         placeholders)
+                  t "This macro requires that the relative order is the same\
+in the constants vector and in the arguments")
+          `(make-byte-code
+            ',(compiled-function-arglist compiled)
+            ,(compiled-function-instructions compiled)
+            (vector ,@(sublis (pairlis placeholders args)
+                              (mapcar 'quote-maybe
+                                      (compiled-function-constants compiled))
+                              :test 'equal))
+            ,(compiled-function-stack-depth compiled))))))
 
 (define-compiler-macro delete-dups (list)
   `(delete-duplicates (the list ,list) :test #'equal :from-end t))

--- a/tests/ChangeLog	Mon Jun 17 10:23:00 2013 -0600
+++ b/tests/ChangeLog	Mon Jun 17 19:54:02 2013 +0100
@@ -1,3 +1,9 @@
+2013-06-17  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* automated/lisp-tests.el:
+	Test #'apply-partially more extensively, given changes in
+	cl-macs.el.
+
 2013-06-17  Jerry James  <james@xemacs.org>
 
 	* automated/lisp-tests.el: Adjust expected failure message due to

--- a/tests/automated/lisp-tests.el	Mon Jun 17 10:23:00 2013 -0600
+++ b/tests/automated/lisp-tests.el	Mon Jun 17 19:54:02 2013 +0100
@@ -2950,12 +2950,34 @@
        (times-four (apply-partially '* four))
        (plus-twelve (apply-partially '+ 6 (* 3 2)))
        (construct-list (apply-partially 'list (incf four) (incf four)
-                                        (incf four))))
+                                        (incf four)))
+       (list-and-multiply
+        (apply-partially #'(lambda (a b c d &optional e)
+                             (cons (apply #'+ a b c d (if e (list e)))
+                                   (list* a b c d e)))
+                         ;; Constant arguments -> function can be
+                         ;; constructed at compile time
+                         1 2 3))
+       (list-and-four
+        (apply-partially #'(lambda (a b c d &optional e)
+                             (cons (apply #'+ a b c d (if e (list e)))
+                                   (list* a b c d e)))
+                         ;; Not constant arguments -> function constructed
+                         ;; at runtime.
+                         1 2 four)))
   (Assert (eql (funcall times-four 6) 24))
   (Assert (eql (funcall times-four 4 4) 64))
   (Assert (eql (funcall plus-twelve (funcall times-four 4) 4 4) 36))
   (Check-Error wrong-number-of-arguments (apply-partially))
-  (Assert (equal (funcall construct-list) '(5 6 7))))
+  (Assert (equal (funcall construct-list) '(5 6 7)))
+  (Assert (equal (funcall list-and-multiply 5 6) '(17 1 2 3 5 . 6)))
+  (Assert (equal (funcall list-and-multiply 7) '(13 1 2 3 7)))
+  (Check-Error wrong-number-of-arguments
+               (funcall list-and-multiply 7 8 9 10))
+  (Assert (equal (funcall list-and-four 5 6) '(21 1 2 7 5 . 6)))
+  (Assert (equal (funcall list-and-four 7) '(17 1 2 7 7)))
+  (Check-Error wrong-number-of-arguments
+               (funcall list-and-four 7 8 9 10)))
 
 ;; Test labels and inlining.
 (labels