fix prompt in fix in single-value context compilation

* 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.

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 23648cd..f193e9d 100644 (file)
--- 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 ce2e1bf..6f1804a 100644 (file)
--- 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)