mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

more general treatment of call-with-prompt

Browse source 
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
  Don't limit the call-with-prompt to <prompt> transition to lambda
  expressions.  Instead we can lexically bind the handler, and rely on
  peval to propagate a lambda expression.
This commit is contained in:
Andy Wingo 2012-03-02 13:02:19 +01:00
parent e082b13b66
commit 20337139d2
2 changed files with 44 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -538,22 +538,21 @@
'call-with-prompt
(case-lambda
((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline
;; (let ((h (lambda ...))) (prompt k x h))
(cond
((lambda? handler)
(let ((args-sym (gensym)))
(make-prompt
src tag (make-application #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-application #f (make-primitive-ref #f 'apply)
(list handler
(make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
(let ((handler-sym (gensym))
(args-sym (gensym)))
(make-let
src '(handler) (list handler-sym) (list handler)
(make-prompt
src tag (make-application #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-application
#f (make-primitive-ref #f 'apply)
(list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym)))
#f)))))
(else #f)))
(hashq-set! *primitive-expand-table*

29
test-suite/tests/tree-il.test
View file

@ -1532,6 +1532,35 @@
(lambda args args)))
(const 1))
;; Handler lambda inlined
(pass-if-peval
resolve-primitives
(call-with-prompt tag
(lambda () 1)
(lambda args args))
(prompt (toplevel tag)
(const 1)
(lambda-case
((() #f args #f () (_))
(apply (primitive @apply)
(lambda _ _)
(lexical args _))))))
;; Handler toplevel not inlined
(pass-if-peval
resolve-primitives
(call-with-prompt tag
(lambda () 1)
handler)
(let (handler) (_) ((toplevel handler))
(prompt (toplevel tag)
(const 1)
(lambda-case
((() #f args #f () (_))
(apply (primitive @apply)
(lexical handler _)
(lexical args _)))))))
(pass-if-peval
resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its