diff options
| -rw-r--r-- | module/language/tree-il/compile-cps.scm | 26 | ||||
| -rw-r--r-- | module/language/tree-il/primitives.scm | 32 | ||||
| -rw-r--r-- | 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 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* diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 2eecc8218..3805259f0 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 |