[elpa] master 2a532d3 077/187: Replace closure prevention with closure sanitation

[Michael Albinus]

branch: master
commit 2a532d388db717a9eedfd2e80255e4b276cc2e1c
Author: Ryan C. Thompson <address@hidden>
Commit: Ryan C. Thompson <address@hidden>

    Replace closure prevention with closure sanitation
    
    "Sanitation" means that if a closure's list of lexical variables
    contains any variables with unprintable values, those variables are
    removed from the list. When async-debug is on, this also generates a
    message about the removed variables.
    
    This solution is arguably more hackish, but should also work in every
    case where the "prevent all closures" solution worked as well as some
    more cases.
---
 async-test.el |   12 ++++++----
 async.el      |   61 +++++++++++++++++++++++++++++++++++++++++++-------------
 2 files changed, 54 insertions(+), 19 deletions(-)

diff --git a/async-test.el b/async-test.el
index b77fdd1..c1dbb0a 100644
--- a/async-test.el
+++ b/async-test.el
@@ -287,9 +287,11 @@ Return the name of the directory."
   ;; 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
-  ;; loop. Closure prevention avoids the error from this unprintable
-  ;; lexical value in these examples.
+  ;; 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
@@ -305,8 +307,8 @@ Return the name of the directory."
                (cl-loop repeat 2 collect
                         (async-start `(lambda () ,(* 150 2))))))
    t)
-  ;; However closure prevention also (obviously) prevents creation of
-  ;; lexical closures, leading to an error in this case.
+  ;; The following lexical closure should work fine, since x, y, and z
+  ;; all have printable values.
   (should
    (eq 6
        (eval
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