From 08b05b24d6e2488c11fb03598526ba0701e834e3 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 24 Feb 1999 21:37:22 +0000 Subject: [PATCH] Merge different port-type constructors into MAKE-PORT-TYPE. --- v7/src/edwin/artdebug.scm | 4 +- v7/src/edwin/bufinp.scm | 18 ++++---- v7/src/edwin/bufout.scm | 18 ++++---- v7/src/edwin/debug.scm | 4 +- v7/src/edwin/intmod.scm | 4 +- v7/src/edwin/winout.scm | 16 +++---- v7/src/runtime/emacs.scm | 4 +- v7/src/runtime/fileio.scm | 16 ++++--- v7/src/runtime/genio.scm | 22 +++++----- v7/src/runtime/port.scm | 85 +++++++++++++++++--------------------- v7/src/runtime/runtime.pkg | 6 +-- v7/src/runtime/strnin.scm | 18 ++++---- v7/src/runtime/strott.scm | 10 ++--- v7/src/runtime/strout.scm | 10 ++--- v7/src/runtime/ttyio.scm | 4 +- v8/src/runtime/runtime.pkg | 6 +-- 16 files changed, 114 insertions(+), 131 deletions(-) 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 -- 2.25.1