Plumb genio to pass caller name down to operations.

diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm
index 31dc1ee695f4bba85adba98249ca72d9372a9bec..ff02f0d1b82ed574ce8b823ceffe301e76133ef2 100644 (file)
--- 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 80d70a4e8591db249dcbb4470eae1bc86aebbdfc..1195b53e2faa0ec0ad2e2bedccb35e9d0f5ef5b3 100644 (file)
--- a/src/runtime/genio.scm
+++ b/src/runtime/genio.scm
@@ -29,7 +29,7 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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))))
 \f
-(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.
 \f
 ;;;; 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)))
 \f
-(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.
 \f
 ;;;; 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))))
 \f
-(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 e6c0918e246cf67124affad114714ec56da1a5d1..c43238bacd3610f46d410cf8954710176f71a4f2 100644 (file)
--- 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 b12b1645629549800aed433406a388bb4790afd2..9c20e256b7d20b34ea2ed76bf12eaa117aea6801 100644 (file)
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -80,6 +80,19 @@ USA.
   (1d-table/remove! (subprocess-properties process) key))
 \f
 (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 8e23dffe847436fb91b86bdd5c012c83529abfaf..a82c391cda95e0d267ff41e2aa521c4cfa3c5915 100644 (file)
--- 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))))
 \f
 (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 6c1be3c1d5a934a48b28c5b510df8cc0aab2cc4c..1e188c53bded33e4fa006ef72c7a056cd5ef8eb9 100644 (file)
--- 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 0a47a04b878d1b75746b9c28efda77d6fb52dfdf..54f44ad69ed2d8a42426375e0d7b11732f321005 100644 (file)
--- 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))