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/language/tree-il/primitives.scm | |
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/language/tree-il/primitives.scm')
-rw-r--r-- | module/language/tree-il/primitives.scm | 32 |
1 files changed, 31 insertions, 1 deletions
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* |