From 4b5b800df4a70efe8f5c883f0b8c1ad9f3698eb0 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 11 Aug 2014 14:45:55 -0700 Subject: [PATCH] Fluidize (runtime port) internal variables *current-output-port*,... *current-input-port*, *notification-output-port*, *trace-output-port*, and *interaction-i/o-port*. --- src/runtime/make.scm | 1 + src/runtime/port.scm | 74 +++++++++++++++++++++++------------------ src/runtime/rep.scm | 68 +++++++++++++++++++------------------ src/runtime/runtime.pkg | 3 +- 4 files changed, 79 insertions(+), 67 deletions(-) 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") -- 2.25.1