From 9dadfa47b07548ff5cf3604067910c8aece93c42 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 27 Mar 2011 15:00:18 +0200
Subject: [PATCH] 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.
---
 module/language/tree-il/compile-glil.scm |  8 +-
 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)