+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
(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
; 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.
\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.