Add fast write-char and discretionary-flush.

diff --git a/src/runtime/output.scm b/src/runtime/output.scm
index 7980c7b8f1599874e1054e258ded14f377f69d1c..a3ebee73e9d2dac55365aeed18dd91d41adea9d7 100644 (file)
--- a/src/runtime/output.scm
+++ b/src/runtime/output.scm
@@ -26,10 +26,14 @@ USA.
 ;;;; Output
 ;;; package: (runtime output-port)
 
-(declare (usual-integrations))
+(declare (usual-integrations)
+        (integrate-external "port"))
 \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))
 
@@ -48,6 +52,9 @@ USA.
 (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))
+
 (define (output-port/discretionary-flush port)
   ((port/operation/discretionary-flush-output port) port))
 
@@ -82,12 +89,14 @@ USA.
 \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)
-  (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))))
+  (%write-char char (optional-output-port port 'WRITE-CHAR)))
 
 (define (write-string string #!optional port)
   (let ((port (optional-output-port port 'WRITE-STRING)))
@@ -105,33 +114,33 @@ USA.
 
 (define (newline #!optional port)
   (let ((port (optional-output-port port 'NEWLINE)))
-    (if (let ((n (output-port/write-char port #\newline)))
+    (if (let ((n (output-port/%write-char port #\newline)))
          (and n
               (fix:> n 0)))
-       (output-port/discretionary-flush port))))
+       (output-port/%discretionary-flush 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))))
+       (output-port/%discretionary-flush port))))
 \f
 (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 #!optional port)
   (output-port/flush-output (optional-output-port port 'FLUSH-OUTPUT)))
@@ -139,11 +148,11 @@ 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 (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))