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 d8fb964ad60f6089e493efe36afc4909a6a223c9..e044656a3af73996e2164c1a4326f475e671a57e 100644 (file)
--- 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 ca69115f677832eb40927cff0e489a0d2f349f54..ad80e61d6c5a99cac6a8591de1c749c4de72e255 100644 (file)
--- 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 0864c2f569eca7d1813ebbd694f4e77ecc8b2277..2186df686dee8208c6a6ec07cac57d24d358bf23 100644 (file)
--- 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)
 \f
 (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)))
 \f
 ;;; 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