From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Tue, 24 Nov 2009 02:03:07 +0000 (-0800)
Subject: Add fast write-char and discretionary-flush.
X-Git-Tag: 20100708-Gtk~233
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=25379be5b5279ef8b83df9f1cbaf0cf07cc89141;p=mit-scheme.git

Add fast write-char and discretionary-flush.
---

diff --git a/src/runtime/output.scm b/src/runtime/output.scm
index 7980c7b8f..a3ebee73e 100644
--- 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"))
 
 ;;;; 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.
 
 ;;;; 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))))
 
 (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))