mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Ensure <prompt> handler is values handler

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-04 10:44:10 +02:00
parent d6b6daca37
commit 167350db21
3 changed files with 46 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

26
module/language/tree-il/compile-cps.scm
View file

@ -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))

32
module/language/tree-il/primitives.scm
View file

@ -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*

22
test-suite/tests/peval.test
View file

@ -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