From ed122b53dff8ac1f3442e2a4fc12a25414aedbe9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 24 Jan 2017 19:54:51 -0800 Subject: [PATCH] Plumb genio to pass caller name down to operations. --- src/runtime/fileio.scm | 13 ++++--- src/runtime/genio.scm | 74 +++++++++++++++++++--------------------- src/runtime/port.scm | 8 ++--- src/runtime/process.scm | 26 ++++++++------ src/runtime/socket.scm | 17 +++++---- src/runtime/stringio.scm | 6 ++-- src/runtime/ttyio.scm | 3 +- 7 files changed, 78 insertions(+), 69 deletions(-) diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm index 31dc1ee69..ff02f0d1b 100644 --- a/src/runtime/fileio.scm +++ b/src/runtime/fileio.scm @@ -98,26 +98,29 @@ USA. (make-port channel channel pathname caller)))) (define (make-textual-file-port input-channel output-channel pathname caller) - caller - (let ((port (%make-textual-file-port input-channel output-channel pathname))) + (let ((port + (%make-textual-file-port input-channel output-channel pathname + caller))) (port/set-line-ending port (file-line-ending pathname)) port)) (define (make-legacy-binary-file-port input-channel output-channel pathname caller) - caller - (let ((port (%make-textual-file-port input-channel output-channel pathname))) + (let ((port + (%make-textual-file-port input-channel output-channel pathname + caller))) (port/set-coding port 'BINARY) (port/set-line-ending port 'BINARY) port)) -(define (%make-textual-file-port input-channel output-channel pathname) +(define (%make-textual-file-port input-channel output-channel pathname caller) (let ((port (make-generic-i/o-port (and input-channel (make-channel-input-source input-channel)) (and output-channel (make-channel-output-sink output-channel)) + caller (cond ((not input-channel) output-file-type) ((not output-channel) input-file-type) (else i/o-file-type))))) diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 80d70a4e8..1195b53e2 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -29,7 +29,7 @@ USA. (declare (usual-integrations)) -(define (make-generic-i/o-port source sink #!optional type . extra-state) +(define (make-generic-i/o-port source sink caller #!optional type . extra-state) (if (not (or source sink)) (error "Missing arguments.")) (let ((port @@ -37,8 +37,9 @@ USA. (generic-i/o-port-type (source-type source) (sink-type sink)) type) - (apply make-gstate source sink 'TEXT 'TEXT - extra-state)))) + (apply make-gstate source sink 'TEXT 'TEXT caller + extra-state) + caller))) (let ((ib (port-input-buffer port))) (if ib (set-input-buffer-port! ib port))) @@ -81,16 +82,18 @@ USA. (input-buffer-binary-port ib))) (output-buffer-binary-port (port-output-buffer port)))) -(define (make-gstate source sink coder-name normalizer-name . extra) - (let ((binary-port (make-binary-port source sink))) +(define (make-gstate source sink coder-name normalizer-name caller . extra) + (let ((binary-port (make-binary-port source sink caller))) (%make-gstate (and source (make-input-buffer binary-port coder-name - normalizer-name)) + normalizer-name + caller)) (and sink (make-output-buffer binary-port coder-name - normalizer-name)) + normalizer-name + caller)) coder-name normalizer-name (list->vector extra)))) @@ -351,10 +354,11 @@ USA. (define (generic-io/set-coding port name) (let ((ib (port-input-buffer port))) (if ib - (set-input-buffer-coding! ib name))) + (set-input-buffer-decoder! ib (name->decoder name 'port/set-coding)))) (let ((ob (port-output-buffer port))) (if ob - (set-output-buffer-coding! ob name))) + (set-output-buffer-encoder! ob + (name->encoder name 'port/set-coding)))) (set-gstate-coder-name! (textual-port-state port) name)) (define (generic-io/known-coding? port coding) @@ -376,14 +380,18 @@ USA. (define (generic-io/set-line-ending port name) (let ((ib (port-input-buffer port))) (if ib - (set-input-buffer-line-ending! + (set-input-buffer-normalizer! ib - (line-ending (input-buffer-channel ib) name #f)))) + (name->normalizer (line-ending (input-buffer-channel ib) name #f + 'port/set-line-ending) + 'port/set-line-ending)))) (let ((ob (port-output-buffer port))) (if ob - (set-output-buffer-line-ending! + (set-output-buffer-denormalizer! ob - (line-ending (output-buffer-channel ob) name #t)))) + (name->denormalizer (line-ending (output-buffer-channel ob) name #t + 'port/set-line-ending) + 'port/set-line-ending)))) (set-gstate-normalizer-name! (textual-port-state port) name)) (define (generic-io/known-line-ending? port line-ending) @@ -399,8 +407,8 @@ USA. ((output-port? port) (known-output-line-endings)) (else '()))) -(define (line-ending channel name for-output?) - (guarantee-symbol name #f) +(define (line-ending channel name for-output? caller) + (guarantee-symbol name caller) (if (and for-output? (known-input-line-ending? name) (not (known-output-line-ending? name))) @@ -441,13 +449,14 @@ USA. NAME) (DEFINE (,(symbol aproc '/POST-BOOT) NAME ALIAS) (HASH-TABLE/PUT! ,aliases NAME ALIAS)) - (DEFINE (,(symbol 'NAME-> sing) NAME) + (DEFINE (,(symbol 'NAME-> sing) NAME #!OPTIONAL CALLER) (LET LOOP ((NAME NAME)) (LET ((ALIAS (HASH-TABLE/GET ,aliases NAME #F))) (COND ((SYMBOL? ALIAS) (LOOP ALIAS)) ((PROCEDURE? ALIAS) (LOOP (ALIAS))) ((HASH-TABLE/GET ,plur NAME #F)) - (else (ERROR:BAD-RANGE-ARGUMENT NAME #F)))))))))) + (else + (ERROR:BAD-RANGE-ARGUMENT NAME CALLER)))))))))) (ill-formed-syntax form))))) (define-name-map decoder) @@ -552,13 +561,15 @@ USA. ;;;; Input buffer -(define (make-input-buffer binary-port coder-name normalizer-name) +(define (make-input-buffer binary-port coder-name normalizer-name caller) (%make-input-buffer binary-port - (name->decoder coder-name) + (name->decoder coder-name caller) (name->normalizer (line-ending (binary-input-port-channel binary-port) normalizer-name - #f)) + #f + caller) + caller) (make-bytevector max-char-bytes) #f '() @@ -599,12 +610,6 @@ USA. (define (input-buffer-at-eof? ib) (binary-input-port-at-eof? (input-buffer-binary-port ib))) -(define (set-input-buffer-coding! ib coding) - (set-input-buffer-decoder! ib (name->decoder coding))) - -(define (set-input-buffer-line-ending! ib name) - (set-input-buffer-normalizer! ib (name->normalizer name))) - (define (generic-input-port-buffer-contents port) (binary-input-port-buffer-contents (input-buffer-binary-port (port-input-buffer port)))) @@ -654,13 +659,15 @@ USA. ;;;; Output buffer -(define (make-output-buffer binary-port coder-name normalizer-name) +(define (make-output-buffer binary-port coder-name normalizer-name caller) (%make-output-buffer binary-port - (name->encoder coder-name) + (name->encoder coder-name caller) (name->denormalizer (line-ending (binary-output-port-channel binary-port) normalizer-name - #t)) + #t + caller) + caller) (make-bytevector max-char-bytes) 0 0 @@ -707,15 +714,6 @@ USA. (with-channel-blocking channel #t do-flush) (do-flush)))) -(define (set-output-buffer-coding! ob coding) - (set-output-buffer-encoder! ob (name->encoder coding))) - -(define (set-output-buffer-line-ending! ob name) - (set-output-buffer-denormalizer! ob (name->denormalizer name))) - -(define (output-buffer-using-binary-denormalizer? ob) - (eq? (output-buffer-denormalizer ob) binary-denormalizer)) - ;; Returns >0 if the character was written in its entirety. ;; Returns 0 if the character wasn't written at all. ;; Returns #f if the write would block. diff --git a/src/runtime/port.scm b/src/runtime/port.scm index e6c0918e2..c43238bac 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -391,8 +391,8 @@ USA. (transcript textual-port-transcript set-textual-port-transcript!) (metadata textual-port-metadata)) -(define (make-textual-port type state) - (guarantee textual-port-type? type 'MAKE-TEXTUAL-PORT) +(define (make-textual-port type state #!optional caller) + (guarantee textual-port-type? type caller) (%make-textual-port (make-thread-mutex) type state #f #f #f (make-alist-metadata-table))) @@ -713,7 +713,7 @@ USA. (channel-blocking channel) (channel-nonblocking channel)))) -(define (channel-mode-binder bind? mode? get-mode set-mode!) +(define (channel-mode-binder bind? get-mode set-mode!) (lambda (channel mode thunk) (if (bind? channel) (let ((outside-mode)) @@ -732,7 +732,6 @@ USA. (define with-channel-blocking-mode (channel-mode-binder (lambda (channel) channel) - blocking-mode? channel-blocking-mode set-channel-blocking-mode!)) @@ -754,7 +753,6 @@ USA. (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!)) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index b12b16456..9c20e256b 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -80,6 +80,19 @@ USA. (1d-table/remove! (subprocess-properties process) key)) (define (subprocess-i/o-port process) + (%subprocess-i/o-port process 'subprocess-i/o-port)) + +(define (subprocess-input-port process) + (let ((port (%subprocess-i/o-port process 'subprocess-input-port))) + (and (input-port? port) + port))) + +(define (subprocess-output-port process) + (let ((port (%subprocess-i/o-port process 'subprocess-output-port))) + (and (output-port? port) + port))) + +(define (%subprocess-i/o-port process caller) (without-interruption (lambda () (or (subprocess-%i/o-port process) @@ -91,20 +104,11 @@ USA. (and input-channel (make-channel-input-source input-channel)) (and output-channel - (make-channel-output-sink output-channel))))))) + (make-channel-output-sink output-channel)) + caller))))) (set-subprocess-%i/o-port! process port) port))))) -(define (subprocess-input-port process) - (let ((port (subprocess-i/o-port process))) - (and (input-port? port) - port))) - -(define (subprocess-output-port process) - (let ((port (subprocess-i/o-port process))) - (and (output-port? port) - port))) - (define (close-subprocess-i/o process) (cond ((subprocess-%i/o-port process) => (lambda (port) diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index 8e23dffe8..a82c391cd 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -74,7 +74,8 @@ USA. (define (tcp-server-connection-accept server-socket block? peer-address) (connection-accept (ucode-primitive new-tcp-server-connection-accept 3) - server-socket block? peer-address)) + server-socket block? peer-address + 'tcp-server-connection-accept)) (define (unix-server-connection-accept server-socket block?) (connection-accept (named-lambda (new-unix-server-connection-accept @@ -82,9 +83,10 @@ USA. (declare (ignore peer)) ((ucode-primitive new-unix-server-connection-accept 2) socket pair)) - server-socket block? #f)) + server-socket block? #f + 'unix-server-connection-accept)) -(define (connection-accept accept! server-socket block? peer-address) +(define (connection-accept accept! server-socket block? peer-address caller) (let ((channel (with-thread-events-blocked (lambda () @@ -113,15 +115,15 @@ USA. (let loop () (do-test loop)) (do-test (lambda () #f)))))))) (and channel - (make-socket-port channel)))) + (make-socket-port channel caller)))) (define (open-tcp-stream-socket host-name service) (let ((channel (open-tcp-stream-socket-channel host-name service))) - (make-socket-port channel))) + (make-socket-port channel 'open-tcp-stream-socket))) (define (open-unix-stream-socket filename) (let ((channel (open-unix-stream-socket-channel filename))) - (make-socket-port channel))) + (make-socket-port channel 'open-unix-stream-socket))) (define (open-tcp-stream-socket-channel host-name service) (let ((host @@ -144,9 +146,10 @@ USA. (lambda () ((ucode-primitive new-open-unix-stream-socket 2) filename p)))))) -(define (make-socket-port channel) +(define (make-socket-port channel caller) (make-generic-i/o-port (make-channel-input-source channel) (make-channel-output-sink channel) + caller socket-port-type)) (define socket-port-type) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index 6c1be3c1d..1e188c53b 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -237,12 +237,13 @@ USA. (procedure (open-input-octets octets))) (define (open-input-octets octets #!optional start end) - (guarantee-xstring octets 'OPEN-INPUT-OCTETS) + (guarantee-xstring octets 'open-input-octets) (receive (start end) (check-index-limits start end (xstring-length octets) 'OPEN-INPUT-OCTETS) (let ((port (make-generic-i/o-port (make-octets-source octets start end) #f + 'open-input-octets octets-input-type))) (port/set-coding port 'BINARY) (port/set-line-ending port 'BINARY) @@ -471,9 +472,10 @@ USA. (let ((os (make-ostate (make-vector-8b 16) 0 #f))) (make-generic-i/o-port #f (make-byte-sink os) + 'open-output-octets octets-output-type os)))) - (port/set-line-ending port 'NEWLINE) + (port/set-line-ending port 'newline) port)) (define (make-byte-sink os) diff --git a/src/runtime/ttyio.scm b/src/runtime/ttyio.scm index 0a47a04b8..54f44ad69 100644 --- a/src/runtime/ttyio.scm +++ b/src/runtime/ttyio.scm @@ -83,7 +83,8 @@ USA. (make-channel-output-sink output-channel) 'TEXT 'TEXT - (channel-type=file? input-channel))) + (channel-type=file? input-channel) + (default-object))) (define (set-console-i/o-port! port) (if (not (i/o-port? port)) -- 2.25.1