From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Tue, 24 Nov 2009 00:58:58 +0000 (-0800)
Subject: Create some accessors that don't check PORT?
X-Git-Tag: 20100708-Gtk~236
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8969184086852497c456bb20b18ddcdefa46b525;p=mit-scheme.git

Create some accessors that don't check PORT?
---

diff --git a/src/runtime/port.scm b/src/runtime/port.scm
index 870d9c003..e5346c433 100644
--- a/src/runtime/port.scm
+++ b/src/runtime/port.scm
@@ -105,13 +105,17 @@ USA.
 		  (list (car entry) (cdr entry)))
 		(port-type/custom-operations type))))
 
-(define (port-type/operation type name)
-  (guarantee-port-type type 'PORT-TYPE/OPERATION)
+;; Assumes type is a PORT-TYPE
+(define (port-type/%operation type name)
   (let ((entry
 	 (or (assq name (port-type/custom-operations type))
 	     (assq name (port-type/standard-operations type)))))
     (and entry
 	 (cdr entry))))
+
+(define (port-type/operation type name)
+  (guarantee-port-type type 'PORT-TYPE/OPERATION)
+  (port-type/%operation type name))
 
 ;;;; Constructors
 
@@ -428,8 +432,12 @@ USA.
 (define (port/operation-names port)
   (port-type/operation-names (port/type port)))
 
+(define-integrable (port/%operation port name)
+  (port-type/%operation (port/%type port) name))
+
 (define (port/operation port name)
-  (port-type/operation (port/type port) name))
+  (guarantee-port port 'port/operation)
+  (port/%operation port name))
 
 (define-syntax define-port-operation
   (sc-macro-transformer
@@ -451,6 +459,20 @@ USA.
 (define-port-operation flush-output)
 (define-port-operation discretionary-flush-output)
 
+;;; These operations assume that the port is in fact a port.
+(define-syntax define-unsafe-port-operation
+  (sc-macro-transformer
+   (lambda (form environment)
+     (let ((name (cadr form)))
+       `(DEFINE-INTEGRABLE (,(symbol-append 'PORT/%OPERATION/ name) PORT)
+	  (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment)
+	   (PORT/%TYPE PORT)))))))
+
+(define-unsafe-port-operation discretionary-flush-output)
+(define-unsafe-port-operation read-char)
+(define-unsafe-port-operation peek-char)
+(define-unsafe-port-operation write-char)
+
 (define (port-position port)
   ((or (port/operation port 'POSITION)
        (error:bad-range-argument port 'PORT-POSITION))
@@ -515,7 +537,7 @@ USA.
        (%input-open? port)))
 
 (define (%input-open? port)
-  (let ((open? (port/operation port 'INPUT-OPEN?)))
+  (let ((open? (port/%operation port 'INPUT-OPEN?)))
     (if open?
 	(open? port)
 	#t)))
@@ -525,7 +547,7 @@ USA.
        (%output-open? port)))
 
 (define (%output-open? port)
-  (let ((open? (port/operation port 'OUTPUT-OPEN?)))
+  (let ((open? (port/%operation port 'OUTPUT-OPEN?)))
     (if open?
 	(open? port)
 	#t)))