summaryrefslogtreecommitdiff
path: root/module/language/tree-il/primitives.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2020-05-04 10:44:10 +0200
committerAndy Wingo <wingo@pobox.com>2020-05-04 10:53:29 +0200
commit167350db21df51b146b11aaeb9691c39f63ed1cc (patch)
tree78eec7c1c5859fede6415163499f8931425b6e33 /module/language/tree-il/primitives.scm
parentd6b6daca372e3a7d2abc601e2b60d6c2cc6c0abc (diff)
downloadguile-167350db21df51b146b11aaeb9691c39f63ed1cc.tar.gz
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.
Diffstat (limited to 'module/language/tree-il/primitives.scm')
-rw-r--r--module/language/tree-il/primitives.scm32
1 files changed, 31 insertions, 1 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 300080d45..b1fa344af 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*