[Guile-commits] 02/05: Ensure <prompt> handler is values handler

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 167350db21df51b146b11aaeb9691c39f63ed1cc
Author: Andy Wingo <address@hidden>
AuthorDate: Mon May 4 10:44:10 2020 +0200

    Ensure <prompt> handler is values handler
    
    * module/language/tree-il/primitives.scm (call-with-prompt): Only pass
      "values handlers" as handler: lambdas with only req and rest args, and
      only one clause.
    * module/language/tree-il/compile-cps.scm (canonicalize): Remove
      eta-conversion pass here.
    * test-suite/tests/peval.test ("partial evaluation"): Adapt test.
---
 module/language/tree-il/compile-cps.scm | 26 --------------------------
 module/language/tree-il/primitives.scm  | 32 +++++++++++++++++++++++++++++++-
 test-suite/tests/peval.test             | 22 +++++++++++++++-------
 3 files changed, 46 insertions(+), 34 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 8f048a5..5d3457e 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2556,32 +2556,6 @@ integer."
                 (make-primcall src 'rsh (list a n)))
               (make-primcall src 'lsh (list a b)))))))
 
-       ;; Eta-convert prompts without inline handlers.
-       (($ <prompt> src escape-only? tag body handler)
-        (let ((h (gensym "h "))
-              (args (gensym "args ")))
-          (define-syntax-rule (primcall name . args)
-            (make-primcall src 'name (list . args)))
-          (define-syntax-rule (const val)
-            (make-const src val))
-          (with-lexicals src (handler)
-            (make-conditional
-             src
-             (primcall procedure? handler)
-             (make-prompt
-              src escape-only? tag body
-              (make-lambda
-               src '()
-               (make-lambda-case
-                src '() #f 'args #f '() (list args)
-                (primcall apply handler (make-lexical-ref #f 'args args))
-                #f)))
-             (primcall throw
-                       (const 'wrong-type-arg)
-                       (const "call-with-prompt")
-                       (const "Wrong type (expecting procedure): ~S")
-                       (primcall cons handler (const '()))
-                       (primcall cons handler (const '())))))))
        (_ exp)))
    exp))
 
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 300080d..b1fa344 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -651,7 +651,37 @@
 (define-primitive-expander! 'call-with-prompt
   (case-lambda
    ((src tag thunk handler)
-    (make-prompt src #f tag thunk handler))
+    (match handler
+      (($ <lambda> _ _ ($ <lambda-case> _ _ #f _ #f () _ _ #f))
+       (make-prompt src #f tag thunk handler))
+      (_
+       ;; Eta-convert prompts without inline handlers.
+       (let ((h (gensym "h "))
+             (args (gensym "args ")))
+         (define-syntax-rule (primcall name . args)
+           (make-primcall src 'name (list . args)))
+         (define-syntax-rule (const val)
+           (make-const src val))
+         (make-let
+          src (list 'handler) (list h) (list handler)
+          (let ((handler (make-lexical-ref src 'handler h)))
+            (make-conditional
+             src
+             (primcall procedure? handler)
+             (make-prompt
+              src #f tag thunk
+              (make-lambda
+               src '()
+               (make-lambda-case
+                src '() #f 'args #f '() (list args)
+                (primcall apply handler (make-lexical-ref #f 'args args))
+                #f)))
+             (primcall throw
+                       (const 'wrong-type-arg)
+                       (const "call-with-prompt")
+                       (const "Wrong type (expecting procedure): ~S")
+                       (primcall list handler)
+                       (primcall list handler)))))))))
    (else #f)))
 
 (define-primitive-expander! 'abort-to-prompt*
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 2eecc82..3805259 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1223,13 +1223,21 @@
       (call-with-prompt tag
                         (lambda () 1)
                         handler)
-    (prompt #f
-            (toplevel tag)
-            (lambda _
-              (lambda-case
-               ((() #f #f #f () ())
-                (const 1))))
-            (toplevel handler)))
+    (let (handler) (_) ((toplevel handler))
+         (if (primcall procedure? (lexical handler _))
+             (prompt #f
+                     (toplevel tag)
+                     (lambda _
+                       (lambda-case
+                        ((() #f #f #f () ())
+                         (const 1))))
+                     (lambda _
+                       (lambda-case
+                        ((() #f args #f () (_))
+                         (primcall apply
+                                   (lexical handler _)
+                                   (lexical args _))))))
+             (primcall throw . _))))
 
   (pass-if-peval
    ;; `while' without `break' or `continue' has no prompts and gets its