From: Chris Hanson Date: Fri, 15 Nov 1991 05:19:03 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~10063 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0668b0aac189e346fc3edad49f89beb5337141c7;p=mit-scheme.git Initial revision --- diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm new file mode 100644 index 000000000..7228ba795 --- /dev/null +++ b/v7/src/runtime/fileio.scm @@ -0,0 +1,182 @@ +#| -*-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)) + +(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) + +(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) + +(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 diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm new file mode 100644 index 000000000..d36d1d800 --- /dev/null +++ b/v7/src/runtime/genio.scm @@ -0,0 +1,206 @@ +#| -*-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)) + +(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) + +(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")))) + +(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 diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm new file mode 100644 index 000000000..25b7302da --- /dev/null +++ b/v7/src/runtime/port.scm @@ -0,0 +1,385 @@ +#| -*-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)) + +(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))) + +(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) + +(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)))))))) + +(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))))))) + +(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 diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm new file mode 100644 index 000000000..b0d00b9c5 --- /dev/null +++ b/v7/src/runtime/ttyio.scm @@ -0,0 +1,189 @@ +#| -*-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)) + +(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))) + +(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