From ce505a1e1ca7e64d4c1ce05a95f5a11c98a34fa2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 9 Nov 1990 08:44:55 +0000 Subject: [PATCH] Requires microcode 11.52 or later. * Reimplement subprocess abstraction to match new microcode support. * Implement socket abstraction. * Create new "generic channel" input and output ports. These share operations with file and console ports. * Add `buffer-size' and `set-buffer-size' operations to file and console input ports. * Add `eof?' operation to file input port. * Add `channel' operation to file input and output ports. * Change input and output buffer abstractions to permit a buffer-size of zero. Input buffer treats this the same as a buffer size of one, since at least one character of buffering is needed to implement the peek-char operation. * Change the peek-char and read-char input port operations to return an EOF object at end of file, or #F if no characters are available and the input port is set to non-blocking mode. This is an incompatible change. * Change the read-string input port operation to return an EOF object at end of file. This is an incompatible change. * Change the read-string and discard-chars input-port operations to for their input channels into blocking mode. * Add new channel types: TCP-SERVER-SOCKET and DIRECTORY. * Change the file-opening code to signal a range error if an attempt is made to open a channel of type DIRECTORY or UNKNOWN. * Remove error check from `open-pty-master'; the primitive now takes care of this. * Add new operations on PTY masters: pty-master-kill, pty-master-stop, pty-master-continue, pty-master-interrupt, and pty-master-quit. * Change the input-buffer abstraction to handle non-blocking channels correctly. * Use new microcode primitive `file-mod-time-indirect' to implement `file-modification-time'. --- v7/src/runtime/input.scm | 91 ++++---- v7/src/runtime/io.scm | 449 ++++++++++++++++++++----------------- v7/src/runtime/make.scm | 5 +- v7/src/runtime/parse.scm | 74 +++--- v7/src/runtime/process.scm | 190 +++++++++++----- v7/src/runtime/runtime.pkg | 154 +++++++++++-- v7/src/runtime/strnin.scm | 38 ++-- v7/src/runtime/unxprm.scm | 7 +- v7/src/runtime/version.scm | 4 +- v8/src/runtime/make.scm | 5 +- v8/src/runtime/runtime.pkg | 154 +++++++++++-- 11 files changed, 754 insertions(+), 417 deletions(-) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 4cb3c6bd3..78566eed7 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.9 1990/11/02 02:06:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.10 1990/11/09 08:43:53 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -130,22 +130,34 @@ MIT in each case. |# (map car operations)))))))) (define (default-operation/read-string port delimiters) - (list->string - (let ((peek-char (input-port/operation/peek-char port)) - (read-char (input-port/operation/read-char port))) - (let loop () - (if (char-set-member? delimiters (peek-char port)) - '() - (let ((char (read-char port))) - (cons char (loop)))))))) + (let ((peek-char (input-port/operation/peek-char port)) + (discard-char (input-port/operation/discard-char port))) + (let ((peek-char (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 () - (if (not (char-set-member? delimiters (peek-char port))) - (begin (discard-char port) - (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 (input-port/char-ready? port interval) ((input-port/operation/char-ready? port) port interval)) @@ -216,56 +228,53 @@ MIT in each case. |# ;;;; Input Procedures -;;; **** The INTERVAL option for this operation works only for the -;;; console port. Only Edwin uses this option. - (define (char-ready? #!optional port interval) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port))) - (interval - (if (default-object? interval) - 0 - (begin - (if (not (exact-nonnegative-integer? interval)) - (error "interval must be exact nonnegative integer" - interval)) - interval)))) - (input-port/char-ready? port interval))) + (input-port/char-ready? (if (default-object? port) + (current-input-port) + (guarantee-input-port port)) + (if (default-object? interval) + 0 + (begin + (if (not (exact-nonnegative-integer? interval)) + (error:illegal-datum interval + 'CHAR-READY?)) + interval)))) (define (peek-char #!optional port) (let ((port (if (default-object? port) (current-input-port) (guarantee-input-port port)))) - (or (input-port/peek-char port) - eof-object))) + (let loop () + (or (input-port/peek-char port) + (loop))))) (define (read-char #!optional port) (let ((port (if (default-object? port) (current-input-port) (guarantee-input-port port)))) - (or (input-port/read-char port) - eof-object))) + (let loop () + (or (input-port/read-char port) + (loop))))) (define (read-char-no-hang #!optional port) (let ((port (if (default-object? port) (current-input-port) (guarantee-input-port port)))) - (and (input-port/char-ready? port 0) - (or (input-port/read-char port) - eof-object)))) + (if (input-port/char-ready? port 0) + (input-port/read-char port) + (let ((eof? (input-port/custom-operation port 'EOF?))) + (and eof? + (eof? port) + eof-object))))) (define (read-string delimiters #!optional port) - (let ((port - (if (default-object? port) - (current-input-port) - (guarantee-input-port port)))) - (or (input-port/read-string port delimiters) - eof-object))) + (input-port/read-string (if (default-object? port) + (current-input-port) + (guarantee-input-port port)) + delimiters)) (define (read #!optional port parser-table) (let ((port diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 80d6a392d..b12e31f8e 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.10 1990/11/02 02:06:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.11 1990/11/09 08:43:59 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -63,7 +63,8 @@ MIT in each case. |# (let ((type ((ucode-primitive channel-type 1) descriptor)) (types '#(#F FILE PIPE FIFO TERMINAL PTY-MASTER - UNIX-STREAM-SOCKET TCP-STREAM-SOCKET))) + UNIX-STREAM-SOCKET TCP-STREAM-SOCKET + TCP-SERVER-SOCKET DIRECTORY))) (and (< type (vector-length types)) (vector-ref types type)))))) (with-absolutely-no-interrupts @@ -83,6 +84,9 @@ MIT in each case. |# (loop (cdr channels))))) (make-channel descriptor))) +(define-integrable (channel-type=unknown? channel) + (false? (channel-type channel))) + (define-integrable (channel-type=file? channel) (eq? 'FILE (channel-type channel))) @@ -91,6 +95,9 @@ MIT in each case. |# (define-integrable (channel-type=pty-master? channel) (eq? 'PTY-MASTER (channel-type channel))) + +(define-integrable (channel-type=directory? channel) + (eq? 'DIRECTORY (channel-type channel))) (define (channel-close channel) ;; This is locked from interrupts, but GC can occur since the @@ -221,36 +228,28 @@ MIT in each case. |# ;;;; File Primitives +(define (file-open primitive filename) + (let ((channel + (without-interrupts (lambda () (make-channel (primitive filename)))))) + (if (or (channel-type=directory? channel) + (channel-type=unknown? channel)) + (begin + (channel-close channel) + (error:datum-out-of-range filename primitive))) + channel)) + (define (file-open-input-channel filename) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive file-open-input-channel 1) filename))))) + (file-open (ucode-primitive file-open-input-channel 1) filename)) (define (file-open-output-channel filename) ((ucode-primitive file-remove-link 1) filename) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive file-open-output-channel 1) filename))))) + (file-open (ucode-primitive file-open-output-channel 1) filename)) (define (file-open-io-channel filename) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive file-open-io-channel 1) filename))))) + (file-open (ucode-primitive file-open-io-channel 1) filename)) (define (file-open-append-channel filename) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive file-open-append-channel 1) filename))))) - -(define (tty-input-channel) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive tty-input-channel 0)))))) - -(define (tty-output-channel) - (without-interrupts - (lambda () - (make-channel ((ucode-primitive tty-output-channel 0)))))) + (file-open (ucode-primitive file-open-append-channel 1) filename)) (define (file-length channel) ((ucode-primitive file-length-new 1) (channel-descriptor channel))) @@ -264,6 +263,16 @@ MIT in each case. |# ;;;; Terminal Primitives +(define (tty-input-channel) + (without-interrupts + (lambda () + (make-channel ((ucode-primitive tty-input-channel 0)))))) + +(define (tty-output-channel) + (without-interrupts + (lambda () + (make-channel ((ucode-primitive tty-output-channel 0)))))) + (define (terminal-get-state channel) ((ucode-primitive terminal-get-state 1) (channel-descriptor channel))) @@ -309,8 +318,6 @@ MIT in each case. |# (without-interrupts (lambda () (let ((result ((ucode-primitive open-pty-master 0)))) - (if (not result) - (error "unable to open pty master")) (values (make-channel (vector-ref result 0)) (vector-ref result 1) (vector-ref result 2)))))) @@ -318,6 +325,21 @@ MIT in each case. |# (define (pty-master-send-signal channel signal) ((ucode-primitive pty-master-send-signal 2) (channel-descriptor channel) signal)) + +(define (pty-master-kill channel) + ((ucode-primitive pty-master-kill 1) (channel-descriptor channel))) + +(define (pty-master-stop channel) + ((ucode-primitive pty-master-stop 1) (channel-descriptor channel))) + +(define (pty-master-continue channel) + ((ucode-primitive pty-master-continue 1) (channel-descriptor channel))) + +(define (pty-master-interrupt channel) + ((ucode-primitive pty-master-interrupt 1) (channel-descriptor channel))) + +(define (pty-master-quit channel) + ((ucode-primitive pty-master-quit 1) (channel-descriptor channel))) ;;;; File Copying @@ -372,105 +394,101 @@ MIT in each case. |# string position) -(define-integrable (make-output-buffer channel buffer-size) - (%make-output-buffer channel (make-string buffer-size) 0)) +(define (make-output-buffer channel buffer-size) + (%make-output-buffer channel + (and (fix:> buffer-size 0) (make-string buffer-size)) + 0)) (define (output-buffer/close buffer) (output-buffer/drain-block buffer) (channel-close (output-buffer/channel buffer))) (define (output-buffer/size buffer) - (string-length (output-buffer/string buffer))) + (let ((string (output-buffer/string buffer))) + (if string + (string-length string) + 0))) (define (output-buffer/set-size buffer buffer-size) - (if (> (output-buffer/position buffer) buffer-size) - (let loop () (if (>= (output-buffer/drain buffer) buffer-size) (loop)))) - (let ((position (output-buffer/position buffer)) - (string (make-string buffer-size))) - (substring-move-left! (output-buffer/string buffer) 0 position string 0) - (set-output-buffer/string! buffer string) - (if (= position buffer-size) (output-buffer/drain buffer)))) + (output-buffer/drain-block buffer) + (set-output-buffer/string! buffer + (and (fix:> buffer-size 0) + (make-string buffer-size)))) (define output-buffer/buffered-chars output-buffer/position) (define (output-buffer/drain buffer) - (let ((position (output-buffer/position buffer))) - (if (zero? position) + (let ((string (output-buffer/string buffer)) + (position (output-buffer/position buffer))) + (if (or (not string) (zero? position)) 0 - (let ((channel (output-buffer/channel buffer)) - (string (output-buffer/string buffer))) - (let ((n (channel-write channel string 0 position))) - (cond ((or (not n) (zero? n)) position) - ((< n position) - (let ((position* (- position n))) - (substring-move-left! string n position string 0) - (set-output-buffer/position! buffer position*) - position*)) - (else - (set-output-buffer/position! buffer 0) - 0))))))) + (let ((n + (channel-write (output-buffer/channel buffer) + string 0 position))) + (cond ((or (not n) (fix:= n 0)) + position) + ((< n position) + (let ((position* (fix:- position n))) + (substring-move-left! string n position string 0) + (set-output-buffer/position! buffer position*) + position*)) + (else + (set-output-buffer/position! buffer 0) + 0)))))) (define (output-buffer/flush buffer) (set-output-buffer/position! buffer 0)) (define (output-buffer/write-substring buffer string start end) - (if (= start end) - 0 - (let loop ((start start) (n-left (- end start)) (n-previous 0)) - (let ((string* (output-buffer/string buffer)) - (position (output-buffer/position buffer))) - (let ((length (string-length string*)) - (position* (+ position n-left))) - (cond ((<= position* length) - (substring-move-left! string start end string* position) - (set-output-buffer/position! buffer position*) - (if (= position* length) (output-buffer/drain buffer)) - (+ n-previous n-left)) - ((< position length) - (let ((room (- length position))) - (let ((end (+ start room)) - (n-previous (+ n-previous room))) - (substring-move-left! string start end string* position) - (set-output-buffer/position! buffer length) - (if (< (output-buffer/drain buffer) length) - (loop end (- n-left room) n-previous) - n-previous)))) - (else - (if (< (output-buffer/drain buffer) length) - (loop start n-left n-previous) - n-previous)))))))) - -(define (output-buffer/write-char buffer char) - (let* ((string (output-buffer/string buffer)) - (length (string-length string))) - (and (or (< (output-buffer/position buffer) length) - (< (output-buffer/drain buffer) length)) - (let ((position (output-buffer/position buffer))) - (string-set! string position char) - (let ((position (1+ position))) - (set-output-buffer/position! buffer position) - (if (= position length) (output-buffer/drain buffer)) - true))))) + (cond ((fix:= start end) + 0) + ((not (output-buffer/string buffer)) + (or (channel-write (output-buffer/channel buffer) string start end) + 0)) + (else + (let loop ((start start) (n-left (fix:- end start)) (n-previous 0)) + (let ((string* (output-buffer/string buffer)) + (position (output-buffer/position buffer))) + (let ((length (string-length string*)) + (position* (fix:+ position n-left))) + (cond ((fix:<= position* length) + (substring-move-left! string start end string* position) + (set-output-buffer/position! buffer position*) + (if (fix:= position* length) + (output-buffer/drain buffer)) + (fix:+ n-previous n-left)) + ((fix:< position length) + (let ((room (fix:- length position))) + (let ((end (fix:+ start room)) + (n-previous (fix:+ n-previous room))) + (substring-move-left! string start end + string* position) + (set-output-buffer/position! buffer length) + (if (fix:< (output-buffer/drain buffer) length) + (loop end (fix:- n-left room) n-previous) + n-previous)))) + (else + (if (fix:< (output-buffer/drain buffer) length) + (loop start n-left n-previous) + n-previous))))))))) (define (output-buffer/drain-block buffer) (let loop () - (if (not (zero? (output-buffer/drain buffer))) + (if (not (fix:= (output-buffer/drain buffer) 0)) (loop)))) -(define (output-buffer/write-string-block buffer string) - (output-buffer/write-substring-block buffer string 0 (string-length string))) - (define (output-buffer/write-substring-block buffer string start end) - (let loop ((start start) (n-left (- end start))) - (let ((n (output-buffer/write-substring buffer string start end))) - (if (< n n-left) - (loop (+ start n) (- n-left n)))))) + (do ((start start + (fix:+ start + (output-buffer/write-substring buffer string start end)))) + ((fix:>= start end)))) (define (output-buffer/write-char-block buffer char) - (let loop () - (if (not (output-buffer/write-char buffer char)) - (loop)))) + (output-buffer/write-substring-block buffer (string char) 0 1)) + +(define (output-buffer/write-string-block buffer string) + (output-buffer/write-substring-block buffer string 0 (string-length string))) ;;;; Buffered Input @@ -483,10 +501,11 @@ MIT in each case. |# end-index) (define (make-input-buffer channel buffer-size) - (%make-input-buffer channel - (make-string buffer-size) - buffer-size - buffer-size)) + (let ((buffer-size (if (fix:> buffer-size 1) buffer-size 1))) + (%make-input-buffer channel + (make-string buffer-size) + buffer-size + buffer-size))) (define (input-buffer/close buffer) (set-input-buffer/end-index! buffer 0) @@ -496,108 +515,114 @@ MIT in each case. |# (string-length (input-buffer/string buffer))) (define (input-buffer/set-size buffer buffer-size) - ;; If the buffer's contents will not fit with the new size, the - ;; oldest part of it is discarded. - (let ((start-index (input-buffer/start-index buffer)) - (end-index (input-buffer/end-index buffer)) - (string (make-string buffer-size))) - (substring-move-left! (input-buffer/string buffer) - (max start-index (- end-index buffer-size)) - end-index - string - 0) - (set-input-buffer/string! buffer string) - (set-input-buffer/start-index! buffer 0) - (set-input-buffer/end-index! buffer (- end-index start-index)))) + ;; Returns the actual buffer size, which may be different from the arg. + ;; Discards any buffered characters. + (let ((buffer-size (if (fix:> buffer-size 1) buffer-size 1))) + (set-input-buffer/string! buffer (make-string buffer-size)) + (let ((index (if (fix:= (input-buffer/end-index buffer) 0) 0 buffer-size))) + (set-input-buffer/start-index! buffer index) + (set-input-buffer/end-index! buffer index)) + buffer-size)) (define (input-buffer/flush buffer) - (let ((end-index (input-buffer/end-index buffer))) - (if (< (input-buffer/start-index buffer) end-index) - (set-input-buffer/start-index! buffer end-index)))) + (set-input-buffer/start-index! buffer (input-buffer/end-index buffer))) (define (input-buffer/buffered-chars buffer) - (- (input-buffer/end-index buffer) (input-buffer/start-index buffer))) + (fix:- (input-buffer/end-index buffer) (input-buffer/start-index buffer))) (define (input-buffer/chars-remaining buffer) (let ((channel (input-buffer/channel buffer))) (and (channel-type=file? channel) - (let ((n (- (file-length channel) (file-position channel)))) - (and (not (negative? n)) - (+ (input-buffer/buffered-chars buffer) n)))))) + (let ((n (fix:- (file-length channel) (file-position channel)))) + (and (fix:>= n 0) + (fix:+ (input-buffer/buffered-chars buffer) n)))))) (define (input-buffer/char-ready? buffer interval) - (let ((fill - (if (positive? interval) - (lambda () - (let ((timeout (+ (real-time-clock) interval))) - (let loop () - (cond ((input-buffer/fill buffer) true) - ((< (real-time-clock) timeout) (loop)) - (else false))))) - (lambda () - (input-buffer/fill buffer))))) - (char-ready? buffer - (lambda (buffer) - (let ((channel (input-buffer/channel buffer))) - (case (channel-blocking? channel) - ((#F) (fill)) - ((#T) (with-channel-blocking channel false fill)) - (else false))))))) + (char-ready? buffer + (lambda (buffer) + (with-channel-blocking (input-buffer/channel buffer) false + (lambda () + (if (positive? interval) + (let ((timeout (+ (real-time-clock) interval))) + (let loop () + (let ((n (input-buffer/fill buffer))) + (if n + (fix:> n 0) + (and (< (real-time-clock) timeout) + (loop)))))) + (input-buffer/fill* buffer))))))) (define (char-ready? buffer fill) (let ((end-index (input-buffer/end-index buffer))) - (cond ((< (input-buffer/start-index buffer) end-index) true) - ((zero? (input-buffer/end-index buffer)) false) + (cond ((fix:= (input-buffer/end-index buffer) 0) false) + ((fix:< (input-buffer/start-index buffer) end-index) true) (else (fill buffer))))) + +(define (input-buffer/eof? buffer) + ;; This returns true iff it knows that it is at EOF. + ;; If BUFFER is non-blocking with no input available, it returns false. + (and (not (input-buffer/char-ready? buffer 0)) + (fix:= (input-buffer/end-index buffer) 0))) (define (input-buffer/fill buffer) (let ((end-index (let ((string (input-buffer/string buffer))) (channel-read (input-buffer/channel buffer) string 0 (string-length string))))) - (and end-index - (begin - (set-input-buffer/start-index! buffer 0) - (set-input-buffer/end-index! buffer end-index) - (not (zero? end-index)))))) + (if end-index + (begin + (set-input-buffer/start-index! buffer 0) + (set-input-buffer/end-index! buffer end-index))) + end-index)) + +(define-integrable (input-buffer/fill* buffer) + (let ((n (input-buffer/fill buffer))) + (and n (fix:> n 0)))) (define (input-buffer/read-char buffer) (let ((start-index (input-buffer/start-index buffer)) (end-index (input-buffer/end-index buffer))) - (if (< start-index end-index) - (begin - (set-input-buffer/start-index! buffer (1+ start-index)) - (string-ref (input-buffer/string buffer) start-index)) - (and (not (zero? end-index)) - (input-buffer/fill buffer) - (begin - (set-input-buffer/start-index! buffer 1) - (string-ref (input-buffer/string buffer) 0)))))) + (cond ((fix:< start-index end-index) + (set-input-buffer/start-index! buffer (fix:+ start-index 1)) + (string-ref (input-buffer/string buffer) start-index)) + ((fix:= end-index 0) + eof-object) + (else + (let ((n (input-buffer/fill buffer))) + (cond ((not n) false) + ((fix:= n 0) eof-object) + (else + (set-input-buffer/start-index! buffer 1) + (string-ref (input-buffer/string buffer) 0)))))))) (define (input-buffer/peek-char buffer) (let ((start-index (input-buffer/start-index buffer)) (end-index (input-buffer/end-index buffer))) - (if (< start-index end-index) - (string-ref (input-buffer/string buffer) start-index) - (and (not (zero? end-index)) - (input-buffer/fill buffer) - (string-ref (input-buffer/string buffer) 0))))) + (cond ((fix:< start-index end-index) + (string-ref (input-buffer/string buffer) start-index)) + ((fix:= end-index 0) + eof-object) + (else + (let ((n (input-buffer/fill buffer))) + (cond ((not n) false) + ((fix:= n 0) eof-object) + (else (string-ref (input-buffer/string buffer) 0)))))))) (define (input-buffer/discard-char buffer) (let ((start-index (input-buffer/start-index buffer))) - (if (< start-index (input-buffer/end-index buffer)) - (set-input-buffer/start-index! buffer (1+ start-index))))) + (if (fix:< start-index (input-buffer/end-index buffer)) + (set-input-buffer/start-index! buffer (fix:+ start-index 1))))) (define (input-buffer/read-substring buffer string start end) (let ((start-index (input-buffer/start-index buffer)) (end-index (input-buffer/end-index buffer))) - (cond ((< start-index end-index) + (cond ((fix:< start-index end-index) (let ((string* (input-buffer/string buffer)) - (available (- end-index start-index)) - (needed (- end start))) - (if (>= available needed) + (available (fix:- end-index start-index)) + (needed (fix:- end start))) + (if (fix:>= available needed) (begin - (let ((end-index (+ start-index needed))) + (let ((end-index (fix:+ start-index needed))) (substring-move-left! string* start-index end-index string start) (set-input-buffer/start-index! buffer end-index)) @@ -606,52 +631,58 @@ MIT in each case. |# (substring-move-left! string* start-index end-index string start) (set-input-buffer/start-index! buffer end-index) - (+ available - (or (channel-read (input-buffer/channel buffer) - string - (+ start available) - end) - 0)))))) - ((zero? end-index) + (fix:+ available + (or (channel-read (input-buffer/channel buffer) + string + (fix:+ start available) + end) + 0)))))) + ((fix:= end-index 0) 0) (else (channel-read (input-buffer/channel buffer) string start end))))) (define (input-buffer/read-until-delimiter buffer delimiters) - (and (char-ready? buffer input-buffer/fill) - (let ((string (input-buffer/string buffer))) - (let loop () - (let ((start-index (input-buffer/start-index buffer)) - (end-index (input-buffer/end-index buffer))) - (let ((delimiter-index - (substring-find-next-char-in-set string - start-index - end-index - delimiters))) - (if delimiter-index - (let ((head (substring string start-index delimiter-index))) - (set-input-buffer/start-index! buffer delimiter-index) - head) - (let ((head (substring string start-index end-index))) - (set-input-buffer/start-index! buffer end-index) - (if (input-buffer/fill buffer) - (string-append head (loop)) - head))))))))) + (with-channel-blocking (input-buffer/channel buffer) true + (lambda () + (if (char-ready? buffer input-buffer/fill*) + (let ((string (input-buffer/string buffer))) + (let loop () + (let ((start-index (input-buffer/start-index buffer)) + (end-index (input-buffer/end-index buffer))) + (let ((delimiter-index + (substring-find-next-char-in-set string + start-index + end-index + delimiters))) + (if delimiter-index + (let ((head + (substring string start-index delimiter-index))) + (set-input-buffer/start-index! buffer delimiter-index) + head) + (let ((head (substring string start-index end-index))) + (set-input-buffer/start-index! buffer end-index) + (if (input-buffer/fill* buffer) + (string-append head (loop)) + head))))))) + eof-object)))) (define (input-buffer/discard-until-delimiter buffer delimiters) - (if (char-ready? buffer input-buffer/fill) - (let ((string (input-buffer/string buffer))) - (let loop () - (let ((end-index (input-buffer/end-index buffer))) - (let ((delimiter-index - (substring-find-next-char-in-set - string - (input-buffer/start-index buffer) - end-index - delimiters))) - (if delimiter-index - (set-input-buffer/start-index! buffer delimiter-index) - (begin - (set-input-buffer/start-index! buffer end-index) - (if (input-buffer/fill buffer) - (loop)))))))))) \ No newline at end of file + (with-channel-blocking (input-buffer/channel buffer) true + (lambda () + (if (char-ready? buffer input-buffer/fill*) + (let ((string (input-buffer/string buffer))) + (let loop () + (let ((end-index (input-buffer/end-index buffer))) + (let ((delimiter-index + (substring-find-next-char-in-set + string + (input-buffer/start-index buffer) + end-index + delimiters))) + (if delimiter-index + (set-input-buffer/start-index! buffer delimiter-index) + (begin + (set-input-buffer/start-index! buffer end-index) + (if (input-buffer/fill* buffer) + (loop)))))))))))) \ No newline at end of file diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index a665bf879..ba03be578 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.23 1990/07/20 01:20:52 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.24 1990/11/09 08:44:06 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -316,6 +316,8 @@ MIT in each case. |# (RUNTIME CONSOLE-INPUT) (RUNTIME CONSOLE-OUTPUT) (RUNTIME TRANSCRIPT) + (RUNTIME GENERIC-INPUT) + (RUNTIME GENERIC-OUTPUT) (RUNTIME FILE-INPUT) (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) @@ -353,6 +355,7 @@ MIT in each case. |# (RUNTIME) (RUNTIME X-GRAPHICS) (RUNTIME STARBASE-GRAPHICS) + (RUNTIME SUBPROCESS) ;; Emacs -- last because it grabs the kitchen sink. (RUNTIME EMACS-INTERFACE))) diff --git a/v7/src/runtime/parse.scm b/v7/src/runtime/parse.scm index 92cbcbe84..5719ab670 100644 --- a/v7/src/runtime/parse.scm +++ b/v7/src/runtime/parse.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.12 1990/10/10 06:30:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.13 1990/11/09 08:44:12 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -155,11 +155,6 @@ MIT in each case. |# (define (within-parser port parser-table thunk) (fluid-let ((*parser-input-port* port) - (*parser-peek-char* (input-port/operation/peek-char port)) - (*parser-discard-char* (input-port/operation/discard-char port)) - (*parser-read-char* (input-port/operation/read-char port)) - (*parser-read-string* (input-port/operation/read-string port)) - (*parser-discard-chars* (input-port/operation/discard-chars port)) (*parser-parse-object-table* (parser-table/parse-object parser-table)) (*parser-collect-list-table* (parser-table/collect-list parser-table)) (*parser-parse-object-special-table* @@ -171,34 +166,37 @@ MIT in each case. |# ;;;; Character Operations (define *parser-input-port*) -(define *parser-peek-char*) -(define *parser-discard-char*) -(define *parser-read-char*) -(define *parser-read-string*) -(define *parser-discard-chars*) -(define-integrable (peek-char) - (or (peek-char/eof-ok) - (parse-error/end-of-file))) +(define (peek-char) + (let ((char (peek-char/eof-ok))) + (if (eof-object? char) + (parse-error/end-of-file)) + char)) -(define-integrable (peek-char/eof-ok) - (*parser-peek-char* *parser-input-port*)) +(define (peek-char/eof-ok) + (let loop () + (or (input-port/peek-char *parser-input-port*) + (loop)))) -(define-integrable (read-char) - (or (read-char/eof-ok) - (parse-error/end-of-file))) +(define (read-char) + (let ((char (read-char/eof-ok))) + (if (eof-object? char) + (parse-error/end-of-file)) + char)) -(define-integrable (read-char/eof-ok) - (*parser-read-char* *parser-input-port*)) +(define (read-char/eof-ok) + (let loop () + (or (input-port/read-char *parser-input-port*) + (loop)))) (define-integrable (discard-char) - (*parser-discard-char* *parser-input-port*)) + (input-port/discard-char *parser-input-port*)) (define-integrable (read-string delimiters) - (*parser-read-string* *parser-input-port* delimiters)) + (input-port/read-string *parser-input-port* delimiters)) (define-integrable (discard-chars delimiters) - (*parser-discard-chars* *parser-input-port* delimiters)) + (input-port/discard-chars *parser-input-port* delimiters)) (define (parse-error/end-of-file) (parse-error "end of file")) @@ -218,10 +216,10 @@ MIT in each case. |# (define-integrable (parse-object/dispatch) (let ((char (peek-char/eof-ok))) - (if char + (if (eof-object? char) + char ((vector-ref *parser-parse-object-table* - (or (char-ascii? char) (parse-error/non-ascii)))) - (make-eof-object *parser-input-port*)))) + (or (char-ascii? char) (parse-error/non-ascii))))))) (define-integrable (collect-list/dispatch) ((vector-ref *parser-collect-list-table* (peek-ascii)))) @@ -392,10 +390,12 @@ MIT in each case. |# (if (char=? #\# (peek-char)) (discard-char) (loop)) - (begin (if (char=? #\| (peek-char)) - (begin (discard-char) - (loop))) - (loop))))) + (begin + (if (char=? #\| (peek-char)) + (begin + (discard-char) + (loop))) + (loop))))) ;;;; Quoting @@ -410,8 +410,9 @@ MIT in each case. |# (define (parse-object/unquote) (discard-char) (if (char=? #\@ (peek-char)) - (begin (discard-char) - (list 'UNQUOTE-SPLICING (parse-object/dispatch))) + (begin + (discard-char) + (list 'UNQUOTE-SPLICING (parse-object/dispatch))) (list 'UNQUOTE (parse-object/dispatch)))) (define (parse-object/string-quote) @@ -459,10 +460,11 @@ MIT in each case. |# (else (let ((string (read-string char-set/char-delimiters))) (if (let ((char (peek-char/eof-ok))) - (and char + (and (not (eof-object? char)) (char=? #\- char))) - (begin (discard-char) - (string-append string "-" (loop))) + (begin + (discard-char) + (string-append string "-" (loop))) string)))))))) ;;;; Constants diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index c67b2047f..dc617c772 100644 --- a/v7/src/runtime/process.scm +++ b/v7/src/runtime/process.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.3 1990/03/24 19:14:13 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.4 1990/11/09 08:44:17 cph Rel $ Copyright (c) 1989, 1990 Massachusetts Institute of Technology @@ -32,69 +32,135 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Subprocess support -;;; package: (runtime subprocesses) +;;;; Subprocess Support +;;; package: (runtime subprocess) (declare (usual-integrations)) -(define (initialize-package!) +(define-structure (subprocess + (constructor %make-subprocess) + (conc-name subprocess-)) + (index false read-only true) + (ctty-type false read-only true) + (pty false read-only true) + (id false read-only true) + (synchronous? false read-only true) + ;; Input to the subprocess; an OUTPUT port. + (input-port false read-only true) + ;; Output from the subprocess; an INPUT port. + (output-port false read-only true)) + +(define (make-subprocess filename arguments environment ctty-type) + (let ((index + ((ucode-primitive make-subprocess 4) + filename + arguments + environment + (case ctty-type + ((none) 0) + ((inherited) 1) + ((pipe) 2) + ((pty) 3) + (else (error:illegal-datum ctty-type 'MAKE-SUBPROCESS)))))) + (let ((input-channel + (without-interrupts + (lambda () + (make-channel ((ucode-primitive process-input 1) index))))) + (output-channel + (without-interrupts + (lambda () + (make-channel ((ucode-primitive process-output 1) index))))) + (ctty-type + (let ((type ((ucode-primitive process-ctty-type 1) index)) + (types '#(NONE INHERITED PIPE PTY))) + (and (< type (vector-length types)) + (vector-ref types type))))) + (let ((input-port (make-generic-output-port input-channel 512)) + (output-port (make-generic-input-port output-channel 512))) + (set-input-port/associated-port! input-port output-port) + (set-output-port/associated-port! output-port input-port) + (let ((process + (%make-subprocess + index + ctty-type + (and (eq? ctty-type 'PTY) input-channel) + ((ucode-primitive process-id 1) index) + ((ucode-primitive process-synchronous? 1) index) + input-port + output-port))) + (set! subprocesses (cons process subprocesses)) + process))))) + +(define (subprocess-delete process) + (close-output-port (subprocess-input-port process)) + (close-input-port (subprocess-output-port process)) + ((ucode-primitive process-delete 1) (subprocess-index process)) + (set! subprocesses (delq! process subprocesses)) unspecific) -(let-syntax - ((define-special-primitives - (macro names - `(DEFINE-PRIMITIVES - ,@(map (lambda (name) - (let ((name (car name)) - (arity (cadr name))) - (list (symbol-append 'prim- name) - name - arity))) - names))))) - (define-special-primitives - (create-process 1) - (process-get-pid 1) - (process-get-input-channel 1) - (process-get-output-channel 1) - (process-get-status-flags 1) - (process-char-ready? 2))) - -(let-syntax - ((define-process-primitives - (macro names - `(BEGIN ,@(map (lambda (name) - `(BEGIN - (DEFINE (,name PROCESS) - (,(symbol-append 'prim- name) - (PROCESS/MICROCODE-PROCESS PROCESS))))) - names))))) - (define-process-primitives - process-get-pid - process-get-input-channel - process-get-output-channel - process-get-status-flags)) - -(define-structure (process - (conc-name process/) - (constructor make-process - (command-string microcode-process))) - (command-string false read-only true) ;original command - (microcode-process false read-only true) ;index into microcode - ;process table - (to-port false) ;port to write to process - (from-port false) ;port to read from process - ) - -(define (create-process command-string) - (let* ((prim-process ((ucode-primitive create-process 1) command-string)) - (process (make-process command-string prim-process))) - (set-process/to-port! process (open-process-output process)) - (set-process/from-port! process (open-process-input process)) - process)) - -(define (kill-process process) - ((ucode-primitive kill-process 1) (process/microcode-process process))) - -(define (delete-process process) - (close-output-port (process/to-port process)) - (kill-process process)) \ No newline at end of file +(define (subprocess-list) + (list-copy subprocesses)) + +(define subprocesses) +(define scheme-subprocess-environment) + +(define (initialize-package!) + (reset-package!) + (add-event-receiver! event:after-restore reset-package!)) + +(define (reset-package!) + (set! subprocesses '()) + (set! scheme-subprocess-environment ((ucode-primitive scheme-environment 0))) + unspecific) + +(define (subprocess-status process) + (let ((index (subprocess-index process))) + (let ((status + (let ((status ((ucode-primitive process-status 1) index)) + (statuses '#(RUNNING STOPPED EXITED SIGNALLED UNSTARTED))) + (and (< status (vector-length statuses)) + (vector-ref statuses status))))) + (if (or (eq? status 'STOPPED) + (eq? status 'EXITED) + (eq? status 'SIGNALLED)) + (cons status ((ucode-primitive process-reason 1) index)) + status)))) + +(define-integrable os-job-control? + (ucode-primitive os-job-control? 0)) + +(define (subprocess-signal process signal to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-signal 2) (subprocess-index process) signal) + (pty-master-send-signal pty signal)))) + +(define (subprocess-kill process to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-kill 1) (subprocess-index process)) + (pty-master-kill pty)))) + +(define (subprocess-stop process to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-stop 1) (subprocess-index process)) + (pty-master-stop pty)))) + +(define (subprocess-continue process to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-continue 1) (subprocess-index process)) + (pty-master-continue pty)))) + +(define (subprocess-interrupt process to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-interrupt 1) (subprocess-index process)) + (pty-master-interrupt pty)))) + +(define (subprocess-quit process to-process-group?) + (let ((pty (and to-process-group? (subprocess-pty process)))) + (if (not pty) + ((ucode-primitive process-quit 1) (subprocess-index process)) + (pty-master-quit pty)))) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index e2996782d..13542a61a 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.82 1990/11/02 02:06:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.83 1990/11/09 08:44:23 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -690,6 +690,63 @@ MIT in each case. |# hook/record-statistic!) (initialization (initialize-package!))) +(define-package (runtime generic-input) + (files "genin") + (parent ()) + (export (runtime console-input) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/char-ready? + operation/set-buffer-size) + (export (runtime file-input) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/char-ready? + operation/chars-remaining + operation/close + operation/discard-char + operation/discard-chars + operation/eof? + operation/peek-char + operation/read-char + operation/read-chars + operation/read-string + operation/set-buffer-size) + (export (runtime socket) + make-generic-input-port + set-input-port/associated-port!) + (export (runtime subprocess) + make-generic-input-port + set-input-port/associated-port!) + (initialization (initialize-package!))) + +(define-package (runtime generic-output) + (files "genout") + (parent ()) + (export (runtime console-output) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/set-buffer-size) + (export (runtime file-output) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/close + operation/flush-output + operation/set-buffer-size + operation/write-char + operation/write-string) + (export (runtime socket) + make-generic-output-port + set-output-port/associated-port!) + (export (runtime subprocess) + make-generic-output-port + set-output-port/associated-port!) + (initialization (initialize-package!))) + (define-package (runtime gensym) (files "gensym") (parent ()) @@ -812,6 +869,8 @@ MIT in each case. |# set-input-port/state! with-input-from-file with-input-from-port) + (export (runtime primitive-io) + eof-object) (initialization (initialize-package!))) (define-package (runtime interrupt-handler) @@ -1343,9 +1402,20 @@ MIT in each case. |# (export () close-all-open-files copy-file) - (export (runtime file-input) - file-length - file-open-input-channel + (export (runtime socket) + channel-close + channel-descriptor + make-channel + with-channel-blocking) + (export (runtime subprocess) + make-channel + pty-master-continue + pty-master-interrupt + pty-master-kill + pty-master-quit + pty-master-send-signal + pty-master-stop) + (export (runtime generic-input) input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1353,45 +1423,54 @@ MIT in each case. |# input-buffer/close input-buffer/discard-char input-buffer/discard-until-delimiter + input-buffer/eof? input-buffer/peek-char input-buffer/read-char input-buffer/read-substring input-buffer/read-until-delimiter + input-buffer/set-size + input-buffer/size make-input-buffer) - (export (runtime file-output) - channel-close - channel-write-char-block - channel-write-string-block - file-open-append-channel - file-open-output-channel + (export (runtime generic-output) make-output-buffer output-buffer/buffered-chars + output-buffer/channel output-buffer/close output-buffer/drain-block output-buffer/set-size output-buffer/size - output-buffer/write-char-block output-buffer/write-string-block) - (export (runtime console-output) - channel-write-char-block - channel-write-string-block - make-output-buffer - output-buffer/buffered-chars - output-buffer/drain-block - output-buffer/set-size - output-buffer/size - output-buffer/write-char-block - output-buffer/write-string-block - tty-output-channel) + (export (runtime file-input) + file-length + file-open-input-channel + input-buffer/chars-remaining + input-buffer/read-substring + make-input-buffer) + (export (runtime file-output) + file-open-append-channel + file-open-output-channel + make-output-buffer) (export (runtime console-input) channel-type=file? input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? + input-buffer/eof? input-buffer/peek-char input-buffer/read-char + input-buffer/set-size + input-buffer/size make-input-buffer tty-input-channel) + (export (runtime console-output) + make-output-buffer + output-buffer/buffered-chars + output-buffer/channel + output-buffer/drain-block + output-buffer/set-size + output-buffer/size + output-buffer/write-string-block + tty-output-channel) (export (runtime rep) channel-type=terminal? terminal-cooked-input @@ -1744,6 +1823,37 @@ MIT in each case. |# scode-walker?) (initialization (initialize-package!))) +(define-package (runtime socket) + (files "socket") + (parent ()) + (export () + open-tcp-server-socket + open-tcp-stream-socket + open-unix-stream-socket + tcp-server-connection-accept)) + +(define-package (runtime subprocess) + (files "process") + (parent ()) + (export () + make-subprocess + os-job-control? + scheme-subprocess-environment + subprocess-continue + subprocess-ctty-type + subprocess-delete + subprocess-id + subprocess-input-port + subprocess-interrupt + subprocess-kill + subprocess-list + subprocess-output-port + subprocess-quit + subprocess-signal + subprocess-status + subprocess-stop) + (initialization (initialize-package!))) + (define-package (runtime graphics) (files "graphics") (parent ()) diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index aa8a40211..dab66dc5c 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.2 1988/06/13 11:51:51 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.3 1990/11/09 08:44:34 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -83,31 +83,35 @@ MIT in each case. |# (< (input-port/start port) (input-port/end port))) (define (operation/peek-char port) - (and (< (input-port/start port) (input-port/end port)) - (string-ref (input-port/string port) (input-port/start port)))) + (if (< (input-port/start port) (input-port/end port)) + (string-ref (input-port/string port) (input-port/start port)) + (make-eof-object port))) (define (operation/discard-char port) (set-input-port/start! port (1+ (input-port/start port)))) (define (operation/read-char port) (let ((start (input-port/start port))) - (and (< start (input-port/end port)) - (begin (set-input-port/start! port (1+ start)) - (string-ref (input-port/string port) start))))) + (if (< start (input-port/end port)) + (begin + (set-input-port/start! port (1+ start)) + (string-ref (input-port/string port) start)) + (make-eof-object port)))) (define (operation/read-string port delimiters) (let ((start (input-port/start port)) (end (input-port/end port))) - (and (< start end) - (let ((string (input-port/string port))) - (let ((index - (or (substring-find-next-char-in-set string - start - end - delimiters) - end))) - (set-input-port/start! port index) - (substring string start index)))))) + (if (< start end) + (let ((string (input-port/string port))) + (let ((index + (or (substring-find-next-char-in-set string + start + end + delimiters) + end))) + (set-input-port/start! port index) + (substring string start index))) + (make-eof-object port)))) (define (operation/discard-chars port delimiters) (let ((start (input-port/start port)) diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index f9e6e5023..837a06cf8 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.8 1990/04/04 18:51:37 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.9 1990/11/09 08:44:51 cph Rel $ Copyright (c) 1988, 1989 Massachusetts Institute of Technology @@ -91,9 +91,8 @@ MIT in each case. |# (inode-number false read-only true)) (define (file-modification-time filename) - (let ((attributes (file-attributes-indirect filename))) - (and attributes - (file-attributes/modification-time attributes)))) + ((ucode-primitive file-mod-time-indirect 1) + (pathname->string (pathname->absolute-pathname (->pathname filename))))) (define (get-environment-variable name) (or ((ucode-primitive get-environment-variable) name) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index a6629d0ef..a3f09342c 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.100 1990/11/02 02:07:08 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.101 1990/11/09 08:44:55 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 100)) + (add-identification! "Runtime" 14 101)) (define microcode-system) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 7fba2de4f..305245514 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.23 1990/07/20 01:20:52 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.24 1990/11/09 08:44:06 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -316,6 +316,8 @@ MIT in each case. |# (RUNTIME CONSOLE-INPUT) (RUNTIME CONSOLE-OUTPUT) (RUNTIME TRANSCRIPT) + (RUNTIME GENERIC-INPUT) + (RUNTIME GENERIC-OUTPUT) (RUNTIME FILE-INPUT) (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) @@ -353,6 +355,7 @@ MIT in each case. |# (RUNTIME) (RUNTIME X-GRAPHICS) (RUNTIME STARBASE-GRAPHICS) + (RUNTIME SUBPROCESS) ;; Emacs -- last because it grabs the kitchen sink. (RUNTIME EMACS-INTERFACE))) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 41e3f0d03..023f8d37e 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.82 1990/11/02 02:06:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.83 1990/11/09 08:44:23 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -690,6 +690,63 @@ MIT in each case. |# hook/record-statistic!) (initialization (initialize-package!))) +(define-package (runtime generic-input) + (files "genin") + (parent ()) + (export (runtime console-input) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/char-ready? + operation/set-buffer-size) + (export (runtime file-input) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/char-ready? + operation/chars-remaining + operation/close + operation/discard-char + operation/discard-chars + operation/eof? + operation/peek-char + operation/read-char + operation/read-chars + operation/read-string + operation/set-buffer-size) + (export (runtime socket) + make-generic-input-port + set-input-port/associated-port!) + (export (runtime subprocess) + make-generic-input-port + set-input-port/associated-port!) + (initialization (initialize-package!))) + +(define-package (runtime generic-output) + (files "genout") + (parent ()) + (export (runtime console-output) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/set-buffer-size) + (export (runtime file-output) + operation/buffer-size + operation/buffered-chars + operation/channel + operation/close + operation/flush-output + operation/set-buffer-size + operation/write-char + operation/write-string) + (export (runtime socket) + make-generic-output-port + set-output-port/associated-port!) + (export (runtime subprocess) + make-generic-output-port + set-output-port/associated-port!) + (initialization (initialize-package!))) + (define-package (runtime gensym) (files "gensym") (parent ()) @@ -812,6 +869,8 @@ MIT in each case. |# set-input-port/state! with-input-from-file with-input-from-port) + (export (runtime primitive-io) + eof-object) (initialization (initialize-package!))) (define-package (runtime interrupt-handler) @@ -1343,9 +1402,20 @@ MIT in each case. |# (export () close-all-open-files copy-file) - (export (runtime file-input) - file-length - file-open-input-channel + (export (runtime socket) + channel-close + channel-descriptor + make-channel + with-channel-blocking) + (export (runtime subprocess) + make-channel + pty-master-continue + pty-master-interrupt + pty-master-kill + pty-master-quit + pty-master-send-signal + pty-master-stop) + (export (runtime generic-input) input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1353,45 +1423,54 @@ MIT in each case. |# input-buffer/close input-buffer/discard-char input-buffer/discard-until-delimiter + input-buffer/eof? input-buffer/peek-char input-buffer/read-char input-buffer/read-substring input-buffer/read-until-delimiter + input-buffer/set-size + input-buffer/size make-input-buffer) - (export (runtime file-output) - channel-close - channel-write-char-block - channel-write-string-block - file-open-append-channel - file-open-output-channel + (export (runtime generic-output) make-output-buffer output-buffer/buffered-chars + output-buffer/channel output-buffer/close output-buffer/drain-block output-buffer/set-size output-buffer/size - output-buffer/write-char-block output-buffer/write-string-block) - (export (runtime console-output) - channel-write-char-block - channel-write-string-block - make-output-buffer - output-buffer/buffered-chars - output-buffer/drain-block - output-buffer/set-size - output-buffer/size - output-buffer/write-char-block - output-buffer/write-string-block - tty-output-channel) + (export (runtime file-input) + file-length + file-open-input-channel + input-buffer/chars-remaining + input-buffer/read-substring + make-input-buffer) + (export (runtime file-output) + file-open-append-channel + file-open-output-channel + make-output-buffer) (export (runtime console-input) channel-type=file? input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? + input-buffer/eof? input-buffer/peek-char input-buffer/read-char + input-buffer/set-size + input-buffer/size make-input-buffer tty-input-channel) + (export (runtime console-output) + make-output-buffer + output-buffer/buffered-chars + output-buffer/channel + output-buffer/drain-block + output-buffer/set-size + output-buffer/size + output-buffer/write-string-block + tty-output-channel) (export (runtime rep) channel-type=terminal? terminal-cooked-input @@ -1744,6 +1823,37 @@ MIT in each case. |# scode-walker?) (initialization (initialize-package!))) +(define-package (runtime socket) + (files "socket") + (parent ()) + (export () + open-tcp-server-socket + open-tcp-stream-socket + open-unix-stream-socket + tcp-server-connection-accept)) + +(define-package (runtime subprocess) + (files "process") + (parent ()) + (export () + make-subprocess + os-job-control? + scheme-subprocess-environment + subprocess-continue + subprocess-ctty-type + subprocess-delete + subprocess-id + subprocess-input-port + subprocess-interrupt + subprocess-kill + subprocess-list + subprocess-output-port + subprocess-quit + subprocess-signal + subprocess-status + subprocess-stop) + (initialization (initialize-package!))) + (define-package (runtime graphics) (files "graphics") (parent ()) -- 2.25.1