* read.scm (debug-repl): Temporarily redirect input and output to

/dev/tty while we debug, so we don't interfere with whatever CGEN
is reading or writing.
* utils.scm (setter-getter-fluid-let, with-input-and-output-to):
New functions.

diff --git a/cgen/ChangeLog b/cgen/ChangeLog
index 71b397d..7db756c 100644 (file)
--- a/cgen/ChangeLog
+++ b/cgen/ChangeLog
@@ -1,3 +1,11 @@
+2004-12-16  Jim Blandy  <jimb@redhat.com>
+
+       * read.scm (debug-repl): Temporarily redirect input and output to
+       /dev/tty while we debug, so we don't interfere with whatever CGEN
+       is reading or writing.
+       * utils.scm (setter-getter-fluid-let, with-input-and-output-to):
+       New functions.
+
 2004-11-15  Michael K. Lechner <mike.lechner@gmail.com>
 
        * cpu/iq2000.cpu: Added quotes around macro arguments so that they

diff --git a/cgen/read.scm b/cgen/read.scm
index d6521e1..ee07c22 100644 (file)
--- a/cgen/read.scm
+++ b/cgen/read.scm
@@ -952,6 +952,17 @@ Define a preprocessor-style macro.
 
 (define (debug-var name) (assq-ref debug-env name))
 
+; A handle on /dev/tty, so we can be sure we're talking with the user.
+; We open this the first time we actually need it.
+(define debug-tty #f)
+
+; Return the port we should use for interacting with the user,
+; opening it if necessary.
+(define (debug-tty-port)
+  (if (not debug-tty)
+      (set! debug-tty (open-file "/dev/tty" "r+")))
+  debug-tty)
+
 ; Enter a repl loop for debugging purposes.
 ; Use (quit) to exit cgen completely.
 ; Use (debug-quit) or (quit 0) to exit the debugging session and
@@ -964,13 +975,16 @@ Define a preprocessor-style macro.
 ; FIXME: Move to utils.scm.
 
 (define (debug-repl env-alist)
-  (set! debug-env env-alist)
-  (let loop ()
-    (let ((rc (top-repl)))
-      (if (null? rc)
-         (quit 1)) ; indicate error to `make'
-      (if (not (equal? rc '(0)))
-         (loop))))
+  (with-input-and-output-to
+   (debug-tty-port)
+   (lambda ()
+     (set! debug-env env-alist)
+     (let loop ()
+       (let ((rc (top-repl)))
+        (if (null? rc)
+            (quit 1))                  ; indicate error to `make'
+        (if (not (equal? rc '(0)))
+            (loop))))))
 )
 
 ; Utility for debug-repl.

diff --git a/cgen/utils.scm b/cgen/utils.scm
index 0859e3f..43988e6 100644 (file)
--- a/cgen/utils.scm
+++ b/cgen/utils.scm
@@ -305,6 +305,35 @@
 \f
 ; Output routines.
 
+;; Given some state that has a setter function (SETTER NEW-VALUE) and
+;; a getter function (GETTER), call THUNK with the state set to VALUE,
+;; and restore the original value when THUNK returns.  Ensure that the
+;; original value is restored whether THUNK returns normally, throws
+;; an exception, or invokes a continuation that leaves the call's
+;; dynamic scope.
+(define (setter-getter-fluid-let setter getter value thunk)
+  (let ((swap (lambda ()
+               (let ((temp (getter)))
+                 (setter value)
+                 (set! value temp)))))
+    (dynamic-wind swap thunk swap)))
+      
+
+;; Call THUNK with the current input and output ports set to PORT, and
+;; then restore the current ports to their original values.
+;; 
+;; This ensures the current ports get restored whether THUNK exits
+;; normally, throws an exception, or leaves the call's dynamic scope
+;; by applying a continuation.
+(define (with-input-and-output-to port thunk)
+  (setter-getter-fluid-let
+   set-current-input-port current-input-port port
+   (lambda ()
+     (setter-getter-fluid-let
+      set-current-output-port current-output-port port
+      thunk))))
+
+
 ; Extension to the current-output-port.
 ; Only valid inside string-write.