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.
#| -*-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
(accessor type))))))
\f
(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)))
(begin
(close-output-port port)
(close-input-port port)))))
-
+\f
(define (close-input-port port)
(let ((close-input (port/operation port 'CLOSE-INPUT)))
(if close-input
(let ((close-output (port/operation port 'CLOSE-OUTPUT)))
(if close-output
(close-output port))))
-\f
+
(define (port/input-channel port)
(let ((operation (port/operation port 'INPUT-CHANNEL)))
(and operation
(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))
(error:wrong-type-argument port "I/O port" #f))
port)
\f
+;;;; 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)))
+\f
;;;; Constructors
(define (make-input-port type 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
- (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))
(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)
#| -*-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
(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)
#| -*-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
;;; package: (runtime transcript)
(declare (usual-integrations))
+\f
+(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))))))
+\f
+(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
#| -*-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
(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))
(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)
(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))))
projects / mit-scheme.git / commitdiff