From: Chris Hanson Date: Thu, 18 Feb 1999 03:54:37 +0000 (+0000) Subject: * Add mechanism to encapsulate one port in another, and to build X-Git-Tag: 20090517-FFI~4619 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a2d0ee4d828c2fac1b23e2e78f7a6466cf70d4b;p=mit-scheme.git * Add mechanism to encapsulate one port in another, and to build wrappers around selected operations on the encapsulated port. * Use new encapsulation mechanism to reimplement transcript facility so that each transcript is associated with a particular REPL. Previously the transcript was directly associated with the console port. This change is the goal of all of the port changes from this past week. (I'm a little surprised at the depth of changes required.) This has the side effect of increasing modularity, since the transcript code is now concentrated in one file rather than being integrated into the console port. * Export procedure OUTPUT-PORT/FRESH-LINE to the global environment. This was an oversight from previous changes. --- diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index 715328155..4565eb61d 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: port.scm,v 1.15 1999/02/16 20:41:49 cph Exp $ +$Id: port.scm,v 1.16 1999/02/18 03:54:03 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -164,13 +164,27 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (accessor type)))))) (define port-rtd (make-record-type "port" '(TYPE STATE THREAD-MUTEX))) +(define %make-port (record-constructor port-rtd '(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/state (record-accessor 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/state port) + (%port/state (base-port port))) + +(define set-port/state! + (let ((modifier (record-modifier port-rtd 'STATE))) + (lambda (port state) + (modifier (base-port port) state)))) + +(define (base-port port) + (let ((state (%port/state port))) + (if (encapsulated-port-state? state) + (base-port (encapsulated-port-state/port state)) + port))) + (define (port/operation-names port) (port-type/operation-names (port/type port))) @@ -224,7 +238,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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 @@ -234,7 +248,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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 @@ -280,6 +294,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (and (port-type/supports-input? type) (port-type/supports-output? type))))) +(define (guarantee-port port) + (if (not (port? port)) + (error:wrong-type-argument port "port" #f)) + port) + (define (guarantee-input-port port) (if (not (input-port? port)) (error:wrong-type-argument port "input port" #f)) @@ -295,6 +314,54 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (error:wrong-type-argument port "I/O port" #f)) port) +;;;; Encapsulation + +(define-structure (encapsulated-port-state + (conc-name encapsulated-port-state/)) + (port #f read-only #t) + state) + +(define (encapsulated-port? object) + (and (port? object) + (encapsulated-port-state? (%port/state object)))) + +(define (guarantee-encapsulated-port object procedure) + (guarantee-port object) + (if (not (encapsulated-port-state? (%port/state object))) + (error:wrong-type-argument object "encapsulated port" procedure))) + +(define (encapsulated-port/port port) + (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/PORT) + (encapsulated-port-state/port (%port/state port))) + +(define (encapsulated-port/state port) + (guarantee-encapsulated-port port 'ENCAPSULATED-PORT/STATE) + (encapsulated-port-state/state (%port/state port))) + +(define (set-encapsulated-port/state! port state) + (guarantee-encapsulated-port port 'SET-ENCAPSULATED-PORT/STATE!) + (set-encapsulated-port-state/state! (%port/state port) state)) + +(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) + (append-map + (lambda (entry) + (let ((operation + (rewrite-operation (car entry) (cadr entry)))) + (if operation + (list (list (car entry) operation)) + '()))) + (port-type/operations type)) + #f)) + (make-encapsulated-port-state port state) + (port/thread-mutex port))) + ;;;; Constructors (define (make-input-port type state) @@ -307,11 +374,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (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 '(TYPE STATE THREAD-MUTEX)))) - (lambda (type state) - (guarantee-port-type type 'MAKE-PORT) - (constructor type state (make-thread-mutex))))) +(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)) @@ -330,10 +395,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (list-transform-negative (port-type/operations type) (let ((ignored (append (if (assq 'READ-CHAR operations) - input-operation-names + '(DISCARD-CHAR + DISCARD-CHARS + PEEK-CHAR + READ-CHAR + READ-STRING + READ-SUBSTRING) '()) (if (assq 'WRITE-CHAR operations) - output-operation-names + '(WRITE-CHAR + WRITE-SUBSTRING) '())))) (lambda (entry) (or (assq (car entry) operations) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index b145e6d9d..0a9c547cd 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.52 1999/01/02 06:11:34 cph Exp $ +$Id: rep.scm,v 14.53 1999/02/18 03:54:13 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -86,7 +86,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (error:bad-range-argument port 'MAKE-CMDL)) (constructor (if parent (+ (cmdl/level parent) 1) 1) parent - (or port (cmdl/child-port parent)) + (let ((port* (and parent (cmdl/child-port parent)))) + (if port + (if (eq? port port*) + port + (make-transcriptable-port port)) + port*)) driver state (parse-operations-list operations 'MAKE-CMDL) diff --git a/v7/src/runtime/tscript.scm b/v7/src/runtime/tscript.scm index 0f37e012c..f8701fe01 100644 --- a/v7/src/runtime/tscript.scm +++ b/v7/src/runtime/tscript.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: tscript.scm,v 1.2 1999/01/02 06:19:10 cph Exp $ +$Id: tscript.scm,v 1.3 1999/02/18 03:54:26 cph Exp $ Copyright (c) 1990, 1999 Massachusetts Institute of Technology @@ -23,21 +23,90 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; package: (runtime transcript) (declare (usual-integrations)) + +(define-structure (encap-state + (conc-name encap-state/) + (constructor make-encap-state ())) + (transcript-port #f)) -(define transcript-port) +(define (encap? object) + (and (encapsulated-port? object) + (encap-state? (encapsulated-port/state object)))) -(define (initialize-package!) - (set! transcript-port false) - unspecific) +(define (encap/tport encap) + (encap-state/transcript-port (encapsulated-port/state encap))) + +(define (set-encap/tport! encap tport) + (set-encap-state/transcript-port! (encapsulated-port/state encap) tport)) + +(define (make-transcriptable-port port) + (make-encapsulated-port port (make-encap-state) + (lambda (name operation) + (let ((entry (assq name duplexed-operations))) + (if entry + (and (cadr entry) + ((cadr entry) operation)) + operation))))) (define (transcript-on filename) - (if transcript-port - (error "transcript already turned on")) - (set! transcript-port (open-output-file filename)) - unspecific) + (let ((encap (nearest-cmdl/port))) + (if (not (encap? encap)) + (error "Transcript not supported for this REPL.")) + (if (encap/tport encap) + (error "transcript already turned on")) + (set-encap/tport! encap (open-output-file filename)))) (define (transcript-off) - (if transcript-port - (let ((port transcript-port)) - (set! transcript-port false) - (close-output-port port)))) \ No newline at end of file + (let ((encap (nearest-cmdl/port))) + (if (not (encap? encap)) + (error "Transcript not supported for this REPL.")) + (let ((tport (encap/tport encap))) + (if tport + (begin + (set-encap/tport! encap #f) + (close-port tport)))))) + +(define duplexed-operations) + +(define (initialize-package!) + (set! duplexed-operations + (let ((input-char + (lambda (operation) + (lambda (encap . arguments) + (let ((char (apply operation encap arguments)) + (tport (encap/tport encap))) + (if (and tport (char? char)) + (write-char char tport)) + char)))) + (input-expr + (lambda (operation) + (lambda (encap . arguments) + (let ((expr (apply operation encap arguments)) + (tport (encap/tport encap))) + (if tport + (write expr tport)) + expr)))) + (duplex + (lambda (toperation) + (lambda (operation) + (lambda (encap . arguments) + (apply operation encap arguments) + (let ((tport (encap/tport encap))) + (if tport + (apply toperation tport arguments)))))))) + `((READ-CHAR ,input-char) + (PROMPT-FOR-COMMAND-CHAR ,input-char) + (PROMPT-FOR-EXPRESSION ,input-expr) + (PROMPT-FOR-COMMAND-EXPRESSION ,input-expr) + (READ ,input-expr) + (DISCARD-CHAR #f) + (DISCARD-CHARS #f) + (READ-STRING #f) + (READ-SUBSTRING #f) + (WRITE-CHAR ,(duplex output-port/write-char)) + (WRITE-SUBSTRING ,(duplex output-port/write-substring)) + (FRESH-LINE ,(duplex output-port/fresh-line)) + (FLUSH-OUTPUT ,(duplex output-port/flush-output)) + (DISCRETIONARY-FLUSH-OUTPUT + ,(duplex output-port/discretionary-flush))))) + unspecific) \ No newline at end of file diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm index 290e7404f..750844c80 100644 --- a/v7/src/runtime/ttyio.scm +++ b/v7/src/runtime/ttyio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ttyio.scm,v 1.10 1999/02/16 20:11:30 cph Exp $ +$Id: ttyio.scm,v 1.11 1999/02/18 03:54:37 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -36,16 +36,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (make-i/o-port-type `((BEEP ,operation/beep) (CLEAR ,operation/clear) - (DISCRETIONARY-FLUSH-OUTPUT - ,operation/discretionary-flush-output) - (FLUSH-OUTPUT ,operation/flush-output) - (FRESH-LINE ,operation/fresh-line) + (DISCRETIONARY-FLUSH-OUTPUT ,operation/flush-output) (PEEK-CHAR ,(lambda (port) (hook/peek-char port))) (READ-CHAR ,(lambda (port) (hook/read-char port))) (READ-FINISH ,operation/read-finish) - (WRITE-CHAR ,operation/write-char) (WRITE-SELF ,operation/write-self) - (WRITE-SUBSTRING ,operation/write-substring) (X-SIZE ,operation/x-size) (Y-SIZE ,operation/y-size)) generic-i/o-type)) @@ -132,12 +127,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let ((char (input-buffer/read-char (port/input-buffer port)))) (if (eof-object? char) (signal-end-of-input port)) - (if char - (cond ((console-port-state/echo-input? (port/state port)) - (output-port/write-char port char)) - (transcript-port - (output-port/write-char transcript-port char) - (output-port/discretionary-flush transcript-port)))) + (if (and char (console-port-state/echo-input? (port/state port))) + (output-port/write-char port char)) char)) (define (signal-end-of-input port) @@ -156,29 +147,6 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (loop))))))) (output-port/discretionary-flush port)) -(define (operation/write-char port char) - (output-buffer/write-char-block (port/output-buffer port) char) - (if transcript-port (output-port/write-char transcript-port char))) - -(define (operation/write-substring port string start end) - (output-buffer/write-substring-block (port/output-buffer port) - string start end) - (if transcript-port - (output-port/write-substring transcript-port string start end))) - -(define (operation/fresh-line port) - (if (not (output-buffer/line-start? (port/output-buffer port))) - (operation/write-char port #\newline))) - -(define (operation/flush-output port) - (output-buffer/drain-block (port/output-buffer port)) - (if transcript-port (output-port/flush-output transcript-port))) - -(define (operation/discretionary-flush-output port) - (output-buffer/drain-block (port/output-buffer port)) - (if transcript-port - (output-port/discretionary-flush transcript-port))) - (define (operation/clear port) (output-port/write-string port ((ucode-primitive tty-command-clear 0))))