From: Chris Hanson Date: Wed, 19 Feb 1992 00:05:47 +0000 (+0000) Subject: Add new mechanism for registering inferior threads that do output. X-Git-Tag: 20090517-FFI~9679 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=68ada233fb22aa7ab0fe7db18c5b1ba0d88b4d0d;p=mit-scheme.git Add new mechanism for registering inferior threads that do output. Each inferior thread has its own flag to indicate when it needs to do output, and a thunk that is to be run in the editor to produce the output. When the thread wants to do output, it sets the flag; later, the editor notices that the flag has been set and calls the thunk. --- diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index d8fb964ad..e044656a3 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.216 1992/02/18 14:09:51 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.217 1992/02/19 00:05:11 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology ;;; @@ -65,6 +65,7 @@ (editor-thread-root-continuation) (editor-initial-threads '()) (inferior-thread-changes? false) + (inferior-threads '()) (recursive-edit-continuation false) (recursive-edit-level 0)) (editor-grab-display edwin-editor @@ -368,6 +369,26 @@ This does not affect editor errors or evaluation errors." (with-editor-ungrabbed thunk))) (define inferior-thread-changes?) +(define inferior-threads) + +(define (register-inferior-thread! thread output-processor) + (let ((flags (cons false output-processor))) + (set! inferior-threads + (cons (system-pair-cons (ucode-type weak-cons) thread flags) + inferior-threads)) + flags)) + +(define (inferior-thread-output! flags) + (without-interrupts + (lambda () + (set-car! flags true) + (set! inferior-thread-changes? true) + unspecific))) + +(define (inferior-thread-output!/unsafe flags) + (set-car! flags true) + (set! inferior-thread-changes? true) + unspecific) (define (accept-thread-output) (without-interrupts @@ -375,4 +396,23 @@ This does not affect editor errors or evaluation errors." (and inferior-thread-changes? (begin (set! inferior-thread-changes? false) - (accept-inferior-repl-output/unsafe)))))) \ No newline at end of file + (let loop ((threads inferior-threads) (prev false) (output? false)) + (if (null? threads) + output? + (let ((record (car threads)) + (next (cdr threads))) + (let ((thread (system-pair-car record)) + (flags (system-pair-cdr record))) + (if (and thread (not (thread-dead? thread))) + (loop next + threads + (if (car flags) + (begin + (set-car! flags false) + (or ((cdr flags)) output?)) + output?)) + (begin + (if prev + (set-cdr! prev next) + (set! inferior-threads next)) + (loop next prev output?)))))))))))) \ No newline at end of file diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index ca69115f6..ad80e61d6 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.77 1992/02/17 22:09:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.78 1992/02/19 00:05:47 cph Exp $ Copyright (c) 1989-92 Massachusetts Institute of Technology @@ -972,7 +972,6 @@ MIT in each case. |# (files "intmod") (parent (edwin)) (export (edwin) - accept-inferior-repl-output/unsafe edwin-command$inferior-debugger-self-insert edwin-command$inferior-repl-abort-nearest edwin-command$inferior-repl-abort-previous diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 0864c2f56..2186df686 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.43 1992/02/17 22:01:47 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.44 1992/02/19 00:05:28 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology ;;; @@ -76,7 +76,6 @@ but prefix argument means prompt for different environment." (let ((thread (current-thread))) (detach-thread thread) (let ((port (make-interface-port buffer thread))) - (register-interface-port! port) (attach-buffer-interface-port! buffer port) (with-input-from-port port (lambda () @@ -92,33 +91,7 @@ but prefix argument means prompt for different environment." message)))))))))))) (define (initialize-inferior-repls!) - (set! interface-ports '()) unspecific) - -(define (register-interface-port! port) - (set! interface-ports - (system-pair-cons (ucode-type weak-cons) port interface-ports)) - unspecific) - -(define (accept-inferior-repl-output/unsafe) - (let loop ((ports interface-ports) (prev false) (output? false)) - (if (null? ports) - output? - (let ((port (system-pair-car ports)) - (next (system-pair-cdr ports))) - (cond ((not port) - (if prev - (system-pair-set-cdr! prev next) - (set! interface-ports next)) - (loop next prev output?)) - ((or (not (null? (port/output-strings port))) - (not (queue-empty? (port/output-queue port)))) - (process-output-queue port) - (loop next ports true)) - (else - (loop next ports output?))))))) - -(define interface-ports) (define (wait-for-input port level mode) (enqueue-output-operation! port @@ -408,15 +381,21 @@ If this is an error, the debugger examines the error condition." ;;;; Interface Port (define (make-interface-port buffer thread) - (port/copy interface-port-template - (make-interface-port-state - thread - (mark-left-inserting-copy (buffer-end buffer)) - (make-ring (ref-variable comint-input-ring-size)) - (make-queue) - false - (make-queue) - '()))) + (letrec + ((port + (port/copy interface-port-template + (make-interface-port-state + thread + (mark-left-inserting-copy (buffer-end buffer)) + (make-ring (ref-variable comint-input-ring-size)) + (make-queue) + false + (make-queue) + '() + (register-inferior-thread! + thread + (lambda () (process-output-queue port))))))) + port)) (define-structure (interface-port-state (conc-name interface-port-state/)) (thread false read-only true) @@ -425,7 +404,8 @@ If this is an error, the debugger examines the error condition." (expression-queue false read-only true) command-char (output-queue false read-only true) - output-strings) + output-strings + (output-registration false read-only true)) (define-integrable (port/thread port) (interface-port-state/thread (port/state port))) @@ -456,6 +436,9 @@ If this is an error, the debugger examines the error condition." (define-integrable (set-port/output-strings! port strings) (set-interface-port-state/output-strings! (port/state port) strings)) + +(define-integrable (port/output-registration port) + (interface-port-state/output-registration (port/state port))) ;;; Output operations @@ -478,7 +461,7 @@ If this is an error, the debugger examines the error condition." (define (enqueue-output-string! port string) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) (set-port/output-strings! port (cons string (port/output-strings port))) - (set! inferior-thread-changes? true) + (inferior-thread-output!/unsafe (port/output-registration port)) (set-interrupt-enables! interrupt-mask))) (define (enqueue-output-operation! port operator) @@ -493,7 +476,7 @@ If this is an error, the debugger examines the error condition." (lambda (mark) (region-insert-string! mark string))))))) (enqueue!/unsafe (port/output-queue port) operator) - (set! inferior-thread-changes? true) + (inferior-thread-output!/unsafe (port/output-registration port)) (set-interrupt-enables! interrupt-mask))) (define (process-output-queue port) @@ -512,7 +495,8 @@ If this is an error, the debugger examines the error condition." (do ((strings (reverse! strings) (cdr strings))) ((null? strings)) (region-insert-string! mark (car strings)))))) - (set-interrupt-enables! interrupt-mask))) + (set-interrupt-enables! interrupt-mask)) + true) ;;; Input operations