RFA: use /dev/tty for debugging interaction

[Jim Blandy <jimb at redhat dot com>]

2004-12-13  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.

Index: cgen/read.scm
===================================================================
RCS file: /cvs/cvsfiles/devo/cgen/read.scm,v
retrieving revision 1.32
diff -c -p -r1.32 read.scm
*** cgen/read.scm	20 Oct 2003 01:25:22 -0000	1.32
--- cgen/read.scm	16 Dec 2004 16:44:31 -0000
*************** Define a preprocessor-style macro.
*** 963,968 ****
--- 963,979 ----
  
  (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
*************** Define a preprocessor-style macro.
*** 975,987 ****
  ; 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))))
  )
  
  ; Utility for debug-repl.
--- 986,1001 ----
  ; FIXME: Move to utils.scm.
  
  (define (debug-repl env-alist)
!   (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.
Index: cgen/utils.scm
===================================================================
RCS file: /cvs/cvsfiles/devo/cgen/utils.scm,v
retrieving revision 1.81
diff -c -p -r1.81 utils.scm
*** cgen/utils.scm	22 Mar 2004 22:05:20 -0000	1.81
--- cgen/utils.scm	16 Dec 2004 16:44:31 -0000
***************
*** 304,309 ****
--- 310,344 ----
  )
  
  ; 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.