2 new commits in XEmacs: https://bitbucket.org/xemacs/xemacs/commits/165315eae1ab/ Changeset: 165315eae1ab User: kehoea Date: 2013-06-17 20:54:02 Summary: 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. Affected #: 4 files diff -r 3192994c49caeb8083d28711b176a8ffe32e6e31 -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 lisp/ChangeLog --- a/lisp/ChangeLog +++ b/lisp/ChangeLog ＠＠ -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 3192994c49caeb8083d28711b176a8ffe32e6e31 -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 lisp/cl-macs.el --- a/lisp/cl-macs.el +++ b/lisp/cl-macs.el ＠＠ -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 3192994c49caeb8083d28711b176a8ffe32e6e31 -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 tests/ChangeLog --- a/tests/ChangeLog +++ b/tests/ChangeLog ＠＠ -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 3192994c49caeb8083d28711b176a8ffe32e6e31 -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el +++ b/tests/automated/lisp-tests.el ＠＠ -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 https://bitbucket.org/xemacs/xemacs/commits/f6af091ac654/ Changeset: f6af091ac654 User: kehoea Date: 2013-06-17 21:37:47 Summary: Use new language features in #'call-process-internal now they're available. lisp/ChangeLog addition: 2013-06-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; * process.el (process-synchronize-point): Moved to a label. * process.el (call-process-internal): Now we have better language features, use them rather than creating a closure ourselves or exposing a utility function when there is no need for that with a well-implemented labels function. Affected #: 2 files diff -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 -r f6af091ac6548f5e840cb3c31107474eda04f1cb lisp/ChangeLog --- a/lisp/ChangeLog +++ b/lisp/ChangeLog ＠＠ -1,3 +1,11 ＠＠ +2013-06-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * process.el (process-synchronize-point): Moved to a label. + * process.el (call-process-internal): + Now we have better language features, use them rather than + creating a closure ourselves or exposing a utility function when + there is no need for that with a well-implemented labels function. + 2013-06-17 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-macs.el: diff -r 165315eae1ab4d64ecc4a2d7e919fa4f13844421 -r f6af091ac6548f5e840cb3c31107474eda04f1cb lisp/process.el --- a/lisp/process.el +++ b/lisp/process.el ＠＠ -109,29 +109,6 ＠＠ shell-command-switch (mapconcat 'identity (cons command args) " "))) -(defun process-synchronize-point (proc) - "Set the point(s) in buffer and stderr-buffer according to the process mark." - ;; We need this because the documentation says to insert *BEFORE* point, - ;; but we end up inserting after because only the process mark moves - ;; forward, not point. We synchronize after every place output might - ;; happen, in sentinels, and in an unwind-protect, to make *SURE* that - ;; point is correct. (We could do this more easily and perhaps more - ;; safely using a process filter, but that would create a LOT of garbage - ;; since all the data would get sent in strings.) We make this a separate - ;; function, not an flet, due to dynamic binding problems -- the flet may - ;; not still be in scope when the sentinel is called. - (let ((pb (process-buffer proc)) - (pm (process-mark proc))) - (if (and pb (buffer-live-p pb) (marker-buffer pm)) - (goto-char pm pb)) - (if (process-has-separate-stderr-p proc) - (let ((pseb (process-stderr-buffer proc)) - (psem (process-stderr-mark proc))) - (if (and pseb (not (eq pb pseb)) - (buffer-live-p pseb) - (marker-buffer psem)) - (goto-char psem pseb)))))) - (defun call-process-internal (program &optional infile buffer display &rest args) "Internal function to call PROGRAM synchronously in separate process. ＠＠ -179,7 +156,33 ＠＠ ;; note that we need to be *very* careful in this code to handle C-g ;; at any point. (unwind-protect - (progn + (labels + ((process-synchronize-point (proc) + ;; Set the point(s) in buffer and stderr-buffer according to + ;; the process mark. + ;; + ;; We need this because the documentation says to insert + ;; *BEFORE* point, but we end up inserting after because only + ;; the process mark moves forward, not point. We synchronize + ;; after every place output might happen, in sentinels, and + ;; in an unwind-protect, to make *SURE* that point is + ;; correct. (We could do this more easily and perhaps more + ;; safely using a process filter, but that would create a LOT + ;; of garbage since all the data would get sent in strings.) + ;; We make this a label, not an flet, due to dynamic binding + ;; problems -- the flet may not still be in scope when the + ;; sentinel is called. + (let ((pb (process-buffer proc)) + (pm (process-mark proc))) + (if (and pb (buffer-live-p pb) (marker-buffer pm)) + (goto-char pm pb)) + (if (process-has-separate-stderr-p proc) + (let ((pseb (process-stderr-buffer proc)) + (psem (process-stderr-mark proc))) + (if (and pseb (not (eq pb pseb)) + (buffer-live-p pseb) + (marker-buffer psem)) + (goto-char psem pseb))))))) ;; first handle INFILE. (cond ((stringp infile) (setq infile (expand-file-name infile)) ＠＠ -263,25 +266,20 ＠＠ ;; we finish. ;; ;; #### not clear if we should be doing this. - ;; - ;; NOTE NOTE NOTE: Due to the total bogosity of - ;; dynamic scoping, and the lack of closures, we - ;; have to be careful how we write the first - ;; sentinel below since it may be executed after - ;; this function has returned -- thus we fake a - ;; closure. (This doesn't apply to the second one, - ;; which only gets executed within the - ;; unwind-protect.) - `(lambda (proc status) - (set-process-sentinel proc nil) - (process-synchronize-point proc) - (with-current-buffer ,errbuf - (write-region-internal - 1 (1+ (buffer-size)) - ,stderr - nil 'major-rms-kludge-city nil - coding-system-for-write)) - (kill-buffer ,errbuf))) + (apply-partially + #'(lambda (errbuf stderr proc status) + (set-process-sentinel proc nil) + (process-synchronize-point proc) + (with-current-buffer errbuf + (write-region-internal + 1 (1+ (buffer-size)) + stderr + nil 'major-rms-kludge-city nil + coding-system-for-write)) + (kill-buffer errbuf)) + ;; Close around these two variables, the lambda may be + ;; called outside this enclosing unwind-protect. + errbuf stderr)) (no-wait nil) (t ;; normal sentinel: maybe write out stderr and return Repository URL: https://bitbucket.org/xemacs/xemacs/ -- This is a commit notification from bitbucket.org. You are receiving this because you have the service enabled, addressing the recipient of this email. _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches