[elpa] master f18c735 078/187: Merge pull request #19 from DarwinAwardWinner/lexbind-fix

[Michael Albinus]

branch: master
commit f18c7351e55f763d430054adf80a5491f25fa137
Merge: f6d7a74 2a532d3
Author: John Wiegley <address@hidden>
Commit: John Wiegley <address@hidden>

    Merge pull request #19 from DarwinAwardWinner/lexbind-fix
    
    Lexbind fix redux
---
 async-test.el |   93 ++++++++++++++++++++++++++++++++++++++++++++------------
 async.el      |   61 +++++++++++++++++++++++++++++--------
 2 files changed, 120 insertions(+), 34 deletions(-)

diff --git a/async-test.el b/async-test.el
index a5e83e9..c1dbb0a 100644
--- a/async-test.el
+++ b/async-test.el
@@ -131,26 +131,6 @@
    (lambda (result)
      (message "Async process done: %s" result))))
 
-(defun async-test-7 ()
-  (interactive)
-  (message "Starting async-test-7...")
-  (eval
-   '(progn
-      (print
-       (mapcar #'async-get
-               (cl-loop repeat 2 collect
-                        (async-start (lambda () t)))))
-      (print
-       (mapcar #'async-get
-               (cl-loop repeat 2 collect
-                        (async-start '(lambda () t)))))
-      (print
-       (mapcar #'async-get
-               (cl-loop repeat 2 collect
-                        (async-start `(lambda () ,(* 150 2)))))))
-   t)
-  (message "Finished async-test-7 successfully."))
-
 (defsubst async-file-contents (file)
   "Return the contents of FILE, as a string."
   (with-temp-buffer
@@ -272,6 +252,73 @@ Return the name of the directory."
       (if (file-directory-p temp-dir)  (delete-directory temp-dir t))
       (if (file-directory-p temp-dir2) (delete-directory temp-dir2 t)))))
 
+(defun async-do-start-func-value-type-test ()
+  ;; Variable
+  (set 'myfunc-var (lambda () t))
+  ;; Function symbol
+  (fset 'myfunc-fsym myfunc-var)
+  ;; Defun
+  (defun myfunc-defun () t)
+
+  (should-error (error "ERROR"))
+
+  (should (eq t (eval '(async-sandbox myfunc-var))))
+  (should-error (eval '(async-sandbox 'myfunc-var)))
+  (should-error (eval '(async-sandbox #'myfunc-var)))
+
+  (should-error (eval '(async-sandbox myfunc-fsym)))
+  (should (eq t (eval '(async-sandbox 'myfunc-fsym))))
+  (should (eq t (eval '(async-sandbox #'myfunc-fsym))))
+
+  (should-error (eval '(async-sandbox myfunc-defun)))
+  (should (eq t (eval '(async-sandbox 'myfunc-defun))))
+  (should (eq t (eval '(async-sandbox #'myfunc-defun))))
+
+  (should (eq t (eval '(async-sandbox (lambda () t)))))
+  (should (eq t (eval '(async-sandbox '(lambda () t)))))
+  (should (eq t (eval '(async-sandbox #'(lambda () t)))))
+
+  (should-error (eval '(async-sandbox (closure (t) () t))))
+  (should (eq t (eval '(async-sandbox '(closure (t) () t)))))
+  (should (eq t (eval '(async-sandbox #'(closure (t) () t))))))
+
+(defun async-do-lexbind-test ()
+  ;; The `cl-loop' macro creates some lexical variables, and in this
+  ;; case one of those variables (the one that collects the result)
+  ;; gets set to a list of process objects, which are unprintable. If
+  ;; `lexical-binding' is non-nil, this unprintable value is
+  ;; incorporated into the closures created by `lambda' within the lexical
+  ;; scope of the loop, causing an error when another process tried to
+  ;; read in the printed value. `async--sanitize-closure' should
+  ;; prevent this by deleting the unprintable variable from the
+  ;; closure before printing it.
+  (eval
+   '(progn
+       (mapcar #'async-get
+               (cl-loop repeat 2 collect
+                        (async-start (lambda () t))))
+       (mapcar #'async-get
+               (cl-loop repeat 2 collect
+                        (async-start '(lambda () t))))
+       (mapcar #'async-get
+               (cl-loop repeat 2 collect
+                        (async-start #'(lambda () t))))
+       (mapcar #'async-get
+               (cl-loop repeat 2 collect
+                        (async-start `(lambda () ,(* 150 2))))))
+   t)
+  ;; The following lexical closure should work fine, since x, y, and z
+  ;; all have printable values.
+  (should
+   (eq 6
+       (eval
+        '(let ((x 1)
+               (y 2)
+               (z 3))
+           (async-sandbox (lambda () (+ x y z))))
+        t)
+       )))
+
 (ert-deftest async-copy-directory-lisp-sync-1 ()
   (async-do-copy-directory-test t nil nil :synchronously t))
 (ert-deftest async-copy-directory-lisp-sync-2 ()
@@ -299,6 +346,12 @@ Return the name of the directory."
 (ert-deftest async-copy-directory-native-4 ()
   (async-do-copy-directory-test t t t :use-native-commands t))
 
+(ert-deftest async-start-func-value-type-test ()
+  (async-do-start-func-value-type-test))
+
+(ert-deftest async-lexbind-test ()
+  (async-do-lexbind-test))
+
 (provide 'async-test)
 
 ;;; async-test.el ends here
diff --git a/async.el b/async.el
index c4485d6..1527baf 100644
--- a/async.el
+++ b/async.el
@@ -142,6 +142,47 @@ as follows:
     (async--insert-sexp sexp)
     (process-send-region process (point-min) (point-max))))
 
+(defsubst async--value-printable-p (value)
+  "Return non-nil if VALUE can be round-tripped to a string prepresentation."
+  (condition-case nil
+      (let* ((value-string (prin1-to-string value))
+             (value-from-string (car (read-from-string value-string))))
+        (equal value value-from-string))
+    (error nil)))
+
+(defun async--sanitize-closure (func)
+  "If FUNC is a closure, delete unprintable lexicals from it."
+  (when (eq (car-safe func) 'closure)
+    (setf (cadr func)
+          (or (loop for obj in (cadr func)
+                    if (or (not (consp obj))
+                           (async--value-printable-p (cdr obj)))
+                    collect obj
+                    else do
+                    (when async-debug
+                      (message "Sanitized var from closure: %s=%S"
+                               (car obj) (cdr obj))))
+              ;; A closure with no lexicals generally has this value
+              ;; as its cadr, so we'll use that if everything gets
+              ;; filtered out.
+              '(t))))
+  func)
+
+(defsubst async--get-function (func)
+  "Get the function definition of FUNC, whatever it is.
+
+FUNC can be a variable name, "
+  (indirect-function
+   (cond
+    ;; Quoted form => Extract value without evaluating since `(eval
+    ;; (quote (closure ...)))' is an error.
+    ((memq (car-safe func) '(quote function))
+     (cadr func))
+    ;; Anything else => eval it
+    ;; (e.g. variable or function call)
+    (t
+     (eval func)))))
+
 (defun async-batch-invoke ()
   "Called from the child Emacs process' command-line."
   (setq async-in-child-emacs t
@@ -261,21 +302,13 @@ returns nil.  It can still be useful, however, as an 
argument to
 `async-ready' or `async-wait'."
   (require 'find-func)
   (let* ((procvar (make-symbol "proc"))
-         ;; Evaluate START-FUNC if it isn't aready a function.
-         (start-func
-          (if (functionp start-func)
-              start-func
-            (eval start-func)))
+         ;; Evaluate START-FUNC and resolve it to an actual function
+         ;; definition.
          (start-func
-          (if (eq (car start-func) 'lambda)
-              (eval start-func t)
-            start-func)))
-    ;; If START-FUNC is a lambda, prevent it from creating a lexical
-    ;; closure by evaluating it in an empty lexical environment.
-    (when (eq (car start-func) 'lambda)
-      (setq start-func
-            (eval start-func t)))
-    `(let* ((sexp #',start-func)
+          (async--get-function start-func)))
+    (unless (functionp start-func)
+      (error "Start-func is not a function: %S" start-func))
+    `(let* ((sexp (async--sanitize-closure #',start-func))
             (,procvar
              (async-start-process
               "emacs" (file-truename