diff options
author | Andy Wingo <wingo@pobox.com> | 2020-05-04 10:44:10 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-05-04 10:53:29 +0200 |
commit | 167350db21df51b146b11aaeb9691c39f63ed1cc (patch) | |
tree | 78eec7c1c5859fede6415163499f8931425b6e33 /module | |
parent | d6b6daca372e3a7d2abc601e2b60d6c2cc6c0abc (diff) | |
download | guile-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.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* |