From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Tue, 24 Nov 2009 16:00:45 +0000 (-0800)
Subject: Use faster i/o in parse.
X-Git-Tag: 20100708-Gtk~229
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a0de54abe0f8ef65c6b8e50bbe32d6cb450e5b4d;p=mit-scheme.git

Use faster i/o in parse.
---

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 9adb7f580..d0a08b5c5 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -26,7 +26,9 @@ USA.
 ;;;; Scheme Parser
 ;;; package: (runtime parser)
 
-(declare (usual-integrations))
+(declare (usual-integrations)
+	 (integrate-external "input")
+	 (integrate-external "port"))
 
 (define *parser-radix* 10)
 (define *parser-canonicalize-symbols?* #t)
@@ -71,7 +73,7 @@ USA.
   (let ((handlers (parser-table/initial (db-parser-table db))))
     (let loop ()
       (let* ((position (current-position port db))
-	     (char (read-char port)))
+	     (char (%read-char port)))
 	(if (eof-object? char)
 	    char
 	    (let ((object ((get-handler char handlers) port db ctx char)))
@@ -85,7 +87,7 @@ USA.
   (list 'CONTINUE-PARSING))
 
 (define (handler:special port db ctx char1)
-  (let ((char2 (read-char/no-eof port)))
+  (let ((char2 (%read-char/no-eof port)))
     ((get-handler char2 (parser-table/special (db-parser-table db)))
      port db ctx char1 char2)))
 
@@ -183,7 +185,7 @@ USA.
 (define (handler:comment port db ctx char)
   db ctx char
   (let loop ()
-    (let ((char (read-char port)))
+    (let ((char (%read-char port)))
       (cond ((eof-object? char) char)
 	    ((char=? char #\newline) unspecific)
 	    (else (loop)))))
@@ -192,16 +194,16 @@ USA.
 (define (handler:multi-line-comment port db ctx char1 char2)
   db ctx char1 char2
   (let loop ()
-    (case (read-char/no-eof port)
+    (case (%read-char/no-eof port)
       ((#\#)
        (let sharp ()
-	 (case (read-char/no-eof port)
+	 (case (%read-char/no-eof port)
 	   ((#\#) (sharp))
 	   ((#\|) (loop) (loop))
 	   (else (loop)))))
       ((#\|)
        (let vbar ()
-	 (case (read-char/no-eof port)
+	 (case (%read-char/no-eof port)
 	   ((#\#) unspecific)
 	   ((#\|) (vbar))
 	   (else (loop)))))
@@ -256,19 +258,19 @@ USA.
 		 (let ((char (car prefix)))
 		   (set! prefix (cdr prefix))
 		   char)
-		 (read-char/no-eof port))))
+		 (%read-char/no-eof port))))
 	(%peek
 	 (lambda ()
 	   (if (pair? prefix)
 	       (car prefix)
-	       (peek-char port))))
+	       (%peek-char port))))
 	(%discard
 	 (lambda ()
 	   (if (pair? prefix)
 	       (begin
 		 (set! prefix (cdr prefix))
 		 unspecific)
-	       (read-char port)))))
+	       (%read-char port)))))
     (let read-unquoted ((quoted? #f))
       (let ((char (%peek)))
 	(if (or (eof-object? char)
@@ -286,7 +288,7 @@ USA.
 			     (if (char=? char #\|)
 				 (read-unquoted #t)
 				 (begin
-				   (write-char (if (char=? char #\\)
+				   (%write-char (if (char=? char #\\)
 						   (%read)
 						   char)
 					       port*)
@@ -295,11 +297,11 @@ USA.
 		    ((char=? char #\\)
 		     (if quoting?
 			 (begin
-			   (write-char (%read) port*)
+			   (%write-char (%read) port*)
 			   (read-unquoted #t))
 			 (error:illegal-char char)))
 		    (else
-		     (write-char (canon char) port*)
+		     (%write-char (canon char) port*)
 		     (read-unquoted quoted?)))))))))
 
 (define (handler:list port db ctx char)
@@ -416,9 +418,9 @@ USA.
 
 (define (handler:unquote port db ctx char)
   ctx char
-  (if (char=? (peek-char/no-eof port) #\@)
+  (if (char=? (%peek-char/no-eof port) #\@)
       (begin
-	(read-char port)
+	(%read-char port)
 	(list 'UNQUOTE-SPLICING (read-object port db)))
       (list 'UNQUOTE (read-object port db))))
 
@@ -427,13 +429,13 @@ USA.
   (call-with-output-string
     (lambda (port*)
       (let loop ()
-	(let ((char (read-char/no-eof port)))
+	(let ((char (%read-char/no-eof port)))
 	  (case char
 	    ((#\")
 	     unspecific)
 	    ((#\\)
 	     (let ((char
-		    (let ((char (read-char/no-eof port)))
+		    (let ((char (%read-char/no-eof port)))
 		      (cond ((char-ci=? char #\n) #\newline)
 			    ((char-ci=? char #\t) #\tab)
 			    ((char-ci=? char #\v) #\vt)
@@ -443,21 +445,21 @@ USA.
 			    ((char-ci=? char #\a) #\bel)
 			    ((char->digit char 8) (octal->char char port))
 			    (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)
   (let ((d1 (char->digit c1 8)))
     (if (or (not d1) (fix:> d1 3))
 	(error:illegal-char c1))
-    (let* ((c2 (read-char/no-eof port))
+    (let* ((c2 (%read-char/no-eof port))
 	   (d2 (char->digit c2 8)))
       (if (not d2)
 	  (error:illegal-char c2))
-      (let* ((c3 (read-char/no-eof port))
+      (let* ((c3 (%read-char/no-eof port))
 	     (d3 (char->digit c3 8)))
 	(if (not d3)
 	    (error:illegal-char c3))
@@ -495,10 +497,10 @@ USA.
 
 (define (handler:char port db ctx char1 char2)
   db ctx char1 char2
-  (let ((char (read-char/no-eof port))
+  (let ((char (%read-char/no-eof port))
 	(at-end?
 	 (lambda ()
-	   (let ((char (peek-char port)))
+	   (let ((char (%peek-char port)))
 	     (or (eof-object? char)
 		 (atom-delimiter? char))))))
     (if (or (atom-delimiter? char)
@@ -507,11 +509,11 @@ 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)))
+	       (%write-char (let ((char (%read-char/no-eof port)))
 			     (if (char=? char #\\)
-				 (read-char/no-eof port)
+				 (%read-char/no-eof port)
 				 char))
 			   port*)
 	       (if (not (at-end?))
@@ -535,7 +537,7 @@ USA.
 (define (handler:special-arg port db ctx char1 char2)
   ctx char1
   (let loop ((n (char->digit char2 10)))
-    (let ((char (read-char/no-eof port)))
+    (let ((char (%read-char/no-eof port)))
       (cond ((char-numeric? char)
 	     (loop (+ (* 10 n) (char->digit char 10))))
 	    ((char=? char #\=)
@@ -566,6 +568,16 @@ USA.
 (define non-shared-object
   (list 'NON-SHARED-OBJECT))
 
+(define (%read-char port)
+  (let ((char
+	 (let loop ()
+	   (or (input-port/%read-char port)
+	       (loop))))
+	(op (port/%operation port 'DISCRETIONARY-WRITE-CHAR)))
+    (if op
+	(op char port))
+    char))
+
 (define (read-char port)
   (let ((char
 	 (let loop ()
@@ -576,17 +588,34 @@ USA.
 	(op char port))
     char))
 
+(define (%read-char/no-eof port)
+  (let ((char (%read-char port)))
+    (if (eof-object? char)
+	(error:premature-eof port))
+    char))
+
 (define (read-char/no-eof port)
   (let ((char (read-char port)))
     (if (eof-object? char)
 	(error:premature-eof port))
     char))
 
+(define (%peek-char port)
+  (let loop ()
+    (or (input-port/%peek-char port)
+	(loop))))
+
 (define (peek-char port)
   (let loop ()
     (or (input-port/peek-char port)
 	(loop))))
 
+(define (%peek-char/no-eof port)
+  (let ((char (%peek-char port)))
+    (if (eof-object? char)
+	(error:premature-eof port))
+    char))
+
 (define (peek-char/no-eof port)
   (let ((char (peek-char port)))
     (if (eof-object? char)