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")