From 1c3590885fe1073df467ae00e6a174f26a995b96 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 11 Jan 2017 15:08:43 -0800 Subject: [PATCH] Change port-mode operations to work for all channel ports. Also eliminate old names for these operations. --- src/runtime/genio.scm | 72 +------------ src/runtime/input.scm | 6 +- src/runtime/parser-buffer.scm | 2 +- src/runtime/port.scm | 187 ++++++++++++++++++++-------------- src/runtime/rep.scm | 6 +- src/runtime/runtime.pkg | 12 --- src/runtime/syncproc.scm | 11 +- src/runtime/usrint.scm | 36 +++---- 8 files changed, 144 insertions(+), 188 deletions(-) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index dab58a15e..60213f456 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -130,11 +130,7 @@ USA. (READ-SUBSTRING ,generic-io/read-substring) (UNREAD-CHAR ,generic-io/unread-char))) (ops:in2 - `((INPUT-BLOCKING-MODE ,generic-io/input-blocking-mode) - (INPUT-CHANNEL ,generic-io/input-channel) - (INPUT-TERMINAL-MODE ,generic-io/input-terminal-mode) - (SET-INPUT-BLOCKING-MODE ,generic-io/set-input-blocking-mode) - (SET-INPUT-TERMINAL-MODE ,generic-io/set-input-terminal-mode))) + `((INPUT-CHANNEL ,generic-io/input-channel))) (ops:out1 `((BUFFERED-OUTPUT-BYTES ,generic-io/buffered-output-bytes) (BYTES-WRITTEN ,generic-io/bytes-written) @@ -145,11 +141,7 @@ USA. (WRITE-CHAR ,generic-io/write-char) (WRITE-SUBSTRING ,generic-io/write-substring))) (ops:out2 - `((OUTPUT-BLOCKING-MODE ,generic-io/output-blocking-mode) - (OUTPUT-CHANNEL ,generic-io/output-channel) - (OUTPUT-TERMINAL-MODE ,generic-io/output-terminal-mode) - (SET-OUTPUT-BLOCKING-MODE ,generic-io/set-output-blocking-mode) - (SET-OUTPUT-TERMINAL-MODE ,generic-io/set-output-terminal-mode) + `((OUTPUT-CHANNEL ,generic-io/output-channel) (SYNCHRONIZE-OUTPUT ,generic-io/synchronize-output))) (other-operations `((CLOSE ,generic-io/close) @@ -231,7 +223,7 @@ USA. (define (generic-io/read-substring port string start end) (read-substring (port-input-buffer port) string start end)) - + (define (generic-io/input-line port) (input-buffer-line (port-input-buffer port))) @@ -243,35 +235,6 @@ USA. (if (not ib) (error:bad-range-argument port #f)) (input-buffer-channel ib))) - -(define (generic-io/input-blocking-mode port) - (let ((channel (generic-io/input-channel port))) - (if channel - (if (channel-blocking? channel) 'BLOCKING 'NONBLOCKING) - #f))) - -(define (generic-io/set-input-blocking-mode port mode) - (let ((channel (generic-io/input-channel port))) - (if channel - (case mode - ((BLOCKING) (channel-blocking channel)) - ((NONBLOCKING) (channel-nonblocking channel)) - (else (error:wrong-type-datum mode "blocking mode")))))) - -(define (generic-io/input-terminal-mode port) - (let ((channel (generic-io/input-channel port))) - (if (and channel (channel-type=terminal? channel)) - (if (terminal-cooked-input? channel) 'COOKED 'RAW) - #f))) - -(define (generic-io/set-input-terminal-mode port mode) - (let ((channel (generic-io/input-channel port))) - (if (and channel (channel-type=terminal? channel)) - (case mode - ((COOKED) (terminal-cooked-input channel)) - ((RAW) (terminal-raw-input channel)) - ((#F) unspecific) - (else (error:wrong-type-datum mode "terminal mode")))))) ;;;; Output operations @@ -300,35 +263,6 @@ USA. (error:bad-range-argument port #f)) (output-buffer-channel ob))) -(define (generic-io/output-blocking-mode port) - (let ((channel (generic-io/output-channel port))) - (if channel - (if (channel-blocking? channel) 'BLOCKING 'NONBLOCKING) - #f))) - -(define (generic-io/set-output-blocking-mode port mode) - (let ((channel (generic-io/output-channel port))) - (if channel - (case mode - ((BLOCKING) (channel-blocking channel)) - ((NONBLOCKING) (channel-nonblocking channel)) - (else (error:wrong-type-datum mode "blocking mode")))))) - -(define (generic-io/output-terminal-mode port) - (let ((channel (generic-io/output-channel port))) - (if (and channel (channel-type=terminal? channel)) - (if (terminal-cooked-output? channel) 'COOKED 'RAW) - #f))) - -(define (generic-io/set-output-terminal-mode port mode) - (let ((channel (generic-io/output-channel port))) - (if (and channel (channel-type=terminal? channel)) - (case mode - ((COOKED) (terminal-cooked-output channel)) - ((RAW) (terminal-raw-output channel)) - ((#F) unspecific) - (else (error:wrong-type-datum mode "terminal mode")))))) - (define (generic-io/synchronize-output port) (let ((channel (generic-io/output-channel port))) (if channel diff --git a/src/runtime/input.scm b/src/runtime/input.scm index ad7f795b4..8de16f526 100644 --- a/src/runtime/input.scm +++ b/src/runtime/input.scm @@ -53,7 +53,7 @@ USA. 0)) (define (input-port/read-line port) - (port/with-input-blocking-mode port 'BLOCKING + (with-input-port-blocking-mode port 'BLOCKING (lambda () (let ((read-char (textual-port-operation/read-char port))) (let loop ((a (make-accum 128))) @@ -66,7 +66,7 @@ USA. (else (loop (accum char a)))))))))) (define (input-port/read-string port delimiters) - (port/with-input-blocking-mode port 'BLOCKING + (with-input-port-blocking-mode port 'BLOCKING (lambda () (let ((read-char (textual-port-operation/read-char port))) (let loop ((a (make-accum 128))) @@ -82,7 +82,7 @@ USA. (loop (accum char a)))))))))) (define (input-port/discard-chars port delimiters) - (port/with-input-blocking-mode port 'BLOCKING + (with-input-port-blocking-mode port 'BLOCKING (lambda () (let ((read-char (textual-port-operation/read-char port))) (let loop () diff --git a/src/runtime/parser-buffer.scm b/src/runtime/parser-buffer.scm index f2d50e78c..70b76a1d3 100644 --- a/src/runtime/parser-buffer.scm +++ b/src/runtime/parser-buffer.scm @@ -412,7 +412,7 @@ USA. (%grow-buffer string end min-end)))) (let ((port (parser-buffer-port buffer)) (string (parser-buffer-string buffer))) - (port/with-input-blocking-mode port 'BLOCKING + (with-input-port-blocking-mode port 'BLOCKING (lambda () (let loop ((end end)) (if (< end min-end) diff --git a/src/runtime/port.scm b/src/runtime/port.scm index 95155ce28..5569473f8 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -591,82 +591,6 @@ USA. (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDINGS)) port)) -;;;; Special Operations - -(define (input-port-blocking-mode port) - (let ((operation (textual-port-operation port 'INPUT-BLOCKING-MODE))) - (if operation - (operation port) - #f))) - -(define (set-input-port-blocking-mode! port mode) - (let ((operation (textual-port-operation port 'SET-INPUT-BLOCKING-MODE))) - (if operation - (operation port mode)))) - -(define (with-input-port-blocking-mode port mode thunk) - (bind-mode port 'INPUT-BLOCKING-MODE 'SET-INPUT-BLOCKING-MODE mode thunk)) - -(define (output-port-blocking-mode port) - (let ((operation (textual-port-operation port 'OUTPUT-BLOCKING-MODE))) - (if operation - (operation port) - #f))) - -(define (set-output-port-blocking-mode! port mode) - (let ((operation (textual-port-operation port 'SET-OUTPUT-BLOCKING-MODE))) - (if operation - (operation port mode)))) - -(define (with-output-port-blocking-mode port mode thunk) - (bind-mode port 'OUTPUT-BLOCKING-MODE 'SET-OUTPUT-BLOCKING-MODE mode thunk)) - -(define (input-port-terminal-mode port) - (let ((operation (textual-port-operation port 'INPUT-TERMINAL-MODE))) - (if operation - (operation port) - #f))) - -(define (set-input-port-terminal-mode! port mode) - (let ((operation (textual-port-operation port 'SET-INPUT-TERMINAL-MODE))) - (if operation - (operation port mode)))) - -(define (with-input-port-terminal-mode port mode thunk) - (bind-mode port 'INPUT-TERMINAL-MODE 'SET-INPUT-TERMINAL-MODE mode thunk)) - -(define (output-port-terminal-mode port) - (let ((operation (textual-port-operation port 'OUTPUT-TERMINAL-MODE))) - (if operation - (operation port) - #f))) - -(define (set-output-port-terminal-mode! port mode) - (let ((operation (textual-port-operation port 'SET-OUTPUT-TERMINAL-MODE))) - (if operation - (operation port mode)))) - -(define (with-output-port-terminal-mode port mode thunk) - (bind-mode port 'OUTPUT-TERMINAL-MODE 'SET-OUTPUT-TERMINAL-MODE mode thunk)) - -(define (bind-mode port read-mode write-mode mode thunk) - (let ((read-mode (textual-port-operation port read-mode)) - (write-mode (textual-port-operation port write-mode))) - (if (and read-mode write-mode (read-mode port)) - (let ((outside-mode)) - (dynamic-wind (lambda () - (if (textual-port-open? port) - (begin - (set! outside-mode (read-mode port)) - (write-mode port mode)))) - thunk - (lambda () - (if (textual-port-open? port) - (begin - (set! mode (read-mode port)) - (write-mode port outside-mode)))))) - (thunk)))) - ;;;; Generic ports (define port?) @@ -721,6 +645,117 @@ USA. ((textual-output-port? port) (textual-output-port-channel port)) (else (error:not-a output-port? port 'output-port-channel)))) +;;;; Port modes + +(define (input-port-blocking-mode port) + (channel-blocking-mode (input-port-channel port))) + +(define (set-input-port-blocking-mode! port mode) + (guarantee blocking-mode? mode 'set-input-port-blocking-mode!) + (set-channel-blocking-mode! (input-port-channel port) mode)) + +(define (with-input-port-blocking-mode port mode thunk) + (guarantee blocking-mode? mode 'with-input-port-blocking-mode) + (with-channel-blocking-mode (input-port-channel port) mode thunk)) + +(define (output-port-blocking-mode port) + (channel-blocking-mode (output-port-channel port))) + +(define (set-output-port-blocking-mode! port mode) + (guarantee blocking-mode? mode 'set-output-port-blocking-mode!) + (set-channel-blocking-mode! (output-port-channel port) mode)) + +(define (with-output-port-blocking-mode port mode thunk) + (guarantee blocking-mode? mode 'with-output-port-blocking-mode) + (with-channel-blocking-mode (output-port-channel port) mode thunk)) + +(define (input-port-terminal-mode port) + (channel-terminal-mode (input-port-channel port))) + +(define (set-input-port-terminal-mode! port mode) + (guarantee terminal-mode? mode 'set-input-port-terminal-mode!) + (set-channel-terminal-mode! (input-port-channel port) mode)) + +(define (with-input-port-terminal-mode port mode thunk) + (guarantee terminal-mode? mode 'with-input-port-terminal-mode) + (with-channel-terminal-mode (input-port-channel port) mode thunk)) + +(define (output-port-terminal-mode port) + (channel-terminal-mode (output-port-channel port))) + +(define (set-output-port-terminal-mode! port mode) + (guarantee terminal-mode? mode 'set-output-port-terminal-mode!) + (set-channel-terminal-mode! (output-port-channel port) mode)) + +(define (with-output-port-terminal-mode port mode thunk) + (guarantee terminal-mode? mode 'with-output-port-terminal-mode) + (with-channel-terminal-mode (output-port-channel port) mode thunk)) + +(define (blocking-mode? object) + (or (eq? 'blocking object) + (eq? 'nonblocking object))) + +(define (channel-blocking-mode channel) + (if channel + (if (channel-blocking? channel) 'blocking 'nonblocking) + #f)) + +(define (set-channel-blocking-mode! channel mode) + (if channel + (if (eq? 'blocking mode) + (channel-blocking channel) + (channel-nonblocking channel)))) + +(define (channel-mode-binder bind? mode? get-mode set-mode!) + (lambda (channel mode thunk) + (if (bind? channel) + (let ((outside-mode)) + (dynamic-wind (lambda () + (if (channel-open? channel) + (begin + (set! outside-mode (get-mode channel)) + (set-mode! channel mode)))) + thunk + (lambda () + (if (channel-open? channel) + (begin + (set! mode (get-mode channel)) + (set-mode! channel outside-mode)))))) + (thunk)))) + +(define with-channel-blocking-mode + (channel-mode-binder (lambda (channel) channel) + blocking-mode? + channel-blocking-mode + set-channel-blocking-mode!)) + +(define (terminal-mode? object) + (or (eq? 'cooked object) + (eq? 'raw object))) + +(define (channel-terminal-mode channel) + (if (and channel (channel-type=terminal? channel)) + (if (terminal-cooked-input? channel) 'cooked 'raw) + #f)) + +(define (set-channel-terminal-mode! channel mode) + (if (and channel (channel-type=terminal? channel)) + (if (eq? 'cooked mode) + (terminal-cooked-input channel) + (terminal-raw-input channel)))) + +(define with-channel-terminal-mode + (channel-mode-binder (lambda (channel) + (and channel (channel-type=terminal? channel))) + terminal-mode? + channel-terminal-mode + set-channel-terminal-mode!)) + +(add-boot-init! + (lambda () + (register-predicate! blocking-mode? 'blocking-mode) + (register-predicate! terminal-mode? 'terminal-mode))) + ;;;; Standard Ports (define current-input-port) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 9bb98fe77..6f6eb6608 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -280,7 +280,7 @@ USA. (define ((cmdl-message/strings . strings) cmdl) (let ((port (cmdl/port cmdl))) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (for-each (lambda (string) (fresh-line port) @@ -290,7 +290,7 @@ USA. (define ((cmdl-message/active actor) cmdl) (let ((port (cmdl/port cmdl))) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (actor port))))) @@ -569,7 +569,7 @@ USA. (define hook/set-default-environment) (define (default/set-default-environment port environment) (let ((port (cmdl/port port))) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (if (not (interpreter-environment? environment)) (begin diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index bf746950b..f32ebc0bd 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2473,22 +2473,10 @@ USA. (parent (runtime)) (export () ;; BEGIN legacy bindings - (port/input-blocking-mode input-port-blocking-mode) - (port/input-terminal-mode input-port-terminal-mode) (port/open? textual-port-open?) (port/operation textual-port-operation) (port/operation-names textual-port-operation-names) - (port/output-blocking-mode output-port-blocking-mode) - (port/output-terminal-mode output-port-terminal-mode) - (port/set-input-blocking-mode set-input-port-blocking-mode!) - (port/set-input-terminal-mode set-input-port-terminal-mode!) - (port/set-output-blocking-mode set-output-port-blocking-mode!) - (port/set-output-terminal-mode set-output-port-terminal-mode!) (port/type textual-port-type) - (port/with-input-blocking-mode with-input-port-blocking-mode) - (port/with-input-terminal-mode with-input-port-terminal-mode) - (port/with-output-blocking-mode with-output-port-blocking-mode) - (port/with-output-terminal-mode with-output-port-terminal-mode) ;; END legacy bindings close-input-port close-output-port diff --git a/src/runtime/syncproc.scm b/src/runtime/syncproc.scm index 2f5a90f90..34290ab33 100644 --- a/src/runtime/syncproc.scm +++ b/src/runtime/syncproc.scm @@ -197,12 +197,11 @@ USA. (handle-broken-pipe process (lambda () (if nonblock? - ((port/operation port 'SET-OUTPUT-BLOCKING-MODE) - port 'NONBLOCKING)) + (set-output-port-blocking-mode! port 'nonblocking)) (receiver (let ((buffer (make-wide-string bsize))) (lambda () - (port/with-input-blocking-mode process-input 'BLOCKING + (with-input-port-blocking-mode process-input 'BLOCKING (lambda () (let ((n (input-port/read-string! process-input buffer))) @@ -242,17 +241,17 @@ USA. (lambda () (let ((n (input-port/read-string! port buffer))) (if (and n (fix:> n 0)) - (port/with-output-blocking-mode process-output + (with-output-port-blocking-mode process-output 'BLOCKING (lambda () (output-port/write-substring process-output buffer 0 n)))) n)))) - (if nonblock? (port/set-input-blocking-mode port 'NONBLOCKING)) + (if nonblock? (set-input-port-blocking-mode! port 'NONBLOCKING)) (let ((status (receiver copy-output))) (if (and nonblock? (input-port/open? port)) (begin - (port/set-input-blocking-mode port 'BLOCKING) + (set-input-port-blocking-mode! port 'BLOCKING) (do () ((not (fix:> (copy-output) 0)))) (input-port/close port))) status))) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index e588cd9d8..b5dbef379 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -43,7 +43,7 @@ USA. (begin (guarantee-i/o-port port 'PROMPT-FOR-COMMAND-EXPRESSION) (write-command-prompt port prompt level) - (port/with-input-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'COOKED (lambda () (read port environment)))))))) @@ -72,13 +72,13 @@ USA. (operation port environment prompt) (begin (guarantee-i/o-port port caller) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port) (newline port) (write-string prompt port) (flush-output port))) - (port/with-input-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'COOKED (lambda () (read port environment)))))))) @@ -109,12 +109,12 @@ USA. (write-command-prompt port prompt level) (let loop () (let ((char - (port/with-input-terminal-mode port 'RAW + (with-input-port-terminal-mode port 'RAW (lambda () (read-char port))))) (if (char-graphic? char) (begin - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (write-char char port) (flush-output port))) @@ -130,28 +130,28 @@ USA. (default/prompt-for-confirmation port prompt))))) (define (default/prompt-for-confirmation port prompt) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port))) (let loop () - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (newline port) (write-string prompt port) (flush-output port))) (let ((char - (port/with-input-terminal-mode port 'RAW + (with-input-port-terminal-mode port 'RAW (lambda () (read-char port))))) (case char ((#\y #\Y #\space) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (write-string "Yes" port) (flush-output port))) true) ((#\n #\N #\rubout) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (write-string "No" port) (flush-output port))) @@ -159,7 +159,7 @@ USA. ((#\newline) (loop)) (else - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (write char port) (beep port) @@ -175,13 +175,13 @@ USA. (default/prompt-for-string port prompt))))) (define (default/prompt-for-string port prompt) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port) (newline port) (write-string prompt port) (flush-output port))) - (port/with-input-terminal-mode port 'COOKED + (with-input-port-terminal-mode port 'COOKED (lambda () (read-line port)))) @@ -239,7 +239,7 @@ USA. (set! outside))))))) (guarantee-i/o-port port 'default/call-with-pass-phrase) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port) (newline port) @@ -248,7 +248,7 @@ USA. (let loop ((input "")) (let ((char (with-binary-line-ending (lambda () - (port/with-input-terminal-mode port 'RAW + (with-input-port-terminal-mode port 'RAW (lambda () (read-char port))))))) (cond ((or (eof-object? char) @@ -257,7 +257,7 @@ USA. (receiver input) (set-string-length! input (string-maximum-length input)) (string-fill! input #\delete) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (newline port))) unspecific) @@ -289,7 +289,7 @@ USA. (define (write-command-prompt port prompt level) (if (not (nearest-cmdl/batch-mode?)) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port) (newline port) @@ -352,7 +352,7 @@ USA. (define (default/write-result port expression object hash-number environment) expression (if (not (nearest-cmdl/batch-mode?)) - (port/with-output-terminal-mode port 'COOKED + (with-output-port-terminal-mode port 'COOKED (lambda () (fresh-line port) (write-string ";" port) -- 2.25.1