Also eliminate old names for these operations.
(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)
(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)
(define (generic-io/read-substring port string start end)
(read-substring (port-input-buffer port) string start end))
-\f
+
(define (generic-io/input-line port)
(input-buffer-line (port-input-buffer port)))
(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"))))))
\f
;;;; Output operations
(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
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)))
(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)))
(loop (accum char a))))))))))
\f
(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 ()
(%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)
(error:bad-range-argument port 'PORT/KNOWN-LINE-ENDINGS))
port))
\f
-;;;; 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))))
-\f
;;;; Generic ports
(define port?)
((textual-output-port? port) (textual-output-port-channel port))
(else (error:not-a output-port? port 'output-port-channel))))
\f
+;;;; 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))
+\f
+(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)))
+\f
;;;; Standard Ports
(define current-input-port)
(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)
(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)))))
(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
(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
(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)))
(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)))
(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))))))))
(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))))))))
(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)))
(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)))
((#\newline)
(loop))
(else
- (port/with-output-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'COOKED
(lambda ()
(write char port)
(beep port)
(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))))
(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)
(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)
(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)
(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)
(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)