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 0eceb57642b99addb86eab68e22f6c0104ddbd9f..6f6857fadf30a2a073bf7799f033817b27bbdc76 100644 (file)
--- 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 7b550d9f4c781ef87ef392526f6eecfe9b49245f..5fa2e5c9fedd5cb8eaacf32ab882821ea7c47f17 100644 (file)
--- 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 260ad72497bf58c9941ad42c0c3cd800e562db66..2d60e6ad0cfc29b60ebed9eaae94cde130541567 100644 (file)
--- 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 c93e503f895f8c5591fc772230320d83a58016db..17a4521c3a0a7802d406c01d6bfdef86191d9567 100644 (file)
--- 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")