From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Feb 1999 21:37:22 +0000 (+0000)
Subject: Merge different port-type constructors into MAKE-PORT-TYPE.
X-Git-Tag: 20090517-FFI~4602
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=08b05b24d6e2488c11fb03598526ba0701e834e3;p=mit-scheme.git

Merge different port-type constructors into MAKE-PORT-TYPE.
---

diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm
index 055cf4a55..6588b8891 100644
--- a/v7/src/edwin/artdebug.scm
+++ b/v7/src/edwin/artdebug.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: artdebug.scm,v 1.27 1999/02/16 20:12:15 cph Exp $
+;;; $Id: artdebug.scm,v 1.28 1999/02/24 21:35:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -1346,7 +1346,7 @@ Prefix argument means do not kill the debugger buffer."
   (prompt-for-confirmation? prompt))
 
 (define interface-port-type
-  (make-output-port-type
+  (make-port-type
    `((WRITE-CHAR ,operation/write-char)
      (WRITE-SUBSTRING ,operation/write-substring)
      (FRESH-LINE ,operation/fresh-line)
diff --git a/v7/src/edwin/bufinp.scm b/v7/src/edwin/bufinp.scm
index ba9ff49ff..3bceda854 100644
--- a/v7/src/edwin/bufinp.scm
+++ b/v7/src/edwin/bufinp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;$Id: bufinp.scm,v 1.7 1999/02/18 04:14:41 cph Exp $
+;;;$Id: bufinp.scm,v 1.8 1999/02/24 21:35:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -123,11 +123,11 @@
 		(buffer-input-port-state/current-index state)))))
 
 (define buffer-input-port-type
-  (make-input-port-type `((CHAR-READY? ,operation/char-ready?)
-			  (DISCARD-CHAR ,operation/discard-char)
-			  (DISCARD-CHARS ,operation/discard-chars)
-			  (PEEK-CHAR ,operation/peek-char)
-			  (PRINT-SELF ,operation/print-self)
-			  (READ-CHAR ,operation/read-char)
-			  (READ-STRING ,operation/read-string))
-			#f))
\ No newline at end of file
+  (make-port-type `((CHAR-READY? ,operation/char-ready?)
+		    (DISCARD-CHAR ,operation/discard-char)
+		    (DISCARD-CHARS ,operation/discard-chars)
+		    (PEEK-CHAR ,operation/peek-char)
+		    (PRINT-SELF ,operation/print-self)
+		    (READ-CHAR ,operation/read-char)
+		    (READ-STRING ,operation/read-string))
+		  #f))
\ No newline at end of file
diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm
index f4736e14f..3fe2dedde 100644
--- a/v7/src/edwin/bufout.scm
+++ b/v7/src/edwin/bufout.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: bufout.scm,v 1.12 1999/02/16 20:12:28 cph Exp $
+;;; $Id: bufout.scm,v 1.13 1999/02/24 21:35:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -82,11 +82,11 @@
   (mark-x-size (port/mark port)))
 
 (define mark-output-port-type
-  (make-output-port-type `((CLOSE ,operation/close)
-			   (FLUSH-OUTPUT ,operation/flush-output)
-			   (FRESH-LINE ,operation/fresh-line)
-			   (PRINT-SELF ,operation/print-self)
-			   (WRITE-CHAR ,operation/write-char)
-			   (WRITE-SUBSTRING ,operation/write-substring)
-			   (X-SIZE ,operation/x-size))
-			 #f))
\ No newline at end of file
+  (make-port-type `((CLOSE ,operation/close)
+		    (FLUSH-OUTPUT ,operation/flush-output)
+		    (FRESH-LINE ,operation/fresh-line)
+		    (PRINT-SELF ,operation/print-self)
+		    (WRITE-CHAR ,operation/write-char)
+		    (WRITE-SUBSTRING ,operation/write-substring)
+		    (X-SIZE ,operation/x-size))
+		  #f))
\ No newline at end of file
diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm
index 0e6511e4c..c7f8a144f 100644
--- a/v7/src/edwin/debug.scm
+++ b/v7/src/edwin/debug.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: debug.scm,v 1.47 1999/02/16 20:12:04 cph Exp $
+;;; $Id: debug.scm,v 1.48 1999/02/24 21:36:02 cph Exp $
 ;;;
 ;;; Copyright (c) 1992-1999 Massachusetts Institute of Technology
 ;;;
@@ -1895,7 +1895,7 @@ once it has been renamed, it will not be deleted automatically.")
   (prompt-for-expression prompt))
 
 (define interface-port-type
-  (make-output-port-type
+  (make-port-type
    `((WRITE-CHAR ,operation/write-char)
      (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
      (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression))
diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm
index 35b61099b..83c8f9b5b 100644
--- a/v7/src/edwin/intmod.scm
+++ b/v7/src/edwin/intmod.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: intmod.scm,v 1.97 1999/02/18 04:05:22 cph Exp $
+;;; $Id: intmod.scm,v 1.98 1999/02/24 21:35:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -1052,7 +1052,7 @@ If this is an error, the debugger examines the error condition."
       #t)))
 
 (define interface-port-type
-  (make-i/o-port-type
+  (make-port-type
    `((WRITE-CHAR ,operation/write-char)
      (WRITE-SUBSTRING ,operation/write-substring)
      (FRESH-LINE ,operation/fresh-line)
diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm
index ae561be00..d2a77b121 100644
--- a/v7/src/edwin/winout.scm
+++ b/v7/src/edwin/winout.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;$Id: winout.scm,v 1.12 1999/02/16 20:12:09 cph Exp $
+;;;$Id: winout.scm,v 1.13 1999/02/24 21:35:58 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
 ;;;
@@ -97,10 +97,10 @@
   (unparse-object state (port/state port)))
 
 (define window-output-port-type
-  (make-output-port-type `((FLUSH-OUTPUT ,operation/flush-output)
-			   (FRESH-LINE ,operation/fresh-line)
-			   (PRINT-SELF ,operation/print-self)
-			   (WRITE-CHAR ,operation/write-char)
-			   (WRITE-SUBSTRING ,operation/write-substring)
-			   (X-SIZE ,operation/x-size))
-			 #f))
\ No newline at end of file
+  (make-port-type `((FLUSH-OUTPUT ,operation/flush-output)
+		    (FRESH-LINE ,operation/fresh-line)
+		    (PRINT-SELF ,operation/print-self)
+		    (WRITE-CHAR ,operation/write-char)
+		    (WRITE-SUBSTRING ,operation/write-substring)
+		    (X-SIZE ,operation/x-size))
+		  #f))
\ No newline at end of file
diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm
index f3fe70188..556d86541 100644
--- a/v7/src/runtime/emacs.scm
+++ b/v7/src/runtime/emacs.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: emacs.scm,v 14.25 1999/02/16 20:30:54 cph Exp $
+$Id: emacs.scm,v 14.26 1999/02/24 21:36:13 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -209,7 +209,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (initialize-package!)
   (set! emacs-console-port
-	(make-port (make-i/o-port-type
+	(make-port (make-port-type
 		    `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression)
 		      (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char)
 		      (PROMPT-FOR-COMMAND-EXPRESSION
diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm
index 61738febd..4286cde9b 100644
--- a/v7/src/runtime/fileio.scm
+++ b/v7/src/runtime/fileio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fileio.scm,v 1.16 1999/02/16 20:11:34 cph Exp $
+$Id: fileio.scm,v 1.17 1999/02/24 21:36:17 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -33,16 +33,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	   (PATHNAME ,operation/pathname)
 	   (TRUENAME ,operation/truename))))
     (set! input-file-type
-	  (make-input-port-type (append input-operations
-					other-operations)
-				generic-input-type))
+	  (make-port-type (append input-operations other-operations)
+			  generic-input-type))
     (set! output-file-type
-	  (make-output-port-type other-operations
-				 generic-output-type))
+	  (make-port-type other-operations
+			  generic-output-type))
     (set! i/o-file-type
-	  (make-i/o-port-type (append input-operations
-				      other-operations)
-			      generic-i/o-type)))
+	  (make-port-type (append input-operations other-operations)
+			  generic-i/o-type)))
   unspecific)
 
 (define input-file-type)
diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm
index 276d12c30..9991dee3a 100644
--- a/v7/src/runtime/genio.scm
+++ b/v7/src/runtime/genio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: genio.scm,v 1.14 1999/02/16 20:11:38 cph Exp $
+$Id: genio.scm,v 1.15 1999/02/24 21:36:33 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -64,18 +64,18 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	 `((CLOSE ,operation/close)
 	   (WRITE-SELF ,operation/write-self))))
     (set! generic-input-type
-	  (make-input-port-type (append input-operations
-					other-operations)
-				#f))
+	  (make-port-type (append input-operations
+				  other-operations)
+			  #f))
     (set! generic-output-type
-	  (make-output-port-type (append output-operations
-					 other-operations)
-				 #f))
+	  (make-port-type (append output-operations
+				  other-operations)
+			  #f))
     (set! generic-i/o-type
-	  (make-i/o-port-type (append input-operations
-				      output-operations
-				      other-operations)
-			      #f)))
+	  (make-port-type (append input-operations
+				  output-operations
+				  other-operations)
+			  #f)))
   unspecific)
 
 (define generic-input-type)
diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm
index 4565eb61d..ff8cb9fbe 100644
--- a/v7/src/runtime/port.scm
+++ b/v7/src/runtime/port.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: port.scm,v 1.16 1999/02/18 03:54:03 cph Exp $
+$Id: port.scm,v 1.17 1999/02/24 21:36:37 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -345,11 +345,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define (make-encapsulated-port port state rewrite-operation)
   (guarantee-port port)
   (%make-port (let ((type (port/type port)))
-		((if (port-type/supports-input? type)
-		     (if (port-type/supports-output? type)
-			 make-i/o-port-type
-			 make-input-port-type)
-		     make-output-port-type)
+		(make-port-type
 		 (append-map
 		  (lambda (entry)
 		    (let ((operation
@@ -364,61 +360,48 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 ;;;; Constructors
 
-(define (make-input-port type state)
-  (make-port (if (port-type? type) type (make-input-port-type type #f)) state))
-
-(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 type state)
-  (make-port (if (port-type? type) type (make-i/o-port-type type #f)) state))
-
 (define (make-port type state)
   (guarantee-port-type type 'MAKE-PORT)
   (%make-port 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?)
+(define (make-port-type operations type)
   (let ((type
 	 (parse-operations-list
 	  (append operations
 		  (if type
 		      (list-transform-negative (port-type/operations type)
 			(let ((ignored
-			       (append (if (assq 'READ-CHAR operations)
-					   '(DISCARD-CHAR
-					     DISCARD-CHARS
-					     PEEK-CHAR
-					     READ-CHAR
-					     READ-STRING
-					     READ-SUBSTRING)
-					   '())
-				       (if (assq 'WRITE-CHAR operations)
-					   '(WRITE-CHAR
-					     WRITE-SUBSTRING)
-					   '()))))
+			       (append
+				(if (assq 'READ-CHAR operations)
+				    '(DISCARD-CHAR
+				      DISCARD-CHARS
+				      PEEK-CHAR
+				      READ-CHAR
+				      READ-STRING
+				      READ-SUBSTRING)
+				    '())
+				(if (or (assq 'WRITE-CHAR operations)
+					(assq 'WRITE-SUBSTRING operations))
+				    '(WRITE-CHAR
+				      WRITE-SUBSTRING)
+				    '()))))
 			  (lambda (entry)
 			    (or (assq (car entry) operations)
 				(memq (car entry) ignored)))))
 		      '()))
-	  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)
+	  'MAKE-PORT-TYPE)))
+    (let ((operations (port-type/operations type)))
+      (install-operations! type
+			   (assq 'READ-CHAR operations)
+			   input-operation-names
+			   input-operation-modifiers
+			   input-operation-defaults)
+      (install-operations! type
+			   (or (assq 'WRITE-CHAR operations)
+			       (assq 'WRITE-SUBSTRING operations))
+			   output-operation-names
+			   output-operation-modifiers
+			   output-operation-defaults))
     type))
 
 (define (parse-operations-list operations procedure)
@@ -717,4 +700,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (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
+(define set-output-port/state! set-port/state!)
+
+(define (make-input-port type state)
+  (make-port (if (port-type? type) type (make-port-type type #f)) state))
+
+(define make-output-port make-input-port)
+(define make-i/o-port make-input-port)
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 13a6a53b8..2e72c06c3 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.319 1999/02/24 21:23:58 cph Exp $
+$Id: runtime.pkg,v 14.320 1999/02/24 21:37:18 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -1070,12 +1070,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  interaction-i/o-port
 	  make-encapsulated-port
 	  make-i/o-port
-	  make-i/o-port-type
 	  make-input-port
-	  make-input-port-type
 	  make-output-port
-	  make-output-port-type
 	  make-port
+	  make-port-type
 	  notification-output-port
 	  output-port-type?
 	  output-port/channel
diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm
index 536bf328a..5c84cef1c 100644
--- a/v7/src/runtime/strnin.scm
+++ b/v7/src/runtime/strnin.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: strnin.scm,v 14.7 1999/02/18 04:14:22 cph Exp $
+$Id: strnin.scm,v 14.8 1999/02/24 21:36:21 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -26,14 +26,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (initialize-package!)
   (set! input-string-port-type
-	(make-input-port-type `((CHAR-READY? ,operation/char-ready?)
-				(DISCARD-CHAR ,operation/discard-char)
-				(DISCARD-CHARS ,operation/discard-chars)
-				(PEEK-CHAR ,operation/peek-char)
-				(WRITE-SELF ,operation/write-self)
-				(READ-CHAR ,operation/read-char)
-				(READ-STRING ,operation/read-string))
-			      #f))
+	(make-port-type `((CHAR-READY? ,operation/char-ready?)
+			  (DISCARD-CHAR ,operation/discard-char)
+			  (DISCARD-CHARS ,operation/discard-chars)
+			  (PEEK-CHAR ,operation/peek-char)
+			  (WRITE-SELF ,operation/write-self)
+			  (READ-CHAR ,operation/read-char)
+			  (READ-STRING ,operation/read-string))
+			#f))
   unspecific)
 
 (define (with-input-from-string string thunk)
diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm
index c84c6a1a3..642b04e08 100644
--- a/v7/src/runtime/strott.scm
+++ b/v7/src/runtime/strott.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: strott.scm,v 14.8 1999/02/18 04:14:19 cph Exp $
+$Id: strott.scm,v 14.9 1999/02/24 21:36:25 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -26,10 +26,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (initialize-package!)
   (set! output-string-port-type
-	(make-output-port-type `((WRITE-SELF ,operation/write-self)
-				 (WRITE-CHAR ,operation/write-char)
-				 (WRITE-SUBSTRING ,operation/write-substring))
-			       #f)))
+	(make-port-type `((WRITE-SELF ,operation/write-self)
+			  (WRITE-CHAR ,operation/write-char)
+			  (WRITE-SUBSTRING ,operation/write-substring))
+			#f)))
 
 (define (with-output-to-truncated-string max thunk)
   (call-with-current-continuation
diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm
index 3bebb239a..0ead6a0ac 100644
--- a/v7/src/runtime/strout.scm
+++ b/v7/src/runtime/strout.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: strout.scm,v 14.11 1999/02/18 04:14:15 cph Exp $
+$Id: strout.scm,v 14.12 1999/02/24 21:36:29 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -26,10 +26,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (initialize-package!)
   (set! output-string-port-type
-	(make-output-port-type `((WRITE-SELF ,operation/write-self)
-				 (WRITE-CHAR ,operation/write-char)
-				 (WRITE-SUBSTRING ,operation/write-substring))
-			       #f))
+	(make-port-type `((WRITE-SELF ,operation/write-self)
+			  (WRITE-CHAR ,operation/write-char)
+			  (WRITE-SUBSTRING ,operation/write-substring))
+			#f))
   unspecific)
 
 (define (with-output-to-string thunk)
diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm
index 750844c80..dbeec07d8 100644
--- a/v7/src/runtime/ttyio.scm
+++ b/v7/src/runtime/ttyio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ttyio.scm,v 1.11 1999/02/18 03:54:37 cph Exp $
+$Id: ttyio.scm,v 1.12 1999/02/24 21:36:08 cph Exp $
 
 Copyright (c) 1991-1999 Massachusetts Institute of Technology
 
@@ -33,7 +33,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     (set! hook/read-char operation/read-char)
     (set! hook/peek-char operation/peek-char)
     (set! the-console-port-type
-	  (make-i/o-port-type
+	  (make-port-type
 	   `((BEEP ,operation/beep)
 	     (CLEAR ,operation/clear)
 	     (DISCRETIONARY-FLUSH-OUTPUT ,operation/flush-output)
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 57751f19d..cc5c06bbf 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.324 1999/02/24 21:23:53 cph Exp $
+$Id: runtime.pkg,v 14.325 1999/02/24 21:37:22 cph Exp $
 
 Copyright (c) 1988-1999 Massachusetts Institute of Technology
 
@@ -1074,12 +1074,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  interaction-i/o-port
 	  make-encapsulated-port
 	  make-i/o-port
-	  make-i/o-port-type
 	  make-input-port
-	  make-input-port-type
 	  make-output-port
-	  make-output-port-type
 	  make-port
+	  make-port-type
 	  notification-output-port
 	  output-port-type?
 	  output-port/channel