APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1371495242 -3600
# Node ID 165315eae1ab4d64ecc4a2d7e919fa4f13844421
# Parent 3192994c49caeb8083d28711b176a8ffe32e6e31
Make #'apply-partially more intelligent still when byte-compiled.
lisp/ChangeLog addition:
2013-06-17 Aidan Kehoe <kehoea(a)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.
tests/ChangeLog addition:
2013-06-17 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Test #'apply-partially more extensively, given changes in
cl-macs.el.
diff -r 3192994c49ca -r 165315eae1ab lisp/ChangeLog
--- 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(a)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(a)xemacs.org>
* bytecomp.el (byte-compile-if): Port this patch from GNU Emacs:
diff -r 3192994c49ca -r 165315eae1ab lisp/cl-macs.el
--- 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))
diff -r 3192994c49ca -r 165315eae1ab tests/ChangeLog
--- 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(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Test #'apply-partially more extensively, given changes in
+ cl-macs.el.
+
2013-06-17 Jerry James <james(a)xemacs.org>
* automated/lisp-tests.el: Adjust expected failure message due to
diff -r 3192994c49ca -r 165315eae1ab tests/automated/lisp-tests.el
--- 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
--
‘Liston operated so fast that he once accidentally amputated an assistant’s
fingers along with a patient’s leg, […] The patient and the assistant both
died of sepsis, and a spectator reportedly died of shock, resulting in the
only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches