mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +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 'call-with-prompt
(case-lambda (case-lambda
((src tag thunk handler) ((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline (let ((handler-sym (gensym))
;; (let ((h (lambda ...))) (prompt k x h)) (args-sym (gensym)))
(cond (make-let
((lambda? handler) src '(handler) (list handler-sym) (list handler)
(let ((args-sym (gensym))) (make-prompt
(make-prompt src tag (make-application #f thunk '())
src tag (make-application #f thunk '()) ;; If handler itself is a lambda, the inliner can do some
;; If handler itself is a lambda, the inliner can do some ;; trickery here.
;; trickery here. (make-lambda-case
(make-lambda-case (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (make-application
(make-application #f (make-primitive-ref #f 'apply) #f (make-primitive-ref #f 'apply)
(list handler (list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f)))))
(else #f)))
(else #f))) (else #f)))
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*

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

@ -1532,6 +1532,35 @@
(lambda args args))) (lambda args args)))
(const 1)) (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 (pass-if-peval
resolve-primitives resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its ;; `while' without `break' or `continue' has no prompts and gets its