mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

fix prompt in fix in single-value context compilation

Browse source 
* module/language/tree-il/compile-glil.scm (flatten): When compiling a
  <prompt> in push context with an RA, after the body returns normally,
  jump to that RA instead of to our POST label (which in that case does
  not need to be emitted).  Fixes a tail <prompt> in a push <fix>.

* test-suite/tests/control.test ("prompt in different contexts"): Add
  more test cases.
This commit is contained in:
Andy Wingo 2011-03-27 15:00:18 +02:00
parent 62f528e929
commit 9dadfa47b0
2 changed files with 99 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/language/tree-il/compile-glil.scm
View file

@ -1,6 +1,6 @@
;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.
;; Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -1095,7 +1095,7 @@
;; post
(comp-push body)
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br POST))
(emit-branch #f 'br (or RA POST)))
((vals)
(let ((MV (make-label)))
@ -1138,8 +1138,8 @@
(comp-tail body)
(emit-code #f (make-glil-unbind))))
(if (or (eq? context 'push)
(and (eq? context 'drop) (not RA)))
(if (and (not RA)
(or (eq? context 'push) (eq? context 'drop)))
(emit-label POST))))
((<abort> src tag args tail)

95
test-suite/tests/control.test
View file

@ -178,6 +178,101 @@
(eq? (k 'xyzzy)
'xyzzy))))
;; Here we test different cases for the `prompt'.
(with-test-prefix/c&e "prompt in different contexts"
(pass-if "push, normal exit"
(car (call-with-prompt
'foo
(lambda () '(#t))
(lambda (k) '(#f)))))
(pass-if "push, nonlocal exit"
(car (call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo) '(#f))
(lambda (k) '(#t)))))
(pass-if "push with RA, normal exit"
(car (letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () '(#t))
(lambda (k) '(#f))))))
(test))))
(pass-if "push with RA, nonlocal exit"
(car (letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo) '(#f))
(lambda (k) '(#t))))))
(test))))
(pass-if "tail, normal exit"
(call-with-prompt
'foo
(lambda () #t)
(lambda (k) #f)))
(pass-if "tail, nonlocal exit"
(call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo) #f)
(lambda (k) #t)))
(pass-if "tail with RA, normal exit"
(letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () #t)
(lambda (k) #f)))))
(test)))
(pass-if "tail with RA, nonlocal exit"
(letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo) #f)
(lambda (k) #t)))))
(test)))
(pass-if "drop, normal exit"
(begin
(call-with-prompt
'foo
(lambda () #f)
(lambda (k) #f))
#t))
(pass-if "drop, nonlocal exit"
(begin
(call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo))
(lambda (k) #f))
#t))
(pass-if "drop with RA, normal exit"
(begin
(letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () #f)
(lambda (k) #f)))))
(test))
#t))
(pass-if "drop with RA, nonlocal exit"
(begin
(letrec ((test (lambda ()
(call-with-prompt
'foo
(lambda () (abort-to-prompt 'foo) #f)
(lambda (k) #f)))))
(test))
#t)))
(define fl (make-fluid))
(fluid-set! fl 0)