Another round of cleanups and renames designed to simplify ports.

diff --git a/src/runtime/input.scm b/src/runtime/input.scm
index 3a940c229a200cba55f8ea1a24a0b8e2c90d3d18..ad7f795b45c52601ba771ca21d38d7f6724a7791 100644 (file)
--- a/src/runtime/input.scm
+++ b/src/runtime/input.scm
@@ -33,35 +33,29 @@ USA.
 ;;;; Low level
 
 (define (input-port/char-ready? port)
-  ((port/operation/char-ready? port) port))
-
-(define-integrable (input-port/%read-char port)
-  ((port/%operation/read-char port) port))
+  ((textual-port-operation/char-ready? port) port))
 
 (define (input-port/read-char port)
-  ((port/operation/read-char port) port))
+  ((textual-port-operation/read-char port) port))
 
 (define (input-port/unread-char port char)
-  ((port/operation/unread-char port) port char))
-
-(define-integrable (input-port/%peek-char port)
-  ((port/%operation/peek-char port) port))
+  ((textual-port-operation/unread-char port) port char))
 
 (define (input-port/peek-char port)
-  ((port/operation/peek-char port) port))
+  ((textual-port-operation/peek-char port) port))
 
 (define (input-port/read-string! port string)
   (input-port/read-substring! port string 0 (xstring-length string)))
 
 (define (input-port/read-substring! port string start end)
   (if (< start end)
-      ((port/operation/read-substring port) port string start end)
+      ((textual-port-operation/read-substring port) port string start end)
       0))
-\f
+
 (define (input-port/read-line port)
   (port/with-input-blocking-mode port 'BLOCKING
     (lambda ()
-      (let ((read-char (port/operation/read-char port)))
+      (let ((read-char (textual-port-operation/read-char port)))
        (let loop ((a (make-accum 128)))
          (let ((char (read-char port)))
            (cond ((eof-object? char)
@@ -74,7 +68,7 @@ USA.
 (define (input-port/read-string port delimiters)
   (port/with-input-blocking-mode port 'BLOCKING
     (lambda ()
-      (let ((read-char (port/operation/read-char port)))
+      (let ((read-char (textual-port-operation/read-char port)))
        (let loop ((a (make-accum 128)))
          (let ((char (read-char port)))
            (cond ((eof-object? char)
@@ -86,11 +80,11 @@ USA.
                   (accum->string a))
                  (else
                   (loop (accum char a))))))))))
-
+\f
 (define (input-port/discard-chars port delimiters)
   (port/with-input-blocking-mode port 'BLOCKING
     (lambda ()
-      (let ((read-char (port/operation/read-char port)))
+      (let ((read-char (textual-port-operation/read-char port)))
        (let loop ()
          (let ((char (read-char port)))
            (cond ((eof-object? char)
@@ -129,12 +123,12 @@ USA.
   (eq? object (eof-object)))
 
 (define (input-port/eof? port)
-  (let ((eof? (port/operation port 'EOF?)))
+  (let ((eof? (textual-port-operation port 'EOF?)))
     (and eof?
         (eof? port))))
 
 (define (input-port/line port)
-  (let ((operation (port/operation port 'INPUT-LINE)))
+  (let ((operation (textual-port-operation port 'INPUT-LINE)))
     (and operation
         (operation port))))
 \f
@@ -156,26 +150,22 @@ USA.
                  (else #f))))
        (input-port/char-ready? port))))
 
-(define (%read-char port)
-  (let loop ()
-    (or (input-port/%read-char port)
-       (loop))))
-
 (define (read-char #!optional port)
-  (%read-char (optional-input-port port 'READ-CHAR)))
+  (let ((port (optional-input-port port 'READ-CHAR)))
+    (let loop ()
+      (or (input-port/read-char port)
+         (loop)))))
 
 (define (unread-char char #!optional port)
   (guarantee-char char 'UNREAD-CHAR)
   (input-port/unread-char (optional-input-port port 'UNREAD-CHAR) char))
 
-(define (%peek-char port)
-  (let loop ()
-    (or (input-port/%peek-char port)
-       (loop))))
-
 (define (peek-char #!optional port)
-  (%peek-char (optional-input-port port 'PEEK-CHAR)))
-\f
+  (let ((port (optional-input-port port 'READ-CHAR)))
+    (let loop ()
+      (or (input-port/peek-char port)
+         (loop)))))
+
 (define (read-char-no-hang #!optional port)
   (let ((port (optional-input-port port 'READ-CHAR-NO-HANG)))
     (and (input-port/char-ready? port)
@@ -213,6 +203,8 @@ USA.
                              string start end))
 
 (define (optional-input-port port caller)
-  (if (default-object? port)
-      (current-input-port)
-      (guarantee-input-port port caller)))
\ No newline at end of file
+  (let ((port (if (default-object? port) (current-input-port) port)))
+    (guarantee textual-input-port? port caller)
+    (if (not (textual-input-port-open? port))
+       (error:bad-range-argument port caller))
+    port))
\ No newline at end of file

diff --git a/src/runtime/output.scm b/src/runtime/output.scm
index d7d7769de9e1aa8d5a43b46a45ca330d97aa83bb..da3f34820fe8102d0a8d0671ae3cc5f55797910c 100644 (file)
--- a/src/runtime/output.scm
+++ b/src/runtime/output.scm
@@ -31,116 +31,104 @@ USA.
 \f
 ;;;; Low level
 
-(define-integrable (output-port/%write-char port char)
-  ((port/operation/write-char port) port char))
-
 (define (output-port/write-char port char)
-  ((port/operation/write-char port) port char))
+  ((textual-port-operation/write-char port) port char))
 
 (define (output-port/write-string port string)
   (output-port/write-substring port string 0 (xstring-length string)))
 
 (define (output-port/write-substring port string start end)
-  ((port/operation/write-substring port) port string start end))
+  ((textual-port-operation/write-substring port) port string start end))
 
 (define (output-port/fresh-line port)
-  ((port/operation/fresh-line port) port))
+  ((textual-port-operation/fresh-line port) port))
 
 (define (output-port/line-start? port)
-  ((port/operation/line-start? port) port))
+  ((textual-port-operation/line-start? port) port))
 
 (define (output-port/flush-output port)
-  ((port/operation/flush-output port) port))
-
-(define-integrable (output-port/%discretionary-flush port)
-  ((port/operation/discretionary-flush-output port) port))
+  ((textual-port-operation/flush-output port) port))
 
 (define (output-port/discretionary-flush port)
-  ((port/operation/discretionary-flush-output port) port))
+  ((textual-port-operation/discretionary-flush-output port) port))
 
 (define (output-port/write-object port object environment)
   (unparse-object/top-level object port #t environment))
 
 (define (output-port/x-size port)
-  (or (let ((operation (port/operation port 'X-SIZE)))
+  (or (let ((operation (textual-port-operation port 'X-SIZE)))
        (and operation
             (operation port)))
       80))
 
 (define (output-port/y-size port)
-  (let ((operation (port/operation port 'Y-SIZE)))
+  (let ((operation (textual-port-operation port 'Y-SIZE)))
     (and operation
         (operation port))))
 
 (define (output-port/column port)
-  (let ((operation (port/operation port 'OUTPUT-COLUMN)))
+  (let ((operation (textual-port-operation port 'OUTPUT-COLUMN)))
     (and operation
         (operation port))))
 
 (define (output-port/bytes-written port)
-  (let ((operation (port/operation port 'BYTES-WRITTEN)))
+  (let ((operation (textual-port-operation port 'BYTES-WRITTEN)))
     (and operation
         (operation port))))
 
 (define (output-port/synchronize-output port)
-  (let ((operation (port/operation port 'SYNCHRONIZE-OUTPUT)))
+  (let ((operation (textual-port-operation port 'SYNCHRONIZE-OUTPUT)))
     (if operation
        (operation port))))
 \f
 ;;;; High level
 
-(define (%write-char char port)
-  (if (let ((n (output-port/%write-char port char)))
-       (and n
-            (fix:> n 0)))
-      (output-port/%discretionary-flush port)))
-
 (define (write-char char #!optional port)
-  (%write-char char (optional-output-port port 'WRITE-CHAR)))
+  (let ((port (optional-output-port port 'WRITE-CHAR)))
+    (if (let ((n (output-port/write-char port char)))
+         (and n
+              (fix:> n 0)))
+       (output-port/discretionary-flush port))))
 
 (define (write-string string #!optional port)
   (let ((port (optional-output-port port 'WRITE-STRING)))
     (if (let ((n (output-port/write-string port string)))
          (and n
-              (> n 0)))
+              (fix:> n 0)))
        (output-port/discretionary-flush port))))
 
 (define (write-substring string start end #!optional port)
   (let ((port (optional-output-port port 'WRITE-SUBSTRING)))
     (if (let ((n (output-port/write-substring port string start end)))
          (and n
-              (> n 0)))
+              (fix:> n 0)))
        (output-port/discretionary-flush port))))
 
 (define (newline #!optional port)
-  (let ((port (optional-output-port port 'NEWLINE)))
-    (if (let ((n (output-port/%write-char port #\newline)))
-         (and n
-              (fix:> n 0)))
-       (output-port/%discretionary-flush port))))
+  (write-char #\newline port))
 
 (define (fresh-line #!optional port)
   (let ((port (optional-output-port port 'FRESH-LINE)))
     (if (let ((n (output-port/fresh-line port)))
          (and n
               (fix:> n 0)))
-       (output-port/%discretionary-flush port))))
-\f
+       (output-port/discretionary-flush port))))
+
 (define (display object #!optional port environment)
   (let ((port (optional-output-port port 'DISPLAY)))
     (unparse-object/top-level object port #f environment)
-    (output-port/%discretionary-flush port)))
+    (output-port/discretionary-flush port)))
 
 (define (write object #!optional port environment)
   (let ((port (optional-output-port port 'WRITE)))
     (output-port/write-object port object environment)
-    (output-port/%discretionary-flush port)))
+    (output-port/discretionary-flush port)))
 
 (define (write-line object #!optional port environment)
   (let ((port (optional-output-port port 'WRITE-LINE)))
     (output-port/write-object port object environment)
-    (output-port/%write-char port #\newline)
-    (output-port/%discretionary-flush port)))
+    (output-port/write-char port #\newline)
+    (output-port/discretionary-flush port)))
 
 (define (flush-output-port #!optional port)
   (let ((port (optional-output-port port 'flush-output-port)))
@@ -151,19 +139,21 @@ USA.
 (define (wrap-custom-operation-0 operation-name)
   (lambda (#!optional port)
     (let ((port (optional-output-port port operation-name)))
-      (let ((operation (port/operation port operation-name)))
+      (let ((operation (textual-port-operation port operation-name)))
        (if operation
            (begin
              (operation port)
-             (output-port/%discretionary-flush port)))))))
+             (output-port/discretionary-flush port)))))))
 
 (define beep (wrap-custom-operation-0 'BEEP))
 (define clear (wrap-custom-operation-0 'CLEAR))
 
 (define (optional-output-port port caller)
-  (if (default-object? port)
-      (current-output-port)
-      (guarantee-output-port port caller)))
+  (let ((port (if (default-object? port) (current-output-port) port)))
+    (guarantee textual-output-port? port caller)
+    (if (not (textual-output-port-open? port))
+       (error:bad-range-argument port caller))
+    port))
 \f
 ;;;; Tabular output
 

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 9226c96cda185f4b915f4817e97e02215032ecbb..0b0395627dba1220599b1076a863202e432fd210 100644 (file)
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -577,23 +577,23 @@ USA.
                           (if (char=? char #\|)
                               (read-unquoted #t char (%peek))
                               (begin
-                                (%write-char (if (char=? char #\\)
-                                                 (%read)
-                                                 char)
-                                             port*)
+                                (write-char (if (char=? char #\\)
+                                                (%read)
+                                                char)
+                                            port*)
                                 (read-quoted)))))
                       (error:illegal-char char)))
                  ((char=? char #\\)
                   (if quoting?
                       (begin
-                        (%write-char (%read) port*)
+                        (write-char (%read) port*)
                         ;; Forget previous char so
                         ;; that quoting a final colon will
                         ;; suppress it from being a keyword.
                         (read-unquoted #t #f (%peek)))
                       (error:illegal-char char)))
                  (else
-                  (%write-char (%canon char) port*)
+                  (write-char (%canon char) port*)
                   (read-unquoted quoted? char (%peek)))))))))
 \f
 (define (handler:list port db ctx char)
@@ -756,10 +756,10 @@ USA.
                            ((char-ci=? char #\a) #\bel)
                            ((char->digit char 8) (octal->char char port db))
                            (else char)))))
-              (%write-char char port*)
+              (write-char char port*)
               (loop)))
            (else
-            (%write-char char port*)
+            (write-char char port*)
             (loop))))))))
 
 (define (octal->char c1 port db)
@@ -822,9 +822,9 @@ USA.
        (name->char
         (call-with-output-string
           (lambda (port*)
-            (%write-char char port*)
+            (write-char char port*)
             (let loop ()
-              (%write-char (let ((char (%read-char/no-eof port db)))
+              (write-char (let ((char (%read-char/no-eof port db)))
                             (if (char=? char #\\)
                                 (%read-char/no-eof port db)
                                 char))
@@ -856,7 +856,7 @@ USA.
         (let ((char (%read-char/no-eof port db)))
           (if (not (char=? char #\>))
               (begin
-                (%write-char char port*)
+                (write-char char port*)
                 (loop)))))))))
 
 (define (handler:special-arg port db ctx char1 char2)

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 6d0939a2577e657f45c62309bbbae5a04dbaa0ed..85592b47384f20a74e3267589d1f411f5fabd797 100644 (file)
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -29,78 +29,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define (port? object)
-  (or (textual-port? object)
-      (binary-port? object)))
-
-(define (input-port? object)
-  (or (textual-input-port? object)
-      (binary-input-port? object)))
-
-(define (output-port? object)
-  (or (textual-output-port? object)
-      (binary-output-port? object)))
-
-(define (i/o-port? object)
-  (or (textual-i/o-port? object)
-      (binary-i/o-port? object)))
-
-#;
-(add-boot-init!
- (lambda ()
-   (register-predicate! port? 'port)
-   (set-predicate<=! binary-port? port?)
-   (set-predicate<=! textual-port? port?)
-   (register-predicate! input-port? 'port)
-   (set-predicate<=! binary-input-port? input-port?)
-   (set-predicate<=! textual-input-port? input-port?)
-   (register-predicate! output-port? 'port)
-   (set-predicate<=! binary-output-port? output-port?)
-   (set-predicate<=! textual-output-port? output-port?)
-   (register-predicate! i/o-port? 'port)
-   (set-predicate<=! binary-i/o-port? i/o-port?)
-   (set-predicate<=! textual-i/o-port? i/o-port?)))
-
-(define-guarantee port "port")
-(define-guarantee input-port "input port")
-(define-guarantee output-port "output port")
-(define-guarantee i/o-port "I/O port")
-
-(define (input-port-open? port)
-  (cond ((binary-input-port? port) (binary-input-port-open? port))
-       ((textual-input-port? port) (textual-input-port-open? port))
-       (else (error:not-a input-port? port 'input-port-open?))))
-
-(define (output-port-open? port)
-  (cond ((binary-output-port? port) (binary-output-port-open? port))
-       ((textual-output-port? port) (textual-output-port-open? port))
-       (else (error:not-a output-port? port 'output-port-open?))))
-
-(define (close-port port)
-  (cond ((binary-port? port) (close-binary-port port))
-       ((textual-port? port) (close-textual-port port))
-       (else (error:not-a port? port 'close-port))))
-
-(define (close-input-port port)
-  (cond ((binary-input-port? port) (close-binary-input-port port))
-       ((textual-input-port? port) (close-textual-input-port port))
-       (else (error:not-a input-port? port 'close-input-port))))
-
-(define (close-output-port port)
-  (cond ((binary-output-port? port) (close-binary-output-port port))
-       ((textual-output-port? port) (close-textual-output-port port))
-       (else (error:not-a output-port? port 'close-output-port))))
-
-(define (input-port-channel port)
-  (cond ((binary-input-port? port) (binary-input-port-channel port))
-       ((textual-input-port? port) (textual-input-port-channel port))
-       (else (error:not-a input-port? port 'input-port-channel))))
-
-(define (output-port-channel port)
-  (cond ((binary-output-port? port) (binary-output-port-channel port))
-       ((textual-output-port? port) (textual-output-port-channel port))
-       (else (error:not-a output-port? port 'output-port-channel))))
-\f
 ;;;; Port type
 
 (define-structure (port-type (type-descriptor <textual-port-type>)
@@ -304,8 +232,8 @@ USA.
        (else (op name))))))
 
 (define (generic-port-operation:read-substring port string start end)
-  (let ((char-ready? (port/operation/char-ready? port))
-       (read-char (port/operation/read-char port)))
+  (let ((char-ready? (textual-port-operation/char-ready? port))
+       (read-char (textual-port-operation/read-char port)))
     (let ((char (read-char port)))
       (cond ((not char) #f)
            ((eof-object? char) 0)
@@ -345,7 +273,7 @@ USA.
   unspecific)
 
 (define (generic-port-operation:write-substring port string start end)
-  (let ((write-char (port/operation/write-char port)))
+  (let ((write-char (textual-port-operation/write-char port)))
     (let loop ((i start))
       (if (< i end)
          (let ((n (write-char port (xstring-ref string i))))
@@ -423,7 +351,8 @@ USA.
             (let ((n (defer port string start end)))
               (if (and n (> n 0))
                   (let ((end (+ start n)))
-                    (set-textual-port-previous! port (xstring-ref string (- end 1)))
+                    (set-textual-port-previous! port
+                                                (xstring-ref string (- end 1)))
                     (transcribe-substring string start end port)))
               n))))
        (flush-output
@@ -475,23 +404,49 @@ USA.
   (guarantee-port-type type 'MAKE-PORT)
   (%make-textual-port type state (make-thread-mutex) #f #f '() #f))
 
+(define (textual-input-port? object)
+  (and (textual-port? object)
+       (port-type/supports-input? (port/type object))
+       #t))
+
+(define (textual-output-port? object)
+  (and (textual-port? object)
+       (port-type/supports-output? (port/type object))
+       #t))
+
+(define (textual-i/o-port? object)
+  (and (textual-port? object)
+       (let ((type (port/type object)))
+        (and (port-type/supports-input? type)
+             (port-type/supports-output? type)
+             #t))))
+
+(add-boot-init!
+ (lambda ()
+   (register-predicate! textual-input-port? 'textual-input-port
+                       '<= textual-port?)
+   (register-predicate! textual-output-port? 'textual-output-port
+                       '<= textual-port?)
+   (register-predicate! textual-i/o-port? 'textual-i/o-port
+                       '<= textual-port?)))
+
 (define (port=? p1 p2)
   (guarantee-port p1 'PORT=?)
   (guarantee-port p2 'PORT=?)
   (eq? p1 p2))
 
-(define (port/operation-names port)
+(define (textual-port-operation-names port)
   (port-type/operation-names (port/type port)))
 
-(define (port/operation port name)
-  (guarantee-port port 'port/operation)
+(define (textual-port-operation port name)
+  (guarantee textual-port? port 'textual-port-operation)
   (port-type/%operation (port/type port) name))
-\f
+
 (define-syntax define-port-operation
   (sc-macro-transformer
    (lambda (form environment)
      (let ((name (cadr form)))
-       `(DEFINE (,(symbol-append 'PORT/OPERATION/ name) PORT)
+       `(DEFINE (,(symbol-append 'TEXTUAL-PORT-OPERATION/ name) PORT)
          (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
           (PORT/TYPE PORT)))))))
 
@@ -506,16 +461,6 @@ USA.
 (define-port-operation line-start?)
 (define-port-operation flush-output)
 (define-port-operation discretionary-flush-output)
-
-(define (port-position port)
-  ((or (port/operation port 'POSITION)
-       (error:bad-range-argument port 'PORT-POSITION))
-   port))
-
-(define (set-port-position! port position)
-  ((or (port/operation port 'SET-POSITION!)
-       (error:bad-range-argument port 'SET-PORT-POSITION!))
-   port position))
 \f
 (set-record-type-unparser-method! <textual-port>
   (lambda (state port)
@@ -524,7 +469,7 @@ USA.
                  ((textual-input-port? port) 'TEXTUAL-INPUT-PORT)
                  ((textual-output-port? port) 'TEXTUAL-OUTPUT-PORT)
                  (else 'TEXTUAL-PORT))))
-       (cond ((port/operation port 'WRITE-SELF)
+       (cond ((textual-port-operation port 'WRITE-SELF)
              => (lambda (operation)
                   (standard-unparser-method name operation)))
             (else
@@ -539,7 +484,7 @@ USA.
     port))
 
 (define (close-textual-port port)
-  (let ((close (port/operation port 'CLOSE)))
+  (let ((close (textual-port-operation port 'CLOSE)))
     (if close
        (close port)
        (begin
@@ -547,17 +492,17 @@ USA.
          (close-input-port port)))))
 
 (define (close-textual-input-port port)
-  (let ((close-input (port/operation port 'CLOSE-INPUT)))
+  (let ((close-input (textual-port-operation port 'CLOSE-INPUT)))
     (if close-input
        (close-input port))))
 
 (define (close-textual-output-port port)
-  (let ((close-output (port/operation port 'CLOSE-OUTPUT)))
+  (let ((close-output (textual-port-operation port 'CLOSE-OUTPUT)))
     (if close-output
        (close-output port))))
 
 (define (port/open? port)
-  (let ((open? (port/operation port 'OPEN?)))
+  (let ((open? (textual-port-operation port 'OPEN?)))
     (if open?
        (open? port)
        (and (if (textual-input-port? port)
@@ -568,24 +513,24 @@ USA.
                 #t)))))
 
 (define (textual-input-port-open? port)
-  (let ((open? (port/operation port 'INPUT-OPEN?)))
+  (let ((open? (textual-port-operation port 'INPUT-OPEN?)))
     (if open?
        (open? port)
        #t)))
 
 (define (textual-output-port-open? port)
-  (let ((open? (port/operation port 'OUTPUT-OPEN?)))
+  (let ((open? (textual-port-operation port 'OUTPUT-OPEN?)))
     (if open?
        (open? port)
        #t)))
 
-(define (textual-port-input-channel port)
-  (let ((operation (port/operation port 'input-port-channel)))
+(define (textual-input-port-channel port)
+  (let ((operation (textual-port-operation port 'input-port-channel)))
     (and operation
         (operation port))))
 
-(define (textual-port-output-channel port)
-  (let ((operation (port/operation port 'output-port-channel)))
+(define (textual-output-port-channel port)
+  (let ((operation (textual-port-operation port 'output-port-channel)))
     (and operation
         (operation port))))
 \f
@@ -616,12 +561,14 @@ USA.
 
 (define (port/remove-property! port name)
   (guarantee-symbol name 'PORT/REMOVE-PROPERTY!)
-  (set-textual-port-properties! port (del-assq! name (textual-port-properties port))))
+  (set-textual-port-properties! port
+                               (del-assq! name
+                                          (textual-port-properties port))))
 
 (define (transcribe-char char port)
   (let ((tport (textual-port-transcript port)))
     (if tport
-       (%write-char char tport))))
+       (write-char char tport))))
 
 (define (transcribe-substring string start end port)
   (let ((tport (textual-port-transcript port)))
@@ -637,131 +584,114 @@ USA.
   (let ((tport (textual-port-transcript port)))
     (if tport
        (output-port/discretionary-flush tport))))
-\f
-(define (textual-input-port? object)
-  (and (textual-port? object)
-       (port-type/supports-input? (port/type object))
-       #t))
 
-(define (textual-output-port? object)
-  (and (textual-port? object)
-       (port-type/supports-output? (port/type object))
-       #t))
-
-(define (textual-i/o-port? object)
-  (and (textual-port? object)
-       (let ((type (port/type object)))
-        (and (port-type/supports-input? type)
-             (port-type/supports-output? type)
-             #t))))
-\f
 (define (port/supports-coding? port)
-  (let ((operation (port/operation port 'SUPPORTS-CODING?)))
+  (let ((operation (textual-port-operation port 'SUPPORTS-CODING?)))
     (if operation
        (operation port)
        #f)))
 
 (define (port/coding port)
-  ((or (port/operation port 'CODING)
+  ((or (textual-port-operation port 'CODING)
        (error:bad-range-argument port 'PORT/CODING))
    port))
 
 (define (port/set-coding port name)
-  ((or (port/operation port 'SET-CODING)
+  ((or (textual-port-operation port 'SET-CODING)
        (error:bad-range-argument port 'PORT/SET-CODING))
    port name))
 
 (define (port/known-coding? port name)
-  ((or (port/operation port 'KNOWN-CODING?)
+  ((or (textual-port-operation port 'KNOWN-CODING?)
        (error:bad-range-argument port 'PORT/KNOWN-CODING?))
    port name))
 
 (define (port/known-codings port)
-  ((or (port/operation port 'KNOWN-CODINGS)
+  ((or (textual-port-operation port 'KNOWN-CODINGS)
        (error:bad-range-argument port 'PORT/KNOWN-CODINGS))
    port))
 
 (define (port/line-ending port)
-  ((or (port/operation port 'LINE-ENDING)
+  ((or (textual-port-operation port 'LINE-ENDING)
        (error:bad-range-argument port 'PORT/LINE-ENDING))
    port))
 
 (define (port/set-line-ending port name)
-  ((or (port/operation port 'SET-LINE-ENDING)
+  ((or (textual-port-operation port 'SET-LINE-ENDING)
        (error:bad-range-argument port 'PORT/SET-LINE-ENDING))
    port name))
 
 (define (port/known-line-ending? port name)
-  ((or (port/operation port 'KNOWN-LINE-ENDING?)
+  ((or (textual-port-operation port 'KNOWN-LINE-ENDING?)
        (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDING?))
    port name))
 
 (define (port/known-line-endings port)
-  ((or (port/operation port 'KNOWN-LINE-ENDINGS)
+  ((or (textual-port-operation port 'KNOWN-LINE-ENDINGS)
        (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDINGS))
    port))
 \f
 ;;;; Special Operations
 
-(define (port/input-blocking-mode port)
-  (let ((operation (port/operation port 'INPUT-BLOCKING-MODE)))
+(define (input-port-blocking-mode port)
+  (let ((operation (textual-port-operation port 'INPUT-BLOCKING-MODE)))
     (if operation
        (operation port)
        #f)))
 
-(define (port/set-input-blocking-mode port mode)
-  (let ((operation (port/operation port 'SET-INPUT-BLOCKING-MODE)))
+(define (set-input-port-blocking-mode! port mode)
+  (let ((operation (textual-port-operation port 'SET-INPUT-BLOCKING-MODE)))
     (if operation
        (operation port mode))))
 
-(define (port/with-input-blocking-mode port mode thunk)
+(define (with-input-port-blocking-mode port mode thunk)
   (bind-mode port 'INPUT-BLOCKING-MODE 'SET-INPUT-BLOCKING-MODE mode thunk))
 
-(define (port/output-blocking-mode port)
-  (let ((operation (port/operation port 'OUTPUT-BLOCKING-MODE)))
+(define (output-port-blocking-mode port)
+  (let ((operation (textual-port-operation port 'OUTPUT-BLOCKING-MODE)))
     (if operation
        (operation port)
        #f)))
 
-(define (port/set-output-blocking-mode port mode)
-  (let ((operation (port/operation port 'SET-OUTPUT-BLOCKING-MODE)))
+(define (set-output-port-blocking-mode! port mode)
+  (let ((operation (textual-port-operation port 'SET-OUTPUT-BLOCKING-MODE)))
     (if operation
        (operation port mode))))
 
-(define (port/with-output-blocking-mode port mode thunk)
+(define (with-output-port-blocking-mode port mode thunk)
   (bind-mode port 'OUTPUT-BLOCKING-MODE 'SET-OUTPUT-BLOCKING-MODE mode thunk))
 
-(define (port/input-terminal-mode port)
-  (let ((operation (port/operation port 'INPUT-TERMINAL-MODE)))
+(define (input-port-terminal-mode port)
+  (let ((operation (textual-port-operation port 'INPUT-TERMINAL-MODE)))
     (if operation
        (operation port)
        #f)))
 
-(define (port/set-input-terminal-mode port mode)
-  (let ((operation (port/operation port 'SET-INPUT-TERMINAL-MODE)))
+(define (set-input-port-terminal-mode! port mode)
+  (let ((operation (textual-port-operation port 'SET-INPUT-TERMINAL-MODE)))
     (if operation
        (operation port mode))))
 
-(define (port/with-input-terminal-mode port mode thunk)
+(define (with-input-port-terminal-mode port mode thunk)
   (bind-mode port 'INPUT-TERMINAL-MODE 'SET-INPUT-TERMINAL-MODE mode thunk))
 
-(define (port/output-terminal-mode port)
-  (let ((operation (port/operation port 'OUTPUT-TERMINAL-MODE)))
+(define (output-port-terminal-mode port)
+  (let ((operation (textual-port-operation port 'OUTPUT-TERMINAL-MODE)))
     (if operation
        (operation port)
        #f)))
 
-(define (port/set-output-terminal-mode port mode)
-  (let ((operation (port/operation port 'SET-OUTPUT-TERMINAL-MODE)))
+(define (set-output-port-terminal-mode! port mode)
+  (let ((operation (textual-port-operation port 'SET-OUTPUT-TERMINAL-MODE)))
     (if operation
        (operation port mode))))
 
-(define (port/with-output-terminal-mode port mode thunk)
+(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 (port/operation port read-mode))
-       (write-mode (port/operation port write-mode)))
+  (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 ()
@@ -777,6 +707,93 @@ USA.
                                (write-mode port outside-mode))))))
        (thunk))))
 \f
+;;;; Generic ports
+
+(define port?)
+(define input-port?)
+(define output-port?)
+(define i/o-port?)
+(add-boot-init!
+ (lambda ()
+   (set! port? (disjoin textual-port? binary-port?))
+   (set! input-port? (disjoin textual-input-port? binary-input-port?))
+   (set! output-port? (disjoin textual-output-port? binary-output-port?))
+   (set! i/o-port? (disjoin textual-i/o-port? binary-i/o-port?))
+   unspecific))
+
+#|
+(define (port? object)
+  (or (textual-port? object)
+      (binary-port? object)))
+
+(define (input-port? object)
+  (or (textual-input-port? object)
+      (binary-input-port? object)))
+
+(define (output-port? object)
+  (or (textual-output-port? object)
+      (binary-output-port? object)))
+
+(define (i/o-port? object)
+  (or (textual-i/o-port? object)
+      (binary-i/o-port? object)))
+
+(add-boot-init!
+ (lambda ()
+   (register-predicate! port? 'port)
+   (set-predicate<=! binary-port? port?)
+   (set-predicate<=! textual-port? port?)
+   (register-predicate! input-port? 'port)
+   (set-predicate<=! binary-input-port? input-port?)
+   (set-predicate<=! textual-input-port? input-port?)
+   (register-predicate! output-port? 'port)
+   (set-predicate<=! binary-output-port? output-port?)
+   (set-predicate<=! textual-output-port? output-port?)
+   (register-predicate! i/o-port? 'port)
+   (set-predicate<=! binary-i/o-port? i/o-port?)
+   (set-predicate<=! textual-i/o-port? i/o-port?)))
+|#
+
+(define-guarantee port "port")
+(define-guarantee input-port "input port")
+(define-guarantee output-port "output port")
+(define-guarantee i/o-port "I/O port")
+
+(define (input-port-open? port)
+  (cond ((binary-input-port? port) (binary-input-port-open? port))
+       ((textual-input-port? port) (textual-input-port-open? port))
+       (else (error:not-a input-port? port 'input-port-open?))))
+
+(define (output-port-open? port)
+  (cond ((binary-output-port? port) (binary-output-port-open? port))
+       ((textual-output-port? port) (textual-output-port-open? port))
+       (else (error:not-a output-port? port 'output-port-open?))))
+
+(define (close-port port)
+  (cond ((binary-port? port) (close-binary-port port))
+       ((textual-port? port) (close-textual-port port))
+       (else (error:not-a port? port 'close-port))))
+
+(define (close-input-port port)
+  (cond ((binary-input-port? port) (close-binary-input-port port))
+       ((textual-input-port? port) (close-textual-input-port port))
+       (else (error:not-a input-port? port 'close-input-port))))
+
+(define (close-output-port port)
+  (cond ((binary-output-port? port) (close-binary-output-port port))
+       ((textual-output-port? port) (close-textual-output-port port))
+       (else (error:not-a output-port? port 'close-output-port))))
+
+(define (input-port-channel port)
+  (cond ((binary-input-port? port) (binary-input-port-channel port))
+       ((textual-input-port? port) (textual-input-port-channel port))
+       (else (error:not-a input-port? port 'input-port-channel))))
+
+(define (output-port-channel port)
+  (cond ((binary-output-port? port) (binary-output-port-channel port))
+       ((textual-output-port? port) (textual-output-port-channel port))
+       (else (error:not-a output-port? port 'output-port-channel))))
+\f
 ;;;; Standard Ports
 
 (define current-input-port)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c06e68b6c1f0bd615f0d4ca5c2f6e5706c9a9b1d..bd271647b4b7ffb6fe48f34f52659962943213ea 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2465,6 +2465,7 @@ USA.
          close-binary-output-port
          close-binary-port)
   (export (runtime output-port)
+         binary-output-port?
          flush-binary-output-port))
 
 (define-package (runtime port)
@@ -2472,11 +2473,25 @@ USA.
   (parent (runtime))
   (export ()
          ;; BEGIN legacy bindings
+         (port/input-blocking-mode input-port-blocking-mode)
          (port/input-channel input-port-channel)
+         (port/input-terminal-mode input-port-terminal-mode)
+         (port/operation textual-port-operation)
+         (port/operation-names textual-port-operation-names)
+         (port/output-blocking-mode output-port-blocking-mode)
          (port/output-channel output-port-channel)
+         (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/state textual-port-state)
          (port/thread-mutex textual-port-thread-mutex)
          (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)
          (set-port/state! set-textual-port-state!)
          ;; END legacy bindings
          close-input-port
@@ -2489,20 +2504,21 @@ USA.
          guarantee-output-port
          guarantee-port
          i/o-port?
+         input-port-blocking-mode
          input-port-channel
          input-port-open?
+         input-port-terminal-mode
          input-port?
          interaction-i/o-port
          notification-output-port
+         output-port-blocking-mode
          output-port-channel
          output-port-open?
+         output-port-terminal-mode
          output-port?
-         port-position
          port/coding
          port/copy
          port/get-property
-         port/input-blocking-mode
-         port/input-terminal-mode
          port/intern-property!
          port/known-coding?
          port/known-codings
@@ -2510,61 +2526,62 @@ USA.
          port/known-line-endings
          port/line-ending
          port/open?
-         port/operation
-         port/operation-names
-         port/output-blocking-mode
-         port/output-terminal-mode
+         textual-port-operation
+         textual-port-operation-names
          port/remove-property!
          port/set-coding
-         port/set-input-blocking-mode
-         port/set-input-terminal-mode
          port/set-line-ending
-         port/set-output-blocking-mode
-         port/set-output-terminal-mode
          port/set-property!
          port/supports-coding?
-         port/with-input-blocking-mode
-         port/with-input-terminal-mode
-         port/with-output-blocking-mode
-         port/with-output-terminal-mode
          port=?
          port?
          set-current-input-port!
          set-current-output-port!
+         set-input-port-blocking-mode!
+         set-input-port-terminal-mode!
          set-interaction-i/o-port!
          set-notification-output-port!
-         set-port-position!
+         set-output-port-blocking-mode!
+         set-output-port-terminal-mode!
          set-trace-output-port!
          textual-port?
          trace-output-port
          with-input-from-port
+         with-input-port-blocking-mode
+         with-input-port-terminal-mode
          with-interaction-i/o-port
          with-notification-output-port
+         with-output-port-blocking-mode
+         with-output-port-terminal-mode
          with-output-to-port
          with-trace-output-port)
   (export (runtime)
+         (port/input-channel textual-input-port-channel)
+         (port/output-channel textual-output-port-channel)
          generic-port-operation:write-substring
          make-port
          make-port-type
-         port/input-channel
-         port/output-channel
          set-textual-port-state!
          textual-port-state)
   (export (runtime input-port)
-         port/operation
-         port/operation/char-ready?
-         port/operation/peek-char
-         port/operation/read-char
-         port/operation/read-substring
-         port/operation/unread-char)
+         textual-input-port-open?
+         textual-input-port?
+         textual-port-operation
+         textual-port-operation/char-ready?
+         textual-port-operation/peek-char
+         textual-port-operation/read-char
+         textual-port-operation/read-substring
+         textual-port-operation/unread-char)
   (export (runtime output-port)
-         port/operation
-         port/operation/discretionary-flush-output
-         port/operation/flush-output
-         port/operation/fresh-line
-         port/operation/line-start?
-         port/operation/write-char
-         port/operation/write-substring)
+         textual-output-port-open?
+         textual-output-port?
+         textual-port-operation
+         textual-port-operation/discretionary-flush-output
+         textual-port-operation/flush-output
+         textual-port-operation/fresh-line
+         textual-port-operation/line-start?
+         textual-port-operation/write-char
+         textual-port-operation/write-substring)
   (export (runtime transcript)
          set-textual-port-transcript!
          textual-port-transcript)
@@ -2580,16 +2597,10 @@ USA.
   (parent (runtime))
   (export ()
          (discard-char read-char)
-         (%discard-char %read-char)
-         (input-port/%discard-char input-port/%read-char)
          (input-port/discard-char input-port/read-char)
-         %read-char
-         %peek-char
          char-ready?
          eof-object
          eof-object?
-         input-port/%read-char
-         input-port/%peek-char
          input-port/char-ready?
          input-port/line
          input-port/discard-chars
@@ -2618,7 +2629,6 @@ USA.
   (parent (runtime))
   (export ()
          (flush-output flush-output-port)
-         %write-char
          beep
          call-with-truncated-output-port
          clear
@@ -2626,8 +2636,6 @@ USA.
          flush-output-port
          fresh-line
          newline
-         output-port/%write-char
-         output-port/%discretionary-flush
          output-port/bytes-written
          output-port/column
          output-port/discretionary-flush

diff --git a/src/runtime/unicode.scm b/src/runtime/unicode.scm
index 305fa91020a9bf08234f448714cfac6383a360da..ee9e63cc65b897ab8ba3a02328531a8c92bdf47b 100644 (file)
--- a/src/runtime/unicode.scm
+++ b/src/runtime/unicode.scm
@@ -258,10 +258,10 @@ USA.
   (let ((input (open-input string start end))
        (output (open-output)))
     (let loop ()
-      (let ((c (%read-char input)))
+      (let ((c (read-char input)))
        (if (not (eof-object? c))
            (begin
-             (%write-char c output)
+             (write-char c output)
              (loop)))))
     (get-output-string! output)))
 \f
@@ -681,7 +681,7 @@ USA.
 (define (for-all-chars-in-string? predicate string #!optional start end coding)
   (let ((port (open-string string start end coding 'FOR-ALL-CHARS-IN-STRING?)))
     (let loop ()
-      (let ((char (%read-char port)))
+      (let ((char (read-char port)))
        (cond ((eof-object? char) #t)
              ((predicate char) (loop))
              (else #f))))))
@@ -689,7 +689,7 @@ USA.
 (define (for-any-char-in-string? predicate string #!optional start end coding)
   (let ((port (open-string string start end coding 'FOR-ANY-CHAR-IN-STRING?)))
     (let loop ()
-      (let ((char (%read-char port)))
+      (let ((char (read-char port)))
        (cond ((eof-object? char) #f)
              ((predicate char) #t)
              (else (loop)))))))