From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 Feb 1999 19:44:51 +0000 (+0000)
Subject: Change the port implementation to have a type that holds the
X-Git-Tag: 20090517-FFI~4624
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=790edc025600ab44e03c6e3ddd0916cee8d5755d;p=mit-scheme.git

Change the port implementation to have a type that holds the
operations on the port.  This new implementation supports a crude form
of single inheritance.
---

diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm
index db96ce65f..f43234312 100644
--- a/v7/src/runtime/output.scm
+++ b/v7/src/runtime/output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: output.scm,v 14.18 1999/02/16 00:49:02 cph Exp $
+$Id: output.scm,v 14.19 1999/02/16 19:44:51 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -38,6 +38,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (output-port/write-object port object)
   (unparse-object/top-level object port #t (current-unparser-table)))
 
+(define (output-port/fresh-line port)
+  ((output-port/operation/fresh-line port) port))
+
 (define (output-port/flush-output port)
   ((output-port/operation/flush-output port) port))
 
@@ -48,7 +51,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (or (let ((operation (port/operation port 'X-SIZE)))
 	(and operation
 	     (operation port)))
-      79))
+      80))
 
 (define (output-port/y-size port)
   (let ((operation (port/operation port 'Y-SIZE)))
@@ -70,10 +73,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	 (if (default-object? port)
 	     (current-output-port)
 	     (guarantee-output-port port))))
-    (let ((operation (port/operation port 'FRESH-LINE)))
-      (if operation
-	  (operation port)
-	  (output-port/write-char port #\newline)))
+    (output-port/fresh-line port)
     (output-port/discretionary-flush port)))
 
 (define (write-char char #!optional port)
@@ -104,11 +104,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	      (operation port)
 	      (output-port/discretionary-flush port)))))))
 
-(define beep
-  (wrap-custom-operation-0 'BEEP))
-
-(define clear
-  (wrap-custom-operation-0 'CLEAR))
+(define beep (wrap-custom-operation-0 'BEEP))
+(define clear (wrap-custom-operation-0 'CLEAR))
 
 (define (display object #!optional port unparser-table)
   (let ((port
@@ -145,7 +142,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	 (if (default-object? unparser-table)
 	     (current-unparser-table)
 	     (guarantee-unparser-table unparser-table 'WRITE-LINE))))
-    (output-port/write-char port #\Newline)
+    (output-port/write-char port #\newline)
     (unparse-object/top-level object port #t unparser-table)
     (output-port/discretionary-flush port)))
 
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 806973871..c913da9d3 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.13 1999/02/16 05:17:42 cph Exp $
+$Id: port.scm,v 1.14 1999/02/16 19:43:17 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -24,68 +24,175 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (declare (usual-integrations))
 
-(define port-rtd
-  (make-record-type "port"
-    '(STATE
-      THREAD-MUTEX
-      OPERATION-NAMES
-      CUSTOM-OPERATIONS
-      ;; input operations:
-      CHAR-READY?
-      PEEK-CHAR
-      READ-CHAR
-      DISCARD-CHAR
-      READ-STRING
-      DISCARD-CHARS
-      READ-SUBSTRING
-      ;; output operations:
-      WRITE-CHAR
-      WRITE-SUBSTRING
-      FLUSH-OUTPUT
-      DISCRETIONARY-FLUSH-OUTPUT)))
-
-(define port? (record-predicate port-rtd))
-(define port/state (record-accessor port-rtd 'STATE))
-(define set-port/state! (record-updater port-rtd 'STATE))
-(define port/thread-mutex (record-accessor port-rtd 'THREAD-MUTEX))
-(define set-port/thread-mutex! (record-updater port-rtd 'THREAD-MUTEX))
-(define port/operation-names (record-accessor port-rtd 'OPERATION-NAMES))
-(define set-port/operation-names! (record-updater port-rtd 'OPERATION-NAMES))
-(define port/custom-operations (record-accessor port-rtd 'CUSTOM-OPERATIONS))
-
-(define input-port/operation/char-ready?
-  (record-accessor port-rtd 'CHAR-READY?))
-
-(define input-port/operation/peek-char
-  (record-accessor port-rtd 'PEEK-CHAR))
-
-(define input-port/operation/read-char
-  (record-accessor port-rtd 'READ-CHAR))
-
-(define input-port/operation/discard-char
-  (record-accessor port-rtd 'DISCARD-CHAR))
-
-(define input-port/operation/read-string
-  (record-accessor port-rtd 'READ-STRING))
+(define-structure (port-type (type-descriptor port-type-rtd)
+			     (conc-name port-type/)
+			     (constructor %make-port-type (custom-operations)))
+  custom-operations
+  ;; input operations:
+  (char-ready? #f read-only #t)
+  (peek-char #f read-only #t)
+  (read-char #f read-only #t)
+  (discard-char #f read-only #t)
+  (read-string #f read-only #t)
+  (discard-chars #f read-only #t)
+  (read-substring #f read-only #t)
+  ;; output operations:
+  (write-char #f read-only #t)
+  (write-substring #f read-only #t)
+  (fresh-line #f read-only #t)
+  (flush-output #f read-only #t)
+  (discretionary-flush-output #f read-only #t))
+
+(set-record-type-unparser-method! port-type-rtd
+  (lambda (state type)
+    ((standard-unparser-method
+      (if (port-type/supports-input? type)
+	  (if (port-type/supports-output? type)
+	      'I/O-PORT-TYPE
+	      'INPUT-PORT-TYPE)
+	  (if (port-type/supports-output? type)
+	      'OUTPUT-PORT-TYPE
+	      'PORT-TYPE))
+      #f)
+     state
+     type)))
 
-(define input-port/operation/discard-chars
-  (record-accessor port-rtd 'DISCARD-CHARS))
+(define (guarantee-port-type object procedure)
+  (if (not (port-type? object))
+      (error:wrong-type-argument object "port type" procedure))
+  object)
 
-(define input-port/operation/read-substring
-  (record-accessor port-rtd 'READ-SUBSTRING))
+(define-integrable (port-type/supports-input? type)
+  (port-type/read-char type))
 
-(define output-port/operation/write-char
-  (record-accessor port-rtd 'WRITE-CHAR))
+(define-integrable (port-type/supports-output? type)
+  (port-type/write-char type))
 
-(define output-port/operation/write-substring
-  (record-accessor port-rtd 'WRITE-SUBSTRING))
+(define (input-port-type? object)
+  (and (port-type? object)
+       (port-type/supports-input? object)
+       #t))
 
-(define output-port/operation/flush-output
-  (record-accessor port-rtd 'FLUSH-OUTPUT))
+(define (output-port-type? object)
+  (and (port-type? object)
+       (port-type/supports-output? object)
+       #t))
 
-(define output-port/operation/discretionary-flush
-  (record-accessor port-rtd 'DISCRETIONARY-FLUSH-OUTPUT))
+(define (i/o-port-type? object)
+  (and (port-type? object)
+       (port-type/supports-input? object)
+       (port-type/supports-output? object)
+       #t))
+
+(define input-operation-names
+  '(CHAR-READY?
+    DISCARD-CHAR
+    DISCARD-CHARS
+    PEEK-CHAR
+    READ-CHAR
+    READ-STRING
+    READ-SUBSTRING))
+
+(define input-operation-accessors
+  (map (lambda (name) (record-accessor port-type-rtd name))
+       input-operation-names))
+
+(define input-operation-modifiers
+  (map (lambda (name) (record-modifier port-type-rtd name))
+       input-operation-names))
+
+(define output-operation-names
+  '(DISCRETIONARY-FLUSH-OUTPUT
+    FLUSH-OUTPUT
+    FRESH-LINE
+    WRITE-CHAR
+    WRITE-SUBSTRING))
+
+(define output-operation-accessors
+  (map (lambda (name) (record-accessor port-type-rtd name))
+       output-operation-names))
+
+(define output-operation-modifiers
+  (map (lambda (name) (record-modifier port-type-rtd name))
+       output-operation-names))
+
+(define (port-type/operation-names type)
+  (guarantee-port-type type 'PORT-TYPE/OPERATION-NAMES)
+  (append (if (port-type/supports-input? type) input-operation-names '())
+	  (if (port-type/supports-output? type) output-operation-names '())
+	  (map car (port-type/custom-operations type))))
+
+(define (port-type/operations type)
+  (guarantee-port-type type 'PORT-TYPE/OPERATIONS)
+  (append (if (port-type/supports-input? type)
+	      (map (lambda (name accessor)
+		     (list name (accessor type)))
+		   input-operation-names
+		   input-operation-accessors)
+	      '())
+	  (if (port-type/supports-output? type)
+	      (map (lambda (name accessor)
+		     (list name (accessor type)))
+		   output-operation-names
+		   output-operation-accessors)
+	      '())
+	  (map (lambda (entry)
+		 (list (car entry) (cdr entry)))
+	       (port-type/custom-operations type))))
+
+(define (port-type/operation type name)
+  (guarantee-port-type type 'PORT-TYPE/OPERATION)
+  ;; Optimized for custom operations, since standard operations will
+  ;; usually be accessed directly.
+  (let ((entry (assq name (port-type/custom-operations type))))
+    (if entry
+	(cdr entry)
+	(let ((accessor
+	       (letrec ((loop
+			 (lambda (names accessors)
+			   (and (pair? names)
+				(if (eq? name (car names))
+				    (car accessors)
+				    (loop (cdr names) (cdr accessors)))))))
+		 (or (and (port-type/supports-input? type)
+			  (loop input-operation-names
+				input-operation-accessors))
+		     (and (port-type/supports-output? type)
+			  (loop output-operation-names
+				output-operation-accessors))))))
+	  (and accessor
+	       (accessor type))))))
 
+(define port-rtd (make-record-type "port" '(TYPE STATE THREAD-MUTEX)))
+(define port? (record-predicate port-rtd))
+(define port/type (record-accessor port-rtd 'TYPE))
+(define port/state (record-accessor port-rtd 'STATE))
+(define set-port/state! (record-modifier port-rtd 'STATE))
+(define port/thread-mutex (record-accessor port-rtd 'THREAD-MUTEX))
+(define set-port/thread-mutex! (record-modifier port-rtd 'THREAD-MUTEX))
+
+(define (port/operation-names port)
+  (port-type/operation-names (port/type port)))
+
+(let-syntax ((define-port-operation
+	       (lambda (dir name)
+		 `(DEFINE (,(symbol-append dir '-PORT/OPERATION/ name) PORT)
+		    (,(symbol-append 'PORT-TYPE/ name) (PORT/TYPE PORT))))))
+  (define-port-operation input char-ready?)
+  (define-port-operation input peek-char)
+  (define-port-operation input read-char)
+  (define-port-operation input discard-char)
+  (define-port-operation input read-string)
+  (define-port-operation input discard-chars)
+  (define-port-operation input read-substring)
+  (define-port-operation output write-char)
+  (define-port-operation output write-substring)
+  (define-port-operation output fresh-line)
+  (define-port-operation output flush-output))
+
+(define (output-port/operation/discretionary-flush port)
+  (port-type/discretionary-flush-output (port/type port)))
+
 (set-record-type-unparser-method! port-rtd
   (lambda (state port)
     ((let ((name
@@ -110,36 +217,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (set-port/thread-mutex! port (make-thread-mutex))
     port))
 
-(define (port/operation port name)
-  ;; Optimized for custom operations, since standard operations will
-  ;; usually be accessed directly.
-  (let ((entry (assq name (port/custom-operations port))))
-    (if entry
-	(cdr entry)
-	(case name
-	  ((CHAR-READY?) (input-port/operation/char-ready? port))
-	  ((PEEK-CHAR) (input-port/operation/peek-char port))
-	  ((READ-CHAR) (input-port/operation/read-char port))
-	  ((DISCARD-CHAR) (input-port/operation/discard-char port))
-	  ((READ-STRING) (input-port/operation/read-string port))
-	  ((DISCARD-CHARS) (input-port/operation/discard-chars port))
-	  ((READ-SUBSTRING) (input-port/operation/read-substring port))
-	  ((WRITE-CHAR) (output-port/operation/write-char port))
-	  ((WRITE-SUBSTRING) (output-port/operation/write-substring port))
-	  ((FLUSH-OUTPUT) (output-port/operation/flush-output port))
-	  ((DISCRETIONARY-FLUSH-OUTPUT)
-	   (output-port/operation/discretionary-flush port))
-	  (else false)))))
-
-(define ((closer name) port)
-  (let ((operation (port/operation port name)))
-    (if operation
-	(operation port))))
-
-(define close-port (closer 'CLOSE))
-(define close-input-port (closer 'CLOSE-INPUT))
-(define close-output-port (closer 'CLOSE-OUTPUT))
-
+(define (close-port port)
+  (let ((close (port/operation port 'CLOSE)))
+    (if close
+	(close port)
+	(begin
+	  (close-output-port port)
+	  (close-input-port port)))))
+
+(define (close-input-port port)
+  (let ((close-input (port/operation port 'CLOSE-INPUT)))
+    (if close-input
+	(close-input port))))
+
+(define (close-output-port port)
+  (let ((close-output (port/operation port 'CLOSE-OUTPUT)))
+    (if close-output
+	(close-output port))))
+
 (define (port/input-channel port)
   (let ((operation (port/operation port 'INPUT-CHANNEL)))
     (and operation
@@ -150,18 +245,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (and operation
 	 (operation port))))
 
-;; These names for upwards compatibility:
-(define input-port/channel port/input-channel)
-(define input-port/copy port/copy)
-(define input-port/operation-names port/operation-names)
-(define input-port/state port/state)
-(define set-input-port/state! set-port/state!)
-(define output-port/channel port/output-channel)
-(define output-port/copy port/copy)
-(define output-port/operation-names port/operation-names)
-(define output-port/state port/state)
-(define set-output-port/state! set-port/state!)
-
+(define (port/operation port name)
+  (port-type/operation (port/type port) name))
+
 (define (input-port/operation port name)
   (port/operation port
 		  (case name
@@ -180,24 +266,19 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		    ((CHANNEL) 'OUTPUT-CHANNEL)
 		    (else name))))
 
-(define input-port/custom-operation input-port/operation)
-(define output-port/custom-operation output-port/operation)
-
 (define (input-port? object)
   (and (port? object)
-       (input-port/operation/read-char object)
-       #t))
+       (port-type/supports-input? (port/type object))))
 
 (define (output-port? object)
   (and (port? object)
-       (output-port/operation/write-char object)
-       #t))
+       (port-type/supports-output? (port/type object))))
 
 (define (i/o-port? object)
   (and (port? object)
-       (input-port/operation/read-char object)
-       (output-port/operation/write-char object)
-       #t))
+       (let ((type (port/type object)))
+	 (and (port-type/supports-input? type)
+	      (port-type/supports-output? type)))))
 
 (define (guarantee-input-port port)
   (if (not (input-port? port))
@@ -216,205 +297,191 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 ;;;; Constructors
 
-(define (make-input-port operations state)
-  (make-port operations state 'MAKE-INPUT-PORT true false))
+(define (make-input-port type state)
+  (make-port (if (port-type? type) type (make-input-port-type type #f)) state))
 
-(define (make-output-port operations state)
-  (make-port operations state 'MAKE-OUTPUT-PORT false true))
+(define (make-output-port type state)
+  (make-port (if (port-type? type) type (make-output-port-type type #f))
+	     state))
 
-(define (make-i/o-port operations state)
-  (make-port operations state 'MAKE-I/O-PORT true true))
+(define (make-i/o-port type state)
+  (make-port (if (port-type? type) type (make-i/o-port-type type #f)) state))
 
 (define make-port
-  (let ((constructor
-	 (record-constructor
-	  port-rtd
-	  '(STATE THREAD-MUTEX OPERATION-NAMES CUSTOM-OPERATIONS))))
-    (lambda (operations state procedure-name input? output?)
-      (let ((port
-	     (constructor state
-			  (make-thread-mutex)
-			  '()
-			  (parse-operations-list operations procedure-name))))
-	(install-input-operations! port input?)
-	(install-output-operations! port output?)
-	(set-port/operation-names! port
-				   (map* (port/operation-names port)
-					 car
-					 (port/custom-operations port)))
-	port))))
+  (let ((constructor (record-constructor port-rtd '(TYPE STATE THREAD-MUTEX))))
+    (lambda (type state)
+      (guarantee-port-type type 'MAKE-PORT)
+      (constructor type state (make-thread-mutex)))))
+
+(define (make-input-port-type operations type)
+  (operations->port-type operations type 'MAKE-INPUT-PORT-TYPE #t #f))
+
+(define (make-output-port-type operations type)
+  (operations->port-type operations type 'MAKE-OUTPUT-PORT-TYPE #f #t))
+
+(define (make-i/o-port-type operations type)
+  (operations->port-type operations type 'MAKE-I/O-PORT-TYPE #t #t))
+
+(define (operations->port-type operations type procedure-name input? output?)
+  (let ((type
+	 (parse-operations-list
+	  (append operations
+		  (if type
+		      (list-transform-negative (port-type/operations type)
+			(lambda (entry)
+			  (assq (car entry) operations)))
+		      '()))
+	  procedure-name)))
+    (install-operations! type input?
+			 input-operation-names
+			 input-operation-modifiers
+			 input-operation-defaults)
+    (install-operations! type output?
+			 output-operation-names
+			 output-operation-modifiers
+			 output-operation-defaults)
+    type))
 
 (define (parse-operations-list operations procedure)
   (if (not (list? operations))
       (error:wrong-type-argument operations "list" procedure))
-  (map (lambda (operation)
-	 (if (not (and (pair? operation)
-		       (symbol? (car operation))
-		       (pair? (cdr operation))
-		       (procedure? (cadr operation))
-		       (null? (cddr operation))))
-	     (error:wrong-type-argument operation "port operation" procedure))
-	 (cons (car operation) (cadr operation)))
-       operations))
+  (%make-port-type
+   (map (lambda (operation)
+	  (if (not (and (pair? operation)
+			(symbol? (car operation))
+			(pair? (cdr operation))
+			(procedure? (cadr operation))
+			(null? (cddr operation))))
+	      (error:wrong-type-argument operation "port operation" procedure))
+	  (cons (car operation) (cadr operation)))
+	operations)))
+
+(define (install-operations! type install? names modifiers defaults)
+  (if install?
+      (let* ((operations
+	      (map (lambda (name)
+		     (extract-operation! type name))
+		   names))
+	     (defaults (defaults names operations)))
+	(for-each (lambda (modifier operation name)
+		    (modifier
+		     type
+		     (or operation
+			 (let ((entry (assq name defaults)))
+			   (if (not entry)
+			       (error "Must specify operation:" name))
+			   (cadr entry)))))
+		  modifiers
+		  operations
+		  names))
+      (begin
+	(for-each (lambda (name)
+		    (if (extract-operation! type name)
+			(error "Illegal operation name:" name)))
+		  names)
+	(for-each (lambda (modifier)
+		    (modifier type #f))
+		  modifiers))))
 
 (define extract-operation!
-  (let ((updater (record-updater port-rtd 'CUSTOM-OPERATIONS)))
-    (lambda (port name)
-      (let ((operations (port/custom-operations port)))
-	(let ((operation (assq name operations)))
-	  (and operation
-	       (begin
-		 (updater port (delq! operation operations))
-		 (cdr operation))))))))
-
-;;;; Input Operations
-
-(define install-input-operations!
-  (let ((operation-names
-	 '(CHAR-READY? PEEK-CHAR READ-CHAR
-		       DISCARD-CHAR READ-STRING DISCARD-CHARS READ-SUBSTRING)))
-    (let ((updaters
-	   (map (lambda (name)
-		  (record-updater port-rtd name))
-		operation-names)))
-      (lambda (port install?)
-	(if install?
-	    (let ((operations
-		   (map (lambda (name)
-			  (extract-operation! port name))
-			operation-names)))
-	      (for-each (lambda (updater operation default name)
-			  (updater
-			   port
-			   (or operation
-			       default
-			       (error "Must specify operation:" name))))
-			updaters
-			operations
-			(list default-operation/char-ready?
-			      false
-			      false
-			      (caddr operations)
-			      default-operation/read-string
-			      default-operation/discard-chars
-			      default-operation/read-substring)
-			operation-names)
-	      (set-port/operation-names!
-	       port
-	       (append operation-names (port/operation-names port))))
-	    (begin
-	      (for-each (lambda (name)
-			  (if (extract-operation! port name)
-			      (error "Illegal operation name:" name)))
-			operation-names)
-	      (for-each (lambda (updater)
-			  (updater port false))
-			updaters)))))))
+  (let ((set-port-type/custom-operations!
+	 (record-modifier port-type-rtd 'CUSTOM-OPERATIONS)))
+    (lambda (type name)
+      (let ((operation (assq name (port-type/custom-operations type))))
+	(and operation
+	     (begin
+	       (set-port-type/custom-operations!
+		type
+		(delq! operation (port-type/custom-operations type)))
+	       (cdr operation)))))))
+
+(define (search-paired-lists key keys datums error?)
+  (if (pair? keys)
+      (if (eq? key (car keys))
+	  (car datums)
+	  (search-paired-lists key (cdr keys) (cdr datums) error?))
+      (and error?
+	   (error "Unable to find key:" key))))
 
+;;;; Default Operations
+
+(define (input-operation-defaults names operations)
+  `((CHAR-READY? ,default-operation/char-ready?)
+    (DISCARD-CHAR ,(search-paired-lists 'READ-CHAR names operations #t))
+    (DISCARD-CHARS ,default-operation/discard-chars)
+    (READ-STRING ,default-operation/read-string)
+    (READ-SUBSTRING ,default-operation/read-substring)))
+
 (define (default-operation/char-ready? port interval)
   port interval
-  true)
+  #t)
 
 (define (default-operation/read-string port delimiters)
-  (let ((peek-char (input-port/operation/peek-char port))
-	(discard-char (input-port/operation/discard-char port)))
-    (let ((peek-char (lambda () (let loop () (or (peek-char port) (loop))))))
-      (let ((char (peek-char)))
-	(if (eof-object? char)
-	    char
-	    (list->string
-	     (let loop ((char char))
-	       (if (or (eof-object? char)
-		       (char-set-member? delimiters char))
-		   '()
-		   (begin
-		     (discard-char port)
-		     (cons char (loop (peek-char))))))))))))
+  (let ((peek-char
+	 (lambda () (let loop () (or (input-port/peek-char port) (loop))))))
+    (let ((char (peek-char)))
+      (if (eof-object? char)
+	  char
+	  (list->string
+	   (let loop ((char char))
+	     (if (or (eof-object? char)
+		     (char-set-member? delimiters char))
+		 '()
+		 (begin
+		   (input-port/discard-char port)
+		   (cons char (loop (peek-char)))))))))))
 
 (define (default-operation/discard-chars port delimiters)
-  (let ((peek-char (input-port/operation/peek-char port))
-	(discard-char (input-port/operation/discard-char port)))
-    (let loop ()
-      (let ((char
-	     (let loop ()
-	       (or (peek-char port)
-		   (loop)))))
-	(if (not (or (eof-object? char)
-		     (char-set-member? delimiters char)))
-	    (begin
-	      (discard-char port)
-	      (loop)))))))
+  (let loop ()
+    (let ((char (let loop () (or (input-port/peek-char port) (loop)))))
+      (if (not (or (eof-object? char)
+		   (char-set-member? delimiters char)))
+	  (begin
+	    (input-port/discard-char port)
+	    (loop))))))
 
 (define (default-operation/read-substring port string start end)
-  (let ((read-char (input-port/operation/read-char port)))
-    (let loop ((index start))
-      (if (fix:< index end)
-	  (let ((char (read-char port)))
-	    (cond ((not char)
-		   (if (fix:= index start)
-		       #f
-		       (fix:- index start)))
-		  ((eof-object? char)
-		   (fix:- index start))
-		  (else
-		   (string-set! string index char)
-		   (loop (fix:+ index 1)))))
-	  (fix:- index start)))))
-
-;;;; Output Operations
+  (let loop ((index start))
+    (if (fix:< index end)
+	(let ((char (input-port/read-char port)))
+	  (cond ((not char)
+		 (if (fix:= index start)
+		     #f
+		     (fix:- index start)))
+		((eof-object? char)
+		 (fix:- index start))
+		(else
+		 (string-set! string index char)
+		 (loop (fix:+ index 1)))))
+	(fix:- index start))))
+
+(define (output-operation-defaults names operations)
+  (if (not (or (search-paired-lists 'WRITE-CHAR names operations #f)
+	       (search-paired-lists 'WRITE-SUBSTRING names operations #f)))
+      (error "Must specify at least one of the following:"
+	     '(WRITE-CHAR WRITE-SUBSTRING)))
+  `((DISCRETIONARY-FLUSH-OUTPUT ,default-operation/flush-output)
+    (FLUSH-OUTPUT ,default-operation/flush-output)
+    (FRESH-LINE ,default-operation/fresh-line)
+    (WRITE-CHAR ,default-operation/write-char)
+    (WRITE-SUBSTRING ,default-operation/write-substring)))
 
 (define (default-operation/write-char port char)
-  ((output-port/operation/write-substring port) port (string char) 0 1))
+  (output-port/write-substring port (string char) 0 1))
 
 (define (default-operation/write-substring port string start end)
-  (let ((write-char (output-port/operation/write-char port)))
-    (let loop ((index start))
-      (if (< index end)
-	  (begin
-	    (write-char port (string-ref string index))
-	    (loop (+ index 1)))))))
+  (let loop ((index start))
+    (if (< index end)
+	(begin
+	  (output-port/write-char port (string-ref string index))
+	  (loop (+ index 1))))))
+
+(define (default-operation/fresh-line port)
+  (output-port/write-char port #\newline))
 
 (define (default-operation/flush-output port)
   port
   unspecific)
-
-(define install-output-operations!
-  (let ((operation-names
-	 '(WRITE-CHAR WRITE-SUBSTRING FLUSH-OUTPUT DISCRETIONARY-FLUSH-OUTPUT))
-	(operation-defaults
-	 (list default-operation/write-char
-	       default-operation/write-substring
-	       default-operation/flush-output
-	       default-operation/flush-output)))
-    (let ((updaters
-	   (map (lambda (name)
-		  (record-updater port-rtd name))
-		operation-names)))
-      (lambda (port install?)
-	(if install?
-	    (let ((operations
-		   (map (lambda (name)
-			  (extract-operation! port name))
-			operation-names)))
-	      (if (not (or (car operations) (cadr operations)))
-		  (error "Must specify at least one of the following:"
-			 '(WRITE-CHAR WRITE-SUBSTRING)))
-	      (for-each (lambda (updater operation default)
-			  (updater port (or operation default)))
-			updaters
-			operations
-			operation-defaults)
-	      (set-port/operation-names! port
-					 (append operation-names
-						 (port/operation-names port))))
-	    (begin
-	      (for-each (lambda (name)
-			  (if (extract-operation! port name)
-			      (error "Illegal operation name:" name)))
-			operation-names)
-	      (for-each (lambda (updater)
-			  (updater port false))
-			updaters)))))))
 
 ;;;; Special Operations
 
@@ -422,7 +489,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((operation (port/operation port 'INPUT-BLOCKING-MODE)))
     (if operation
 	(operation port)
-	false)))
+	#f)))
 
 (define (port/set-input-blocking-mode port mode)
   (let ((operation (port/operation port 'SET-INPUT-BLOCKING-MODE)))
@@ -436,7 +503,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((operation (port/operation port 'OUTPUT-BLOCKING-MODE)))
     (if operation
 	(operation port)
-	false)))
+	#f)))
 
 (define (port/set-output-blocking-mode port mode)
   (let ((operation (port/operation port 'SET-OUTPUT-BLOCKING-MODE)))
@@ -450,7 +517,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((operation (port/operation port 'INPUT-TERMINAL-MODE)))
     (if operation
 	(operation port)
-	false)))
+	#f)))
 
 (define (port/set-input-terminal-mode port mode)
   (let ((operation (port/operation port 'SET-INPUT-TERMINAL-MODE)))
@@ -464,7 +531,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (let ((operation (port/operation port 'OUTPUT-TERMINAL-MODE)))
     (if operation
 	(operation port)
-	false)))
+	#f)))
 
 (define (port/set-output-terminal-mode port mode)
   (let ((operation (port/operation port 'SET-OUTPUT-TERMINAL-MODE)))
@@ -556,4 +623,19 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	(cons current-output-port set-current-output-port!)
 	(cons notification-output-port set-notification-output-port!)
 	(cons trace-output-port set-trace-output-port!)
-	(cons interaction-i/o-port set-interaction-i/o-port!)))
\ No newline at end of file
+	(cons interaction-i/o-port set-interaction-i/o-port!)))
+
+;;;; Upwards Compatibility
+
+(define input-port/channel port/input-channel)
+(define input-port/copy port/copy)
+(define input-port/custom-operation input-port/operation)
+(define input-port/operation-names port/operation-names)
+(define input-port/state port/state)
+(define output-port/channel port/output-channel)
+(define output-port/copy port/copy)
+(define output-port/custom-operation output-port/operation)
+(define output-port/operation-names port/operation-names)
+(define output-port/state port/state)
+(define set-input-port/state! set-port/state!)
+(define set-output-port/state! set-port/state!)
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4322192a6..0205a13be 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.311 1999/02/16 18:48:29 cph Exp $
+$Id: runtime.pkg,v 14.312 1999/02/16 19:44:12 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -1096,7 +1096,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  guarantee-i/o-port
 	  guarantee-input-port
 	  guarantee-output-port
+	  guarantee-port-type
+	  i/o-port-type?
 	  i/o-port?
+	  input-port-type?
 	  input-port/channel
 	  input-port/copy
 	  input-port/custom-operation
@@ -1106,9 +1109,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  input-port?
 	  interaction-i/o-port
 	  make-i/o-port
+	  make-i/o-port-type
 	  make-input-port
+	  make-input-port-type
 	  make-output-port
+	  make-output-port-type
 	  notification-output-port
+	  output-port-type?
 	  output-port/channel
 	  output-port/copy
 	  output-port/custom-operation
@@ -1116,6 +1123,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  output-port/operation-names
 	  output-port/state
 	  output-port?
+	  port-type/operation
+	  port-type/operation-names
+	  port-type/operations
+	  port-type?
 	  port/copy
 	  port/input-blocking-mode
 	  port/input-channel
@@ -1131,6 +1142,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  port/set-output-terminal-mode
 	  port/state
 	  port/thread-mutex
+	  port/type
 	  port/with-input-blocking-mode
 	  port/with-input-terminal-mode
 	  port/with-output-blocking-mode
@@ -1161,6 +1173,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (export (runtime output-port)
 	  output-port/operation/discretionary-flush
 	  output-port/operation/flush-output
+	  output-port/operation/fresh-line
 	  output-port/operation/write-char
 	  output-port/operation/write-substring)
   (export (runtime rep)
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 3601215b3..e6278a3d4 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.316 1999/02/16 18:48:36 cph Exp $
+$Id: runtime.pkg,v 14.317 1999/02/16 19:43:54 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -1100,7 +1100,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  guarantee-i/o-port
 	  guarantee-input-port
 	  guarantee-output-port
+	  guarantee-port-type
+	  i/o-port-type?
 	  i/o-port?
+	  input-port-type?
 	  input-port/channel
 	  input-port/copy
 	  input-port/custom-operation
@@ -1110,9 +1113,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  input-port?
 	  interaction-i/o-port
 	  make-i/o-port
+	  make-i/o-port-type
 	  make-input-port
+	  make-input-port-type
 	  make-output-port
+	  make-output-port-type
 	  notification-output-port
+	  output-port-type?
 	  output-port/channel
 	  output-port/copy
 	  output-port/custom-operation
@@ -1120,6 +1127,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  output-port/operation-names
 	  output-port/state
 	  output-port?
+	  port-type/operation
+	  port-type/operation-names
+	  port-type/operations
+	  port-type?
 	  port/copy
 	  port/input-blocking-mode
 	  port/input-channel
@@ -1135,6 +1146,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  port/set-output-terminal-mode
 	  port/state
 	  port/thread-mutex
+	  port/type
 	  port/with-input-blocking-mode
 	  port/with-input-terminal-mode
 	  port/with-output-blocking-mode
@@ -1165,6 +1177,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (export (runtime output-port)
 	  output-port/operation/discretionary-flush
 	  output-port/operation/flush-output
+	  output-port/operation/fresh-line
 	  output-port/operation/write-char
 	  output-port/operation/write-substring)
   (export (runtime rep)