diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 26 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 32 |
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* |