[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/05: Ensure <prompt> handler is values handler
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/05: Ensure <prompt> handler is values handler |
Date: |
Mon, 4 May 2020 09:25:21 -0400 (EDT) |
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