[COMMIT] Make #'apply-partially more intelligent still when byte-compiled.

APPROVE COMMIT NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # 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&gt; * 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&gt; * 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&gt; + + * 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&gt; * 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&gt; + + * automated/lisp-tests.el: + Test #'apply-partially more extensively, given changes in + cl-macs.el. + 2013-06-17 Jerry James <james(a)xemacs.org&gt; * 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