Change port-mode operations to work for all channel ports.
authorChris Hanson <org/chris-hanson/cph>
Wed, 11 Jan 2017 23:08:43 +0000 (15:08 -0800)
committerChris Hanson <org/chris-hanson/cph>
Wed, 11 Jan 2017 23:08:43 +0000 (15:08 -0800)
Also eliminate old names for these operations.

src/runtime/genio.scm
src/runtime/input.scm
src/runtime/parser-buffer.scm
src/runtime/port.scm
src/runtime/rep.scm
src/runtime/runtime.pkg
src/runtime/syncproc.scm
src/runtime/usrint.scm

index dab58a15e4071c637b23e3c050f24d4d2db7fc24..60213f4566264e9ae67c606c37bd06af1d25c174 100644 (file)
@@ -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))
-\f
+
 (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"))))))
 \f
 ;;;; 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
index ad7f795b45c52601ba771ca21d38d7f6724a7791..8de16f526c2f944f55e51922c3ed74c677644295 100644 (file)
@@ -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))))))))))
 \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 ()
index f2d50e78c300f7616757ef7341d28f608b91a041..70b76a1d31c45fad5b0f46b989c995548b669e9c 100644 (file)
@@ -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)
index 95155ce289e7d185045d9e77deef75fbcbd7fa8c..5569473f8e7e196ce8100ff6a9c17659f6331561 100644 (file)
@@ -591,82 +591,6 @@ USA.
        (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?)
@@ -721,6 +645,117 @@ USA.
        ((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)
index 9bb98fe77a79d5fddbc01faa97abf3ac8253eb8c..6f6eb6608fef5c1d9c82313231673c749d211bfa 100644 (file)
@@ -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
index bf746950b457ab6014372d21a291af87f03498ee..f32ebc0bd10095b6baaff070b378e452d36e886c 100644 (file)
@@ -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
index 2f5a90f90a4425ac038ad9a5ab0cadf286e38827..34290ab338efb492108827d29470ce57840c8608 100644 (file)
@@ -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)))
index e588cd9d850966fddf2833ddf4e8136ddb1979cb..b5dbef379926c680e80c4707c39657b76f776b62 100644 (file)
@@ -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)