From 23674f803f776f6c7f27a370064f3c3c64256897 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 28 Feb 2016 01:47:15 -0800 Subject: [PATCH] Change standard ports to *be* parameters. This is the use case that parameters were designed for, so we might as well take advantage of it. --- src/runtime/port.scm | 113 ++++++++++++++++------------------------ src/runtime/rep.scm | 10 ++-- src/runtime/runtime.pkg | 9 +--- 3 files changed, 51 insertions(+), 81 deletions(-) diff --git a/src/runtime/port.scm b/src/runtime/port.scm index 2b61ad00d..853a5ca0b 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -65,10 +65,13 @@ USA. state type))) -(define (guarantee-port-type object procedure) +(define (guarantee-port-type object #!optional caller) (if (not (port-type? object)) - (error:wrong-type-argument object "port type" procedure)) + (error:not-port-type object caller)) object) + +(define (error:not-port-type object #!optional caller) + (error:wrong-type-argument object "port type" caller)) (define-integrable (port-type/supports-input? type) (port-type/read-char type)) @@ -629,36 +632,36 @@ USA. (port-type/supports-output? type) #t)))) -(define-integrable (guarantee-port port caller) +(define (guarantee-port port #!optional caller) (if (not (port? port)) (error:not-port port caller)) port) -(define (error:not-port port caller) +(define (error:not-port port #!optional caller) (error:wrong-type-argument port "port" caller)) -(define-integrable (guarantee-input-port port caller) +(define (guarantee-input-port port #!optional caller) (if (not (input-port? port)) (error:not-input-port port caller)) port) -(define (error:not-input-port port caller) +(define (error:not-input-port port #!optional caller) (error:wrong-type-argument port "input port" caller)) -(define-integrable (guarantee-output-port port caller) +(define (guarantee-output-port port #!optional caller) (if (not (output-port? port)) (error:not-output-port port caller)) port) -(define (error:not-output-port port caller) +(define (error:not-output-port port #!optional caller) (error:wrong-type-argument port "output port" caller)) -(define-integrable (guarantee-i/o-port port caller) +(define (guarantee-i/o-port port #!optional caller) (if (not (i/o-port? port)) (error:not-i/o-port port caller)) port) -(define (error:not-i/o-port port caller) +(define (error:not-i/o-port port #!optional caller) (error:wrong-type-argument port "I/O port" caller)) (define (port/supports-coding? port) @@ -785,86 +788,60 @@ USA. ;;;; Standard Ports -(define *current-input-port*) -(define *current-output-port*) -(define *notification-output-port*) -(define *trace-output-port*) -(define *interaction-i/o-port*) +(define current-input-port) +(define current-output-port) +(define notification-output-port) +(define trace-output-port) +(define interaction-i/o-port) (define (initialize-package!) - (set! *current-input-port* (make-parameter #f)) - (set! *current-output-port* (make-parameter #f)) - (set! *notification-output-port* (make-parameter #f)) - (set! *trace-output-port* (make-parameter #f)) - (set! *interaction-i/o-port* (make-parameter #f))) + (set! current-input-port (make-port-parameter guarantee-input-port)) + (set! current-output-port (make-port-parameter guarantee-output-port)) + (set! notification-output-port (make-port-parameter guarantee-output-port)) + (set! trace-output-port (make-port-parameter guarantee-output-port)) + (set! interaction-i/o-port (make-port-parameter guarantee-i/o-port)) + unspecific) -(define (current-input-port) - (or (*current-input-port*) (nearest-cmdl/port))) +(define (make-port-parameter guarantee) + (make-general-parameter #f + (lambda (port) + (if port (guarantee port)) + port) + (lambda (port) + (or port (nearest-cmdl/port))) + default-parameter-setter)) (define (set-current-input-port! port) - (*current-input-port* (guarantee-input-port port 'SET-CURRENT-INPUT-PORT!)) - unspecific) + (current-input-port port)) (define (with-input-from-port port thunk) - (parameterize* (list (cons *current-input-port* - (guarantee-input-port port 'WITH-INPUT-FROM-PORT))) + (parameterize* (list (cons current-input-port port)) thunk)) -(define (current-output-port) - (or (*current-output-port*) (nearest-cmdl/port))) - (define (set-current-output-port! port) - (*current-output-port* (guarantee-output-port port 'SET-CURRENT-OUTPUT-PORT!)) - unspecific) + (current-output-port port)) (define (with-output-to-port port thunk) - (parameterize* (list (cons *current-output-port* - (guarantee-output-port port 'WITH-OUTPUT-TO-PORT))) + (parameterize* (list (cons current-output-port port)) thunk)) -(define (notification-output-port) - (or (*notification-output-port*) (nearest-cmdl/port))) - (define (set-notification-output-port! port) - (*notification-output-port* - (guarantee-output-port port 'SET-NOTIFICATION-OUTPUT-PORT!)) - unspecific) + (notification-output-port port)) (define (with-notification-output-port port thunk) - (parameterize* - (list (cons *notification-output-port* - (guarantee-output-port port 'WITH-NOTIFICATION-OUTPUT-PORT))) - thunk)) - -(define (trace-output-port) - (or (*trace-output-port*) (nearest-cmdl/port))) + (parameterize* (list (cons notification-output-port port)) + thunk)) (define (set-trace-output-port! port) - (*trace-output-port* (guarantee-output-port port 'SET-TRACE-OUTPUT-PORT!)) - unspecific) + (trace-output-port port)) (define (with-trace-output-port port thunk) - (parameterize* - (list (cons *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))) + (parameterize* (list (cons trace-output-port port)) + thunk)) (define (set-interaction-i/o-port! port) - (*interaction-i/o-port* (guarantee-i/o-port port 'SET-INTERACTION-I/O-PORT!)) - unspecific) + (interaction-i/o-port port)) (define (with-interaction-i/o-port port thunk) - (parameterize* - (list (cons *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!) - (cons current-output-port set-current-output-port!) - (cons notification-output-port set-notification-output-port!) - (cons trace-output-port set-trace-output-port!) - (cons interaction-i/o-port set-interaction-i/o-port!))) \ No newline at end of file + (parameterize* (list (cons interaction-i/o-port port)) + thunk)) \ No newline at end of file diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index d70e5cb6c..1a1862040 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -116,11 +116,11 @@ USA. (let ((thunk (lambda () (parameterize* - (list (cons *current-input-port* #f) - (cons *current-output-port* #f) - (cons *notification-output-port* #f) - (cons *trace-output-port* #f) - (cons *interaction-i/o-port* #f) + (list (cons current-input-port #f) + (cons current-output-port #f) + (cons notification-output-port #f) + (cons trace-output-port #f) + (cons interaction-i/o-port #f) (cons working-directory-pathname (working-directory-pathname)) (cons param:nearest-cmdl cmdl) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e428c7167..ff2e2b08a 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2397,16 +2397,9 @@ USA. (export (runtime transcript) port/transcript set-port/transcript!) - (export (runtime rep) - *current-input-port* - *current-output-port* - *interaction-i/o-port* - *notification-output-port* - *trace-output-port*) (export (runtime emacs-interface) set-port/thread-mutex! - set-port/type! - standard-port-accessors) + set-port/type!) (initialization (initialize-package!))) (define-package (runtime input-port) -- 2.25.1