From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 11 Aug 2014 21:45:55 +0000 (-0700)
Subject: Fluidize (runtime port) internal variables *current-output-port*,...
X-Git-Tag: mit-scheme-pucked-9.2.12~402^2~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4b5b800df4a70efe8f5c883f0b8c1ad9f3698eb0;p=mit-scheme.git

Fluidize (runtime port) internal variables *current-output-port*,...

*current-input-port*, *notification-output-port*, *trace-output-port*,
and *interaction-i/o-port*.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 0eceb5764..6f6857fad 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -480,6 +480,7 @@ USA.
    ;; Threads
    (RUNTIME THREAD)
    ;; I/O
+   (RUNTIME PORT)
    (RUNTIME OUTPUT-PORT)
    (RUNTIME GENERIC-I/O-PORT)
    (RUNTIME FILE-I/O-PORT)
diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 7b550d9f4..5fa2e5c9f 100644
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -787,74 +787,82 @@ USA.
 
 (define *current-input-port*)
 (define *current-output-port*)
-(define *notification-output-port* #f)
-(define *trace-output-port* #f)
-(define *interaction-i/o-port* #f)
+(define *notification-output-port*)
+(define *trace-output-port*)
+(define *interaction-i/o-port*)
+
+(define (initialize-package!)
+  (set! *current-input-port* (make-fluid #f))
+  (set! *current-output-port* (make-fluid #f))
+  (set! *notification-output-port* (make-fluid #f))
+  (set! *trace-output-port* (make-fluid #f))
+  (set! *interaction-i/o-port* (make-fluid #f)))
 
 (define (current-input-port)
-  (or *current-input-port* (nearest-cmdl/port)))
+  (or (fluid *current-input-port*) (nearest-cmdl/port)))
 
 (define (set-current-input-port! port)
-  (set! *current-input-port*
-	(guarantee-input-port port 'SET-CURRENT-INPUT-PORT!))
+  (set-fluid! *current-input-port*
+	      (guarantee-input-port port 'SET-CURRENT-INPUT-PORT!))
   unspecific)
 
 (define (with-input-from-port port thunk)
-  (fluid-let ((*current-input-port*
-	       (guarantee-input-port port 'WITH-INPUT-FROM-PORT)))
-    (thunk)))
+  (let-fluid
+   *current-input-port* (guarantee-input-port port 'WITH-INPUT-FROM-PORT)
+   thunk))
 
 (define (current-output-port)
-  (or *current-output-port* (nearest-cmdl/port)))
+  (or (fluid *current-output-port*) (nearest-cmdl/port)))
 
 (define (set-current-output-port! port)
-  (set! *current-output-port*
-	(guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!))
+  (set-fluid! *current-output-port*
+	      (guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!))
   unspecific)
 
 (define (with-output-to-port port thunk)
-  (fluid-let ((*current-output-port*
-	       (guarantee-output-port port 'WITH-OUTPUT-TO-PORT)))
-    (thunk)))
+  (let-fluid
+   *current-output-port* (guarantee-output-port port 'WITH-OUTPUT-TO-PORT)
+   thunk))
 
 (define (notification-output-port)
-  (or *notification-output-port* (nearest-cmdl/port)))
+  (or (fluid *notification-output-port*) (nearest-cmdl/port)))
 
 (define (set-notification-output-port! port)
-  (set! *notification-output-port*
-	(guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!))
+  (set-fluid! *notification-output-port*
+	      (guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!))
   unspecific)
 
 (define (with-notification-output-port port thunk)
-  (fluid-let ((*notification-output-port*
-	       (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT)))
-    (thunk)))
+  (let-fluid
+   *notification-output-port*
+   (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT)
+   thunk))
 
 (define (trace-output-port)
-  (or *trace-output-port* (nearest-cmdl/port)))
+  (or (fluid *trace-output-port*) (nearest-cmdl/port)))
 
 (define (set-trace-output-port! port)
-  (set! *trace-output-port*
-	(guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!))
+  (set-fluid! *trace-output-port*
+	      (guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!))
   unspecific)
 
 (define (with-trace-output-port port thunk)
-  (fluid-let ((*trace-output-port*
-	       (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT)))
-    (thunk)))
+  (let-fluid
+   *trace-output-port* (guarantee-output-port port 'WITH-TRACE-OUTPUT-PORT)
+   thunk))
 
 (define (interaction-i/o-port)
-  (or *interaction-i/o-port* (nearest-cmdl/port)))
+  (or (fluid *interaction-i/o-port*) (nearest-cmdl/port)))
 
 (define (set-interaction-i/o-port! port)
-  (set! *interaction-i/o-port*
-	(guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!))
+  (set-fluid! *interaction-i/o-port*
+	      (guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!))
   unspecific)
 
 (define (with-interaction-i/o-port port thunk)
-  (fluid-let ((*interaction-i/o-port*
-	       (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT)))
-    (thunk)))
+  (let-fluid
+   *interaction-i/o-port* (guarantee-i/o-port port 'WITH-INTERACTION-I/O-PORT)
+   thunk))
 
 (define standard-port-accessors
   (list (cons current-input-port set-current-input-port!)
diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 260ad7249..2d60e6ad0 100644
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -115,39 +115,41 @@ USA.
   (let ((port (cmdl/port cmdl)))
     (let ((thunk
 	   (lambda ()
-	     (fluid-let ((*nearest-cmdl* cmdl)
-			 (dynamic-handler-frames '())
-			 (*bound-restarts*
-			  (if (cmdl/parent cmdl) *bound-restarts* '()))
-			 (standard-error-hook #f)
-			 (standard-warning-hook #f)
-			 (standard-breakpoint-hook #f)
-			 (*working-directory-pathname*
-			  *working-directory-pathname*)
-			 (*default-pathname-defaults*
-			  *default-pathname-defaults*)
-			 (*current-input-port* #f)
-			 (*current-output-port* #f)
-			 (*notification-output-port* #f)
-			 (*trace-output-port* #f)
-			 (*interaction-i/o-port* #f))
-	       (let loop ((message message))
-		 (loop
-		  (bind-abort-restart cmdl
-		    (lambda ()
-		      (deregister-all-events)
-		      (with-interrupt-mask interrupt-mask/all
-			(lambda (interrupt-mask)
-			  interrupt-mask
-			  (unblock-thread-events)
-			  (ignore-errors
-			   (lambda ()
-			     ((->cmdl-message message) cmdl)))
-			  (call-with-current-continuation
-			   (lambda (continuation)
-			     (with-create-thread-continuation continuation
-			       (lambda ()
-				 ((cmdl/driver cmdl) cmdl))))))))))))))
+	     (let-fluids
+	      *current-input-port* #f
+	      *current-output-port* #f
+	      *notification-output-port* #f
+	      *trace-output-port* #f
+	      *interaction-i/o-port* #f
+	      (lambda ()
+		(fluid-let ((*nearest-cmdl* cmdl)
+			    (dynamic-handler-frames '())
+			    (*bound-restarts*
+			     (if (cmdl/parent cmdl) *bound-restarts* '()))
+			    (standard-error-hook #f)
+			    (standard-warning-hook #f)
+			    (standard-breakpoint-hook #f)
+			    (*working-directory-pathname*
+			     *working-directory-pathname*)
+			    (*default-pathname-defaults*
+			     *default-pathname-defaults*))
+		  (let loop ((message message))
+		    (loop
+		     (bind-abort-restart cmdl
+		       (lambda ()
+			 (deregister-all-events)
+			 (with-interrupt-mask interrupt-mask/all
+			   (lambda (interrupt-mask)
+			     interrupt-mask
+			     (unblock-thread-events)
+			     (ignore-errors
+			      (lambda ()
+				((->cmdl-message message) cmdl)))
+			     (call-with-current-continuation
+			      (lambda (continuation)
+				(with-create-thread-continuation continuation
+				  (lambda ()
+				    ((cmdl/driver cmdl) cmdl))))))))))))))))
 	  (mutex (port/thread-mutex port)))
       (let ((thread (current-thread))
 	    (owner (thread-mutex-owner mutex)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c93e503f8..17a4521c3 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2345,7 +2345,8 @@ USA.
   (export (runtime emacs-interface)
 	  set-port/thread-mutex!
 	  set-port/type!
-	  standard-port-accessors))
+	  standard-port-accessors)
+  (initialization (initialize-package!)))
 
 (define-package (runtime input-port)
   (files "input")