diff options
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 8 | ||||
-rw-r--r-- | test-suite/tests/control.test | 95 |
2 files changed, 99 insertions, 4 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 23648cdde..f193e9dcd 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -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) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index ce2e1bf0a..6f1804a3f 100644 --- a/test-suite/tests/control.test +++ b/test-suite/tests/control.test @@ -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) |