summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/compile-glil.scm8
-rw-r--r--test-suite/tests/control.test95
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)