summaryrefslogtreecommitdiff
path: root/module
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
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')
-rw-r--r--module/language/tree-il/compile-cps.scm26
-rw-r--r--module/language/tree-il/primitives.scm32
2 files changed, 31 insertions, 27 deletions
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 8f048a504..5d3457e16 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 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*