--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/fileio.scm,v 1.1 1991/11/15 05:17:18 cph Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; File I/O Ports
+;;; package: (runtime file-i/o-port)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (let ((input-operations
+ `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
+ (CHAR-READY? ,operation/char-ready?)
+ (CHARS-REMAINING ,operation/chars-remaining)
+ (DISCARD-CHAR ,operation/discard-char)
+ (DISCARD-CHARS ,operation/discard-chars)
+ (EOF? ,operation/eof?)
+ (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
+ (INPUT-CHANNEL ,operation/input-channel)
+ (LENGTH ,operation/length)
+ (PEEK-CHAR ,operation/peek-char)
+ (READ-CHAR ,operation/read-char)
+ (READ-CHARS ,operation/read-chars)
+ (READ-STRING ,operation/read-string)
+ (READ-SUBSTRING ,operation/read-substring)
+ (REST->STRING ,operation/rest->string)
+ (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)))
+ (output-operations
+ `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
+ (FLUSH-OUTPUT ,operation/flush-output)
+ (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
+ (OUTPUT-CHANNEL ,operation/output-channel)
+ (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-STRING ,operation/write-string)
+ (WRITE-SUBSTRING ,operation/write-substring)))
+ (other-operations
+ `((CLOSE ,operation/close)
+ (PATHNAME ,operation/pathname)
+ (PRINT-SELF ,operation/print-self)
+ (TRUENAME ,operation/truename))))
+ (set! input-file-template
+ (make-input-port (append input-operations
+ other-operations)
+ false))
+ (set! output-file-template
+ (make-output-port (append output-operations
+ other-operations)
+ false))
+ (set! i/o-file-template
+ (make-i/o-port (append input-operations
+ output-operations
+ other-operations)
+ false)))
+ unspecific)
+
+(define input-file-template)
+(define output-file-template)
+(define i/o-file-template)
+\f
+(define (open-input-file filename)
+ (let* ((pathname (merge-pathnames filename))
+ (channel (file-open-input-channel (->namestring pathname)))
+ (port
+ (port/copy input-file-template
+ (make-file-state (make-input-buffer channel
+ input-buffer-size)
+ false
+ pathname))))
+ (set-channel-port! channel port)
+ port))
+
+(define (open-output-file filename #!optional append?)
+ (let* ((pathname (->pathname filename))
+ (channel
+ (let ((filename (->namestring pathname)))
+ (if (and (not (default-object? append?)) append?)
+ (file-open-append-channel filename)
+ (file-open-output-channel filename))))
+ (port
+ (port/copy output-file-template
+ (make-file-state false
+ (make-output-buffer channel
+ output-buffer-size)
+ pathname))))
+ (set-channel-port! channel port)
+ port))
+
+(define (open-i/o-file filename)
+ (let* ((pathname (merge-pathnames filename))
+ (channel (file-open-io-channel (->namestring pathname)))
+ (port
+ (port/copy i/o-file-template
+ (make-file-state (make-input-buffer channel
+ input-buffer-size)
+ (make-output-buffer channel
+ output-buffer-size)
+ pathname))))
+ (set-channel-port! channel port)
+ port))
+
+(define input-buffer-size 512)
+(define output-buffer-size 512)
+\f
+(define-structure (file-state (type vector)
+ (conc-name file-state/))
+ ;; First two elements of this vector are required by the generic
+ ;; I/O port operations.
+ (input-buffer false read-only true)
+ (output-buffer false read-only true)
+ (pathname false read-only true))
+
+(define (operation/length port)
+ (file-length (operation/input-channel port)))
+
+(define (operation/pathname port)
+ (file-state/pathname (port/state port)))
+
+(define operation/truename
+ ;; This works for unix because truename and pathname are the same.
+ ;; On operating system where they differ, there must be support to
+ ;; determine the truename.
+ operation/pathname)
+
+(define (operation/print-self unparser-state port)
+ (unparse-string unparser-state "for file: ")
+ (unparse-object unparser-state (operation/truename port)))
+
+(define (operation/rest->string port)
+ ;; This operation's intended purpose is to snarf an entire file in
+ ;; a single gulp, exactly what a text editor would need.
+ (let ((buffer (file-state/input-buffer (port/state port))))
+ (let ((remaining (input-buffer/chars-remaining buffer))
+ (fill-buffer
+ (lambda (string)
+ (let ((length (string-length string)))
+ (let loop ()
+ (or (input-buffer/read-substring buffer string 0 length)
+ (loop)))))))
+ (if remaining
+ (let ((result (make-string remaining)))
+ (let ((n (fill-buffer result)))
+ (if (< n remaining)
+ (substring result 0 n)
+ result)))
+ (apply string-append
+ (let loop ()
+ (let ((string (make-string input-buffer-size)))
+ (let ((n (fill-buffer string)))
+ (cond ((zero? n) '())
+ ((< n remaining) (list (substring string 0 n)))
+ (else (cons string (loop))))))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/genio.scm,v 1.1 1991/11/15 05:17:03 cph Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Generic I/O Ports
+;;; package: (runtime generic-i/o-port)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (let ((input-operations
+ `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
+ (CHAR-READY? ,operation/char-ready?)
+ (CHARS-REMAINING ,operation/chars-remaining)
+ (DISCARD-CHAR ,operation/discard-char)
+ (DISCARD-CHARS ,operation/discard-chars)
+ (EOF? ,operation/eof?)
+ (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
+ (INPUT-CHANNEL ,operation/input-channel)
+ (PEEK-CHAR ,operation/peek-char)
+ (READ-CHAR ,operation/read-char)
+ (READ-CHARS ,operation/read-chars)
+ (READ-STRING ,operation/read-string)
+ (READ-SUBSTRING ,operation/read-substring)
+ (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)))
+ (output-operations
+ `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
+ (FLUSH-OUTPUT ,operation/flush-output)
+ (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
+ (OUTPUT-CHANNEL ,operation/output-channel)
+ (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-STRING ,operation/write-string)
+ (WRITE-SUBSTRING ,operation/write-substring)))
+ (other-operations
+ `((CLOSE ,operation/close)
+ (PRINT-SELF ,operation/print-self))))
+ (set! generic-input-template
+ (make-input-port (append input-operations
+ other-operations)
+ false))
+ (set! generic-output-template
+ (make-output-port (append output-operations
+ other-operations)
+ false))
+ (set! generic-i/o-template
+ (make-i/o-port (append input-operations
+ output-operations
+ other-operations)
+ false)))
+ unspecific)
+
+(define generic-input-template)
+(define generic-output-template)
+(define generic-i/o-template)
+\f
+(define (make-generic-input-port input-channel input-buffer-size)
+ (make-generic-port generic-input-template
+ (make-input-buffer input-channel input-buffer-size)
+ false))
+
+(define (make-generic-output-port output-channel output-buffer-size)
+ (make-generic-port generic-output-template
+ false
+ (make-output-buffer output-channel output-buffer-size)))
+
+(define (make-generic-i/o-port input-channel output-channel
+ input-buffer-size output-buffer-size)
+ (make-generic-port generic-i/o-template
+ (make-input-buffer input-channel input-buffer-size)
+ (make-output-buffer output-channel output-buffer-size)))
+
+(define (make-generic-port template input-buffer output-buffer)
+ (let ((port (port/copy template (vector input-buffer output-buffer))))
+ (if input-buffer
+ (set-channel-port! (input-buffer/channel input-buffer) port))
+ (if output-buffer
+ (set-channel-port! (output-buffer/channel output-buffer) port))
+ port))
+
+(define-integrable (port/input-buffer port)
+ (vector-ref (port/state port) 0))
+
+(define-integrable (port/output-buffer port)
+ (vector-ref (port/state port) 1))
+
+(define (operation/print-self unparser-state port)
+ (cond ((i/o-port? port)
+ (unparse-string unparser-state "for channels: ")
+ (unparse-object unparser-state (operation/input-channel port))
+ (unparse-string unparser-state " ")
+ (unparse-object unparser-state (operation/output-channel port)))
+ ((input-port? port)
+ (unparse-string unparser-state "for channel: ")
+ (unparse-object unparser-state (operation/input-channel port)))
+ ((output-port? port)
+ (unparse-string unparser-state "for channel: ")
+ (unparse-object unparser-state (operation/output-channel port)))
+ (else
+ (unparse-string unparser-state "for channel"))))
+\f
+(define (operation/char-ready? port interval)
+ (input-buffer/char-ready? (port/input-buffer port) interval))
+
+(define (operation/chars-remaining port)
+ (input-buffer/chars-remaining (port/input-buffer port)))
+
+(define (operation/discard-char port)
+ (input-buffer/discard-char (port/input-buffer port)))
+
+(define (operation/discard-chars port delimiters)
+ (input-buffer/discard-until-delimiter (port/input-buffer port) delimiters))
+
+(define (operation/eof? port)
+ (input-buffer/eof? (port/input-buffer port)))
+
+(define (operation/peek-char port)
+ (input-buffer/peek-char (port/input-buffer port)))
+
+(define (operation/read-char port)
+ (input-buffer/read-char (port/input-buffer port)))
+
+(define (operation/read-chars port result-buffer)
+ (input-buffer/read-substring (port/input-buffer port)
+ result-buffer
+ 0
+ (string-length result-buffer)))
+
+(define (operation/read-substring port string start end)
+ (input-buffer/read-substring (port/input-buffer port) string start end))
+
+(define (operation/read-string port delimiters)
+ (input-buffer/read-until-delimiter (port/input-buffer port) delimiters))
+
+(define (operation/input-buffer-size port)
+ (input-buffer/size (port/input-buffer port)))
+
+(define (operation/buffered-input-chars port)
+ (input-buffer/buffered-chars (port/input-buffer port)))
+
+(define (operation/set-input-buffer-size port buffer-size)
+ (input-buffer/set-size (port/input-buffer port) buffer-size))
+
+(define (operation/input-channel port)
+ (input-buffer/channel (port/input-buffer port)))
+
+(define (operation/flush-output port)
+ (output-buffer/drain-block (port/output-buffer port)))
+
+(define (operation/write-char port char)
+ (output-buffer/write-char-block (port/output-buffer port) char))
+
+(define (operation/write-string port string)
+ (output-buffer/write-string-block (port/output-buffer port) string))
+
+(define (operation/write-substring port string start end)
+ (output-buffer/write-substring-block (port/output-buffer port)
+ string start end))
+
+(define (operation/output-buffer-size port)
+ (output-buffer/size (port/output-buffer port)))
+
+(define (operation/buffered-output-chars port)
+ (output-buffer/buffered-chars (port/output-buffer port)))
+
+(define (operation/set-output-buffer-size port buffer-size)
+ (output-buffer/set-size (port/output-buffer port) buffer-size))
+
+(define (operation/output-channel port)
+ (output-buffer/channel (port/output-buffer port)))
+
+(define (operation/close port)
+ (let ((input-buffer (port/input-buffer port)))
+ (if input-buffer (input-buffer/close input-buffer)))
+ (let ((output-buffer (port/output-buffer port)))
+ (if output-buffer (output-buffer/close output-buffer))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.1 1991/11/15 05:19:03 cph Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; I/O Ports
+;;; package: (runtime port)
+
+(declare (usual-integrations))
+\f
+(define port-rtd
+ (make-record-type "port"
+ '(STATE
+ OPERATION-NAMES
+ CUSTOM-OPERATIONS
+ ;; input operations:
+ CHAR-READY?
+ PEEK-CHAR
+ READ-CHAR
+ DISCARD-CHAR
+ READ-STRING
+ DISCARD-CHARS
+ ;; output operations:
+ WRITE-CHAR
+ WRITE-STRING
+ WRITE-SUBSTRING
+ 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/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 input-port/operation/discard-chars
+ (record-accessor port-rtd 'DISCARD-CHARS))
+
+(define output-port/operation/write-char
+ (record-accessor port-rtd 'WRITE-CHAR))
+
+(define output-port/operation/write-string
+ (record-accessor port-rtd 'WRITE-STRING))
+
+(define output-port/operation/write-substring
+ (record-accessor port-rtd 'WRITE-SUBSTRING))
+
+(define output-port/operation/flush-output
+ (record-accessor port-rtd 'FLUSH-OUTPUT))
+
+(set-record-type-unparser-method! port-rtd
+ (lambda (state port)
+ ((unparser/standard-method
+ (cond ((i/o-port? port) 'I/O-PORT)
+ ((input-port? port) 'INPUT-PORT)
+ ((output-port? port) 'OUTPUT-PORT)
+ (else 'PORT))
+ (port/operation port 'PRINT-SELF))
+ state
+ port)))
+\f
+(define (port/copy port state)
+ (let ((port (record-copy port)))
+ (set-port/state! port state)
+ 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))
+ ((WRITE-CHAR) (output-port/operation/write-char port))
+ ((WRITE-STRING) (output-port/operation/write-string port))
+ ((WRITE-SUBSTRING) (output-port/operation/write-substring port))
+ ((FLUSH-OUTPUT) (output-port/operation/flush-output port))
+ (else false)))))
+
+(define (close-port port)
+ (let ((operation (port/operation port 'CLOSE)))
+ (if operation
+ (operation port))))
+
+(define (port/input-channel port)
+ (let ((operation (port/operation port 'INPUT-CHANNEL)))
+ (and operation
+ (operation port))))
+
+(define (port/output-channel port)
+ (let ((operation (port/operation port 'OUTPUT-CHANNEL)))
+ (and operation
+ (operation port))))
+
+;; These names required by Scheme standard:
+(define close-input-port close-port)
+(define close-output-port close-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 (input-port/operation port name)
+ (port/operation port
+ (case name
+ ((BUFFER-SIZE) 'INPUT-BUFFER-SIZE)
+ ((SET-BUFFER-SIZE) 'SET-INPUT-BUFFER-SIZE)
+ ((BUFFERED-CHARS) 'BUFFERED-INPUT-CHARS)
+ ((CHANNEL) 'INPUT-CHANNEL)
+ (else name))))
+
+(define (output-port/operation port name)
+ (port/operation port
+ (case name
+ ((BUFFER-SIZE) 'OUTPUT-BUFFER-SIZE)
+ ((SET-BUFFER-SIZE) 'SET-OUTPUT-BUFFER-SIZE)
+ ((BUFFERED-CHARS) 'BUFFERED-OUTPUT-CHARS)
+ ((CHANNEL) 'OUTPUT-CHANNEL)
+ (else name))))
+
+(define input-port/custom-operation input-port/operation)
+(define output-port/custom-operation output-port/operation)
+\f
+(define (input-port? object)
+ (and (port? object)
+ (input-port/operation/read-char object)
+ true))
+
+(define (output-port? object)
+ (and (port? object)
+ (output-port/operation/write-char object)
+ true))
+
+(define (i/o-port? object)
+ (and (port? object)
+ (input-port/operation/read-char object)
+ (output-port/operation/write-char object)
+ true))
+
+(define (make-input-port operations state)
+ (make-port operations state 'MAKE-INPUT-PORT true false))
+
+(define (make-output-port operations state)
+ (make-port operations state 'MAKE-OUTPUT-PORT false true))
+
+(define (make-i/o-port operations state)
+ (make-port operations state 'MAKE-I/O-PORT true true))
+
+(define make-port
+ (let ((constructor
+ (record-constructor port-rtd
+ '(STATE OPERATION-NAMES CUSTOM-OPERATIONS))))
+ (lambda (operations state procedure-name input? output?)
+ (let ((port
+ (constructor state
+ '()
+ (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))))
+
+(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))
+
+(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))))))))
+\f
+(define install-input-operations!
+ (let ((operation-names
+ '(CHAR-READY? PEEK-CHAR READ-CHAR
+ DISCARD-CHAR READ-STRING DISCARD-CHARS)))
+ (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 false
+ false
+ false
+ (caddr operations)
+ default-operation/read-string
+ default-operation/discard-chars)
+ 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)))))))
+
+(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))))))))))))
+
+(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)))))))
+\f
+(define (default-operation/write-char port char)
+ ((output-port/operation/write-substring port) port (char->string char) 0 1))
+
+(define (default-operation/write-string port string)
+ ((output-port/operation/write-substring port)
+ port
+ string 0 (string-length string)))
+
+(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)))))))
+
+(define (default-operation/flush-output port)
+ port
+ unspecific)
+
+(define install-output-operations!
+ (let ((operation-names
+ '(WRITE-CHAR WRITE-SUBSTRING WRITE-STRING FLUSH-OUTPUT))
+ (operation-defaults
+ (list default-operation/write-char
+ default-operation/write-substring
+ default-operation/write-string
+ 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)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/ttyio.scm,v 1.1 1991/11/15 05:17:32 cph Exp $
+
+Copyright (c) 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Console I/O Ports
+;;; package: (runtime console-i/o-port)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! hook/read-start default/read-start)
+ (set! hook/read-finish default/read-finish)
+ (set! console-i/o-port
+ (make-i/o-port
+ `((BEEP ,operation/beep)
+ (BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
+ (BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
+ (CHAR-READY? ,operation/char-ready?)
+ (CLEAR ,operation/clear)
+ (DISCARD-CHAR ,operation/read-char)
+ (FLUSH-OUTPUT ,operation/flush-output)
+ (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
+ (INPUT-CHANNEL ,operation/input-channel)
+ (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
+ (OUTPUT-CHANNEL ,operation/output-channel)
+ (PEEK-CHAR ,operation/peek-char)
+ (PRINT-SELF ,operation/print-self)
+ (READ-CHAR ,operation/read-char)
+ (READ-FINISH! ,operation/read-finish!)
+ (READ-START! ,operation/read-start!)
+ (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)
+ (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-STRING ,operation/write-string)
+ (X-SIZE ,operation/x-size)
+ (Y-SIZE ,operation/y-size))
+ false))
+ (set! console-input-port console-i/o-port)
+ (set! console-output-port console-i/o-port)
+ (reset-console)
+ (add-event-receiver! event:after-restore reset-console)
+ (add-event-receiver! event:before-exit save-console-input)
+ (set-current-input-port! console-i/o-port)
+ (set-current-output-port! console-i/o-port))
+
+(define console-i/o-port)
+(define console-input-port)
+(define console-output-port)
+
+(define (save-console-input)
+ ((ucode-primitive reload-save-string 1)
+ (input-buffer/buffer-contents (port/input-buffer console-input-port))))
+
+(define (reset-console)
+ (set-port/state!
+ console-i/o-port
+ (let ((input-channel (tty-input-channel))
+ (output-channel (tty-output-channel)))
+ (set-channel-port! input-channel console-i/o-port)
+ (set-channel-port! output-channel console-i/o-port)
+ (make-console-port-state
+ (let ((buffer (make-input-buffer input-channel input-buffer-size)))
+ (let ((contents ((ucode-primitive reload-retrieve-string 0))))
+ (if contents
+ (input-buffer/set-buffer-contents buffer contents)))
+ buffer)
+ (make-output-buffer output-channel output-buffer-size)
+ (channel-type=file? input-channel)))))
+
+(define input-buffer-size 512)
+(define output-buffer-size 512)
+
+(define-structure (console-port-state (type vector)
+ (conc-name console-port-state/))
+ ;; First two elements of this vector are required by the generic
+ ;; I/O port operations.
+ (input-buffer false read-only true)
+ (output-buffer false read-only true)
+ (echo-input? false read-only true))
+
+(define-integrable (port/input-buffer port)
+ (console-port-state/input-buffer (port/state port)))
+
+(define-integrable (port/output-buffer port)
+ (console-port-state/output-buffer (port/state port)))
+\f
+(define (operation/peek-char port)
+ (let ((char (input-buffer/peek-char (port/input-buffer port))))
+ (if (eof-object? char)
+ (signal-end-of-input))
+ char))
+
+(define (operation/read-char port)
+ (let ((char (input-buffer/read-char (port/input-buffer port))))
+ (if (eof-object? char)
+ (signal-end-of-input))
+ (if char
+ (cond ((console-port-state/echo-input? (port/state port))
+ (output-port/write-char console-output-port char)
+ (output-port/flush-output console-output-port))
+ (transcript-port
+ (output-port/write-char transcript-port char)
+ (output-port/flush-output transcript-port))))
+ char))
+
+(define (signal-end-of-input)
+ (write-string "\nEnd of input stream reached" console-output-port)
+ (%exit))
+
+(define (operation/read-start! port)
+ port
+ (hook/read-start))
+
+(define hook/read-start)
+(define (default/read-start) false)
+
+(define (operation/read-finish! port)
+ (let ((buffer (port/input-buffer port)))
+ (let loop ()
+ (if (input-buffer/char-ready? buffer 0)
+ (let ((char (input-buffer/peek-char buffer)))
+ (if (char-whitespace? char)
+ (begin
+ (operation/read-char port)
+ (loop)))))))
+ (hook/read-finish))
+
+(define hook/read-finish)
+(define (default/read-finish) false)
+
+(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-string port string)
+ (output-buffer/write-string-block (port/output-buffer port) string)
+ (if transcript-port (output-port/write-string transcript-port string)))
+
+(define (operation/flush-output port)
+ (output-buffer/drain-block (port/output-buffer port))
+ (if transcript-port (output-port/flush-output transcript-port)))
+
+(define (operation/clear port)
+ (operation/write-string port ((ucode-primitive tty-command-clear 0))))
+
+(define (operation/beep port)
+ (operation/write-string port ((ucode-primitive tty-command-beep 0))))
+
+(define (operation/x-size port)
+ port
+ ((ucode-primitive tty-x-size 0)))
+
+(define (operation/y-size port)
+ port
+ ((ucode-primitive tty-y-size 0)))
+
+(define (operation/print-self state port)
+ port
+ (unparse-string state "for console"))
\ No newline at end of file
projects / mit-scheme.git / commitdiff