From b3432362982691c8bc0ae4d0f5205deb558e391f Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 15 Nov 1991 05:15:24 +0000 Subject: [PATCH] Redesign ports. New design supports bidirectional ports. Old code should continue to work, with two (unlikely) exceptions: the input/output port pairs for sockets and processes are now implemented as bidirectional ports, and closing one of the ports automatically closes the other as well. * New procedures: CLOSE-PORT I/O-PORT? MAKE-GENERIC-I/O-PORT MAKE-I/O-PORT OPEN-I/O-FILE PORT/COPY PORT/INPUT-CHANNEL PORT/OPERATION PORT/OPERATION-NAMES PORT/OUTPUT-CHANNEL PORT/STATE PORT? SET-PORT/STATE! SUBPROCESS-I/O-PORT * New global variable CONSOLE-I/O-PORT identifies the bidirectional port that communicates with Scheme's console. CONSOLE-INPUT-PORT and CONSOLE-OUTPUT-PORT are initially EQ? to this port. * Obsolete procedures: Old name New name ---------------------------- -------------------- INPUT-PORT/CHANNEL PORT/INPUT-CHANNEL INPUT-PORT/COPY PORT/COPY INPUT-PORT/CUSTOM-OPERATION PORT/OPERATION INPUT-PORT/OPERATION PORT/OPERATION INPUT-PORT/OPERATION-NAMES PORT/OPERATION-NAMES INPUT-PORT/STATE PORT/STATE OUTPUT-PORT/CHANNEL PORT/OUTPUT-CHANNEL OUTPUT-PORT/COPY PORT/COPY OUTPUT-PORT/CUSTOM-OPERATION PORT/OPERATION OUTPUT-PORT/OPERATION PORT/OPERATION OUTPUT-PORT/OPERATION-NAMES PORT/OPERATION-NAMES OUTPUT-PORT/STATE PORT/STATE SET-INPUT-PORT/STATE! SET-PORT/STATE! SET-OUTPUT-PORT/STATE! SET-PORT/STATE! SUBPROCESS-INPUT-PORT SUBPROCESS-I/O-PORT SUBPROCESS-OUTPUT-PORT SUBPROCESS-I/O-PORT For now these procedures still exist. * Obsolete input-port operations: Old name New name --------------- --------------------- BUFFER-SIZE INPUT-BUFFER-SIZE BUFFERED-CHARS BUFFERED-INPUT-CHARS CHANNEL INPUT-CHANNEL SET-BUFFER-SIZE SET-INPUT-BUFFER-SIZE INPUT-PORT/OPERATION and INPUT-PORT/CUSTOM-OPERATION perform these translations so your programs should continue to work. * Obsolete output-port operations: Old name New name --------------- --------------------- BUFFER-SIZE OUTPUT-BUFFER-SIZE BUFFERED-CHARS BUFFERED-OUTPUT-CHARS CHANNEL OUTPUT-CHANNEL SET-BUFFER-SIZE SET-OUTPUT-BUFFER-SIZE OUTPUT-PORT/OPERATION and OUTPUT-PORT/CUSTOM-OPERATION perform these translations so your programs should continue to work. * The ASSOCIATED-PORT operation is no longer implemented by any runtime system port. Ports that previously supported this operation are now bidirectional. * WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE no longer close the port when they are exited abnormally. * Change cold-boot sequence to permit records to be used in most of runtime system. * New procedure RECORD-COPY. * New files "genio.scm", "fileio.scm", and "ttyio.scm" replace old files "genin.scm", "genout.scm", "filein.scm", "filout.scm", "ttyin.scm", and "ttyout.scm". * New file "port.scm". --- v7/src/runtime/input.scm | 158 ++----------------------- v7/src/runtime/make.scm | 27 ++--- v7/src/runtime/output.scm | 140 ++++------------------- v7/src/runtime/process.scm | 69 ++++++----- v7/src/runtime/record.scm | 28 +++-- v7/src/runtime/runtime.pkg | 229 ++++++++++++++++++------------------- v7/src/runtime/socket.scm | 16 +-- v8/src/runtime/make.scm | 27 ++--- v8/src/runtime/runtime.pkg | 229 ++++++++++++++++++------------------- 9 files changed, 335 insertions(+), 588 deletions(-) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 27539e65f..f0a74048c 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.12 1991/02/15 18:05:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.13 1991/11/15 05:14:52 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -39,127 +39,11 @@ MIT in each case. |# ;;;; Input Ports -(define (initialize-package!) - (set! *current-input-port* console-input-port)) - -(define (input-port/unparse state port) - ((unparser/standard-method 'INPUT-PORT - (input-port/custom-operation port 'PRINT-SELF)) - state - port)) - -(define-structure (input-port (conc-name input-port/) - (constructor %make-input-port) - (copier %input-port/copy) - (print-procedure input-port/unparse)) - state - (operation/char-ready? false read-only true) - (operation/peek-char false read-only true) - (operation/read-char false read-only true) - (operation/discard-char false read-only true) - (operation/read-string false read-only true) - (operation/discard-chars false read-only true) - (custom-operations false read-only true) - (operation-names false read-only true)) - (define (guarantee-input-port port) (if (not (input-port? port)) (error:wrong-type-argument port "input port" false)) port) -(define (input-port/copy port state) - (guarantee-input-port port) - (let ((result (%input-port/copy port))) - (set-input-port/state! result state) - result)) - -(define (input-port/custom-operation port name) - (guarantee-input-port port) - (let ((entry (assq name (input-port/custom-operations port)))) - (and entry - (cdr entry)))) - -(define (input-port/operation port name) - ;; Try the custom operations first since the user is less likely to - ;; use this procedure to access the standard operations. - (or (input-port/custom-operation port name) - (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)) - (else false)))) - -(define (make-input-port operations state) - (let ((operations - (map (lambda (entry) - (cons (car entry) (cadr entry))) - operations))) - (let ((operation - (lambda (name default) - (let ((entry (assq name operations))) - (if entry - (begin - (set! operations (delq! entry operations)) - (cdr entry)) - (or default - (error "MAKE-INPUT-PORT: missing operation" name))))))) - (let ((char-ready? (operation 'CHAR-READY? false)) - (peek-char (operation 'PEEK-CHAR false)) - (read-char (operation 'READ-CHAR false))) - (let ((discard-char (operation 'DISCARD-CHAR read-char)) - (read-string - (operation 'READ-STRING default-operation/read-string)) - (discard-chars - (operation 'DISCARD-CHARS default-operation/discard-chars))) - (%make-input-port state - char-ready? - peek-char - read-char - discard-char - read-string - discard-chars - operations - (append '(CHAR-READY? - PEEK-CHAR - READ-CHAR - DISCARD-CHAR - READ-STRING - DISCARD-CHARS) - (map car operations)))))))) - -(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 (input-port/char-ready? port interval) ((input-port/operation/char-ready? port) port interval)) @@ -178,11 +62,6 @@ MIT in each case. |# (define (input-port/discard-chars port delimiters) ((input-port/operation/discard-chars port) port delimiters)) -(define (input-port/channel port) - (let ((operation (input-port/custom-operation port 'CHANNEL))) - (and operation - (operation port)))) - (define eof-object "EOF Object") @@ -207,25 +86,17 @@ MIT in each case. |# (guarantee-input-port port) (fluid-let ((*current-input-port* port)) (thunk))) -(define (with-input-from-file input-specifier thunk) - (let ((new-port (open-input-file input-specifier)) - (old-port false)) - (dynamic-wind (lambda () - (set! old-port *current-input-port*) - (set! *current-input-port* new-port) - (set! new-port false)) - thunk - (lambda () - (if *current-input-port* - (close-input-port *current-input-port*)) - (set! *current-input-port* old-port) - (set! old-port false))))) - (define (call-with-input-file input-specifier receiver) (let ((port (open-input-file input-specifier))) (let ((value (receiver port))) - (close-input-port port) + (close-port port) value))) + +(define (with-input-from-file input-specifier thunk) + (call-with-input-file input-specifier + (lambda (port) + (fluid-let ((*current-input-port* port)) + (thunk))))) ;;;; Input Procedures @@ -267,7 +138,7 @@ MIT in each case. |# (guarantee-input-port port)))) (if (input-port/char-ready? port 0) (input-port/read-char port) - (let ((eof? (input-port/custom-operation port 'EOF?))) + (let ((eof? (port/operation port 'EOF?))) (and eof? (eof? port) eof-object))))) @@ -287,16 +158,11 @@ MIT in each case. |# (if (default-object? parser-table) (current-parser-table) (guarantee-parser-table parser-table)))) - (let ((read-start! (input-port/custom-operation port 'READ-START!))) + (let ((read-start! (port/operation port 'READ-START!))) (if read-start! (read-start! port))) (let ((object (parse-object/internal port parser-table))) - (let ((read-finish! (input-port/custom-operation port 'READ-FINISH!))) + (let ((read-finish! (port/operation port 'READ-FINISH!))) (if read-finish! (read-finish! port))) - object))) - -(define (close-input-port port) - (let ((operation (input-port/custom-operation port 'CLOSE))) - (if operation - (operation port)))) \ No newline at end of file + object))) \ No newline at end of file diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index acccda368..f2b40f2de 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.30 1991/11/04 20:29:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.31 1991/11/15 05:14:57 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -246,7 +246,10 @@ MIT in each case. |# ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("boot" . ()) ("queue" . ()) - ("gc" . (RUNTIME GARBAGE-COLLECTOR))))) + ("gc" . (RUNTIME GARBAGE-COLLECTOR)) + ("equals" . ()) + ("list" . (RUNTIME LIST)) + ("record" . (RUNTIME RECORD))))) (if (not (null? files)) (begin (eval (fasload (map-filename (car (car files))) #t) @@ -265,6 +268,8 @@ MIT in each case. |# (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) 'CONSTANT-SPACE/BASE constant-space/base) +(package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE!) ;; Load everything else. ((eval (fasload "runtim.bldr" #f) system-global-environment) @@ -277,7 +282,10 @@ MIT in each case. |# (string=? filename "gdatab") (string=? filename "boot") (string=? filename "queue") - (string=? filename "gc"))) + (string=? filename "gc") + (string=? filename "equals") + (string=? filename "list") + (string=? filename "record"))) (eval (fasload (map-filename filename) #t) environment)) unspecific) `((SORT-TYPE . MERGE-SORT) @@ -297,7 +305,6 @@ MIT in each case. |# (RUNTIME SYSTEM-CLOCK) ;; Basic data structures (RUNTIME NUMBER) - (RUNTIME LIST) (RUNTIME CHARACTER) (RUNTIME CHARACTER-SET) (RUNTIME GENSYM) @@ -305,7 +312,6 @@ MIT in each case. |# (RUNTIME 2D-PROPERTY) (RUNTIME HASH) (RUNTIME RANDOM-NUMBER) - (RUNTIME RECORD) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME LAMBDA-ABSTRACTION) @@ -318,18 +324,13 @@ MIT in each case. |# (RUNTIME ERROR-HANDLER) (RUNTIME MICROCODE-ERRORS) ;; I/O - (RUNTIME CONSOLE-INPUT) - (RUNTIME CONSOLE-OUTPUT) + (RUNTIME GENERIC-I/O-PORT) + (RUNTIME FILE-I/O-PORT) + (RUNTIME CONSOLE-I/O-PORT) (RUNTIME TRANSCRIPT) - (RUNTIME GENERIC-INPUT) - (RUNTIME GENERIC-OUTPUT) - (RUNTIME FILE-INPUT) - (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) (RUNTIME STRING-OUTPUT) (RUNTIME TRUNCATED-STRING-OUTPUT) - (RUNTIME INPUT-PORT) - (RUNTIME OUTPUT-PORT) (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME LOAD) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index ec0a42205..cfb6b9ef0 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.10 1991/07/09 00:49:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.11 1991/11/15 05:15:01 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -39,101 +39,11 @@ MIT in each case. |# ;;;; Output Ports -(define (initialize-package!) - (set! *current-output-port* console-output-port) - (set! beep (wrap-custom-operation-0 'BEEP)) - (set! clear (wrap-custom-operation-0 'CLEAR)) - unspecific) - -(define (output-port/unparse state port) - ((unparser/standard-method 'OUTPUT-PORT - (output-port/custom-operation port 'PRINT-SELF)) - state port)) - -(define-structure (output-port (conc-name output-port/) - (constructor %make-output-port) - (copier %output-port/copy) - (print-procedure output-port/unparse)) - state - (operation/write-char false read-only true) - (operation/write-string false read-only true) - (operation/write-substring false read-only true) - (operation/flush-output false read-only true) - (custom-operations false read-only true) - (operation-names false read-only true)) - (define (guarantee-output-port port) - (if (not (output-port? port)) (error "Bad output port" port)) + (if (not (output-port? port)) + (error:wrong-type-argument port "output port" false)) port) -(define (output-port/copy port state) - (let ((result (%output-port/copy port))) - (set-output-port/state! result state) - result)) - -(define (output-port/custom-operation port name) - (let ((entry (assq name (output-port/custom-operations port)))) - (and entry (cdr entry)))) - -(define (output-port/operation port name) - (or (output-port/custom-operation port name) - (case name - ((WRITE-CHAR) output-port/write-char) - ((WRITE-STRING) output-port/write-string) - ((WRITE-SUBSTRING) output-port/write-substring) - ((FLUSH-OUTPUT) output-port/flush-output) - (else false)))) - -(define (make-output-port operations state) - (let ((operations - (map (lambda (entry) - (cons (car entry) (cadr entry))) - operations))) - (let ((operation - (lambda (name) - (let ((entry (assq name operations))) - (and entry - (begin - (set! operations (delq! entry operations)) - (cdr entry))))))) - (let ((write-char (operation 'WRITE-CHAR)) - (write-string (operation 'WRITE-STRING)) - (write-substring (operation 'WRITE-SUBSTRING)) - (flush-output (operation 'FLUSH-OUTPUT))) - (if (not (or write-char write-substring)) - (error "Must specify at least one of the following:" - '(WRITE-CHAR WRITE-SUBSTRING))) - (%make-output-port state - (or write-char default-operation/write-char) - (or write-string default-operation/write-string) - (or write-substring - default-operation/write-substring) - (or flush-output default-operation/flush-output) - operations - (append '(WRITE-CHAR WRITE-STRING WRITE-SUBSTRING - FLUSH-OUTPUT) - (map car operations))))))) - -(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 (output-port/write-char port char) ((output-port/operation/write-char port) port char)) @@ -150,13 +60,13 @@ MIT in each case. |# ((output-port/operation/flush-output port) port)) (define (output-port/x-size port) - (or (let ((operation (output-port/custom-operation port 'X-SIZE))) + (or (let ((operation (port/operation port 'X-SIZE))) (and operation (operation port))) 79)) -(define (output-port/channel port) - (let ((operation (output-port/custom-operation port 'CHANNEL))) +(define (output-port/y-size port) + (let ((operation (port/operation port 'Y-SIZE))) (and operation (operation port)))) @@ -174,25 +84,17 @@ MIT in each case. |# (guarantee-output-port port) (fluid-let ((*current-output-port* port)) (thunk))) -(define (with-output-to-file output-specifier thunk) - (let ((new-port (open-output-file output-specifier)) - (old-port false)) - (dynamic-wind (lambda () - (set! old-port *current-output-port*) - (set! *current-output-port* new-port) - (set! new-port false)) - thunk - (lambda () - (if *current-output-port* - (close-output-port *current-output-port*)) - (set! *current-output-port* old-port) - (set! old-port false))))) - (define (call-with-output-file output-specifier receiver) (let ((port (open-output-file output-specifier))) (let ((value (receiver port))) - (close-output-port port) + (close-port port) value))) + +(define (with-output-to-file output-specifier thunk) + (call-with-output-file output-specifier + (lambda (port) + (fluid-let ((*current-output-port* port)) + (thunk))))) ;;;; Output Procedures @@ -209,7 +111,7 @@ MIT in each case. |# (if (default-object? port) (current-output-port) (guarantee-output-port port)))) - (let ((operation (output-port/custom-operation port 'FRESH-LINE))) + (let ((operation (port/operation port 'FRESH-LINE))) (if operation (operation port) (output-port/write-char port #\newline))) @@ -231,25 +133,23 @@ MIT in each case. |# (output-port/write-string port string) (output-port/flush-output port))) -(define (close-output-port port) - (let ((operation (output-port/custom-operation port 'CLOSE))) - (if operation - (operation port)))) - (define (wrap-custom-operation-0 operation-name) (lambda (#!optional port) (let ((port (if (default-object? port) (current-output-port) (guarantee-output-port port)))) - (let ((operation (output-port/custom-operation port operation-name))) + (let ((operation (port/operation port operation-name))) (if operation (begin (operation port) (output-port/flush-output port))))))) -(define beep) -(define clear) +(define beep + (wrap-custom-operation-0 'BEEP)) + +(define clear + (wrap-custom-operation-0 'CLEAR)) (define (display object #!optional port unparser-table) (let ((port diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index a2e2019df..dacbf05fc 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.13 1991/10/29 13:27:41 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.14 1991/11/15 05:15:06 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -70,8 +70,7 @@ MIT in each case. |# input-channel output-channel (id ((ucode-primitive process-id 1) index) read-only true) - (%input-port false) - (%output-port false) + (%i/o-port false) (%status false) (exit-reason false) (%status-tick false) @@ -86,33 +85,33 @@ MIT in each case. |# (define (subprocess-remove! process key) (1d-table/remove! (subprocess-properties process) key)) -(define (subprocess-input-port process) +(define (subprocess-i/o-port process) (without-interrupts (lambda () - (or (subprocess-%input-port process) - (let ((channel (subprocess-input-channel process))) - (and channel - (let ((input-port (make-generic-input-port channel 512)) - (output-port (subprocess-%output-port process))) - (set-subprocess-%input-port! process input-port) - (if output-port (associate-ports! input-port output-port)) - input-port))))))) + (or (subprocess-%i/o-port process) + (let ((port + (let ((input-channel (subprocess-input-channel process)) + (output-channel (subprocess-output-channel process))) + (if input-channel + (if output-channel + (make-generic-i/o-port input-channel output-channel + 512 512) + (make-generic-input-port input-channel 512)) + (if output-channel + (make-generic-output-port output-channel 512) + false))))) + (set-subprocess-%i/o-port! process port) + port))))) + +(define (subprocess-input-port process) + (let ((port (subprocess-i/o-port process))) + (and (input-port? port) + port))) (define (subprocess-output-port process) - (without-interrupts - (lambda () - (or (subprocess-%output-port process) - (let ((channel (subprocess-output-channel process))) - (and channel - (let ((output-port (make-generic-output-port channel 512)) - (input-port (subprocess-%input-port process))) - (set-subprocess-%output-port! process output-port) - (if input-port (associate-ports! input-port output-port)) - output-port))))))) - -(define (associate-ports! input-port output-port) - (set-input-port/associated-port! input-port output-port) - (set-output-port/associated-port! output-port input-port)) + (let ((port (subprocess-i/o-port process))) + (and (output-port? port) + port))) (define (make-subprocess filename arguments environment ctty stdin stdout stderr @@ -169,21 +168,17 @@ MIT in each case. |# ((ucode-primitive process-delete 1) (subprocess-index process)) (set! subprocesses (delq! process subprocesses)) (set-subprocess-index! process false) - (cond ((subprocess-input-port process) - => (lambda (input-port) - (set-subprocess-%input-port! process false) + (cond ((subprocess-%i/o-port process) + => (lambda (port) + (set-subprocess-%i/o-port! process false) (set-subprocess-input-channel! process false) - (close-input-port input-port))) - ((subprocess-input-channel process) + (set-subprocess-output-channel! process false) + (close-port port)))) + (cond ((subprocess-input-channel process) => (lambda (input-channel) (set-subprocess-input-channel! process false) (channel-close input-channel)))) - (cond ((subprocess-output-port process) - => (lambda (output-port) - (set-subprocess-%output-port! process false) - (set-subprocess-output-channel! process false) - (close-output-port output-port))) - ((subprocess-output-channel process) + (cond ((subprocess-output-channel process) => (lambda (output-channel) (set-subprocess-output-channel! process false) (channel-close output-channel)))) diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index e49f6ca87..c4be45774 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.10 1991/07/15 23:34:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.11 1991/11/15 05:15:12 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -59,13 +59,7 @@ MIT in each case. |# (define (make-record-type type-name field-names) (let ((record-type - (vector record-type-marker - type-name - (list-copy field-names) - (string-append "record of type " - (if (string? type-name) - type-name - (write-to-string type-name)))))) + (vector record-type-marker type-name (list-copy field-names)))) (unparser/set-tagged-vector-method! record-type (unparser/standard-method type-name)) (named-structure/set-tag-description! record-type @@ -87,7 +81,7 @@ MIT in each case. |# (define (record-type? object) (and (vector? object) - (= (vector-length object) 4) + (= (vector-length object) 3) (eq? (vector-ref object 0) record-type-marker))) (define (record-type-name record-type) @@ -112,8 +106,15 @@ MIT in each case. |# index (loop (cdr field-names) (+ index 1))))) -(define-integrable (record-type-error record record-type procedure) - (error:wrong-type-argument record (vector-ref record-type 3) procedure)) +(define (record-type-error record record-type procedure) + (error:wrong-type-argument + record + (string-append "record of type " + (let ((type-name (vector-ref record-type 1))) + (if (string? type-name) + type-name + (write-to-string type-name)))) + procedure)) (define (set-record-type-unparser-method! record-type method) (if (not (record-type? record-type)) @@ -150,7 +151,7 @@ MIT in each case. |# (define (record? object) (and (vector? object) - (positive? (vector-length object)) + (> (vector-length object) 0) (record-type? (vector-ref object 0)))) (define (record-type-descriptor record) @@ -158,6 +159,9 @@ MIT in each case. |# (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR)) (vector-ref record 0)) +(define (record-copy record) + (vector-copy record)) + (define (record-predicate record-type) (if (not (record-type? record-type)) (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 2ae709555..9ab27ea05 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.126 1991/11/05 20:37:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.127 1991/11/15 05:15:17 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -268,23 +268,18 @@ MIT in each case. |# ) (initialization (initialize-package!))) -(define-package (runtime console-input) - (files "ttyin") +(define-package (runtime console-i/o-port) + (files "ttyio") (parent ()) (export () - console-input-port) + console-i/o-port + console-input-port + console-output-port) (export (runtime emacs-interface) hook/read-finish hook/read-start) (initialization (initialize-package!))) -(define-package (runtime console-output) - (files "ttyout") - (parent ()) - (export () - console-output-port) - (initialization (initialize-package!))) - (define-package (runtime continuation) (files "contin") (parent ()) @@ -647,17 +642,12 @@ MIT in each case. |# hook/extended-scode-eval) (initialization (initialize-package!))) -(define-package (runtime file-input) - (files "filein") - (parent ()) - (export () - open-input-file) - (initialization (initialize-package!))) - -(define-package (runtime file-output) - (files "filout") +(define-package (runtime file-i/o-port) + (files "fileio") (parent ()) (export () + open-i/o-file + open-input-file open-output-file) (initialization (initialize-package!))) @@ -667,9 +657,7 @@ MIT in each case. |# (export () transcript-off transcript-on) - (export (runtime console-input) - transcript-port) - (export (runtime console-output) + (export (runtime console-i/o-port) transcript-port) (initialization (initialize-package!))) @@ -745,54 +733,44 @@ MIT in each case. |# hook/record-statistic!) (initialization (initialize-package!))) -(define-package (runtime generic-input) - (files "genin") +(define-package (runtime generic-i/o-port) + (files "genio") (parent ()) (export () + make-generic-i/o-port make-generic-input-port - set-input-port/associated-port!) - (export (runtime console-input) - operation/buffer-size - operation/buffered-chars - operation/channel + make-generic-output-port) + (export (runtime console-i/o-port) + operation/buffered-input-chars + operation/buffered-output-chars operation/char-ready? - operation/set-buffer-size) - (export (runtime file-input) - operation/buffer-size - operation/buffered-chars - operation/channel + operation/input-buffer-size + operation/input-channel + operation/output-buffer-size + operation/output-channel + operation/set-input-buffer-size + operation/set-output-buffer-size) + (export (runtime file-i/o-port) + operation/buffered-input-chars + operation/buffered-output-chars operation/char-ready? operation/chars-remaining operation/close operation/discard-char operation/discard-chars operation/eof? + operation/flush-output + operation/input-buffer-size + operation/input-channel + operation/output-buffer-size + operation/output-channel operation/peek-char operation/read-char operation/read-chars operation/read-string operation/read-substring - operation/set-buffer-size) - (initialization (initialize-package!))) - -(define-package (runtime generic-output) - (files "genout") - (parent ()) - (export () - make-generic-output-port - set-output-port/associated-port!) - (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/set-input-buffer-size + operation/set-output-buffer-size operation/write-char operation/write-string operation/write-substring) @@ -882,22 +860,17 @@ MIT in each case. |# history-untransform) (initialization (initialize-package!))) -(define-package (runtime input-port) - (files "input") +(define-package (runtime port) + (files "port") (parent ()) (export () - call-with-input-file - char-ready? close-input-port - current-input-port - eof-object? - guarantee-input-port + close-output-port + close-port + i/o-port? input-port/channel - input-port/char-ready? input-port/copy input-port/custom-operation - input-port/discard-char - input-port/discard-chars input-port/operation input-port/operation-names input-port/operation/char-ready? @@ -906,25 +879,86 @@ MIT in each case. |# input-port/operation/peek-char input-port/operation/read-char input-port/operation/read-string + input-port/state + input-port? + make-i/o-port + make-input-port + make-output-port + output-port/channel + output-port/copy + output-port/custom-operation + output-port/operation + output-port/operation-names + output-port/operation/flush-output + output-port/operation/write-char + output-port/operation/write-string + output-port/operation/write-substring + output-port/state + output-port? + port/copy + port/input-channel + port/output-channel + port/operation + port/operation-names + port/state + port? + set-input-port/state! + set-output-port/state! + set-port/state!)) + +(define-package (runtime input-port) + (files "input") + (parent ()) + (export () + call-with-input-file + char-ready? + current-input-port + eof-object? + guarantee-input-port + input-port/char-ready? + input-port/discard-char + input-port/discard-chars input-port/peek-char input-port/read-char input-port/read-string - input-port/state - input-port? make-eof-object - make-input-port peek-char read read-char read-char-no-hang read-string set-current-input-port! - set-input-port/state! with-input-from-file with-input-from-port) (export (runtime primitive-io) - eof-object) - (initialization (initialize-package!))) + eof-object)) + +(define-package (runtime output-port) + (files "output") + (parent ()) + (export () + beep + call-with-output-file + clear + current-output-port + display + fresh-line + guarantee-output-port + newline + output-port/flush-output + output-port/write-char + output-port/write-object + output-port/write-string + output-port/write-substring + output-port/x-size + output-port/y-size + set-current-output-port! + with-output-to-file + with-output-to-port + write + write-char + write-line + write-string)) (define-package (runtime interrupt-handler) (files "intrpt") @@ -1289,43 +1323,6 @@ MIT in each case. |# (export () load-option)) -(define-package (runtime output-port) - (files "output") - (parent ()) - (export () - beep - call-with-output-file - clear - close-output-port - current-output-port - display - fresh-line - guarantee-output-port - make-output-port - newline - output-port/channel - output-port/copy - output-port/custom-operation - output-port/flush-output - output-port/operation - output-port/operation-names - output-port/state - output-port/write-char - output-port/write-object - output-port/write-string - output-port/write-substring - output-port/x-size - output-port? - set-current-output-port! - set-output-port/state! - with-output-to-file - with-output-to-port - write - write-char - write-line - write-string) - (initialization (initialize-package!))) - (define-package (runtime parser) (files "parse") (parent ()) @@ -1530,7 +1527,7 @@ MIT in each case. |# make-channel) (export (runtime subprocess) channel-descriptor) - (export (runtime generic-input) + (export (runtime generic-i/o-port) input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1546,8 +1543,6 @@ MIT in each case. |# input-buffer/set-size input-buffer/size make-input-buffer - set-channel-port!) - (export (runtime generic-output) make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1559,15 +1554,13 @@ MIT in each case. |# output-buffer/write-string-block output-buffer/write-substring-block set-channel-port!) - (export (runtime file-input) + (export (runtime file-i/o-port) input-buffer/chars-remaining input-buffer/read-substring make-input-buffer - set-channel-port!) - (export (runtime file-output) make-output-buffer set-channel-port!) - (export (runtime console-input) + (export (runtime console-i/o-port) input-buffer/buffer-contents input-buffer/buffered-chars input-buffer/channel @@ -1579,8 +1572,6 @@ MIT in each case. |# input-buffer/set-size input-buffer/size make-input-buffer - set-channel-port!) - (export (runtime console-output) make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1616,6 +1607,7 @@ MIT in each case. |# make-record-type record-accessor record-constructor + record-copy record-predicate record-type-descriptor record-type-field-names @@ -1966,6 +1958,7 @@ MIT in each case. |# subprocess-get subprocess-global-status-tick subprocess-hangup + subprocess-i/o-port subprocess-id subprocess-input-channel subprocess-input-port diff --git a/v7/src/runtime/socket.scm b/v7/src/runtime/socket.scm index 60e12d9c8..1efa02b0f 100644 --- a/v7/src/runtime/socket.scm +++ b/v7/src/runtime/socket.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/socket.scm,v 1.2 1990/11/09 20:59:30 arthur Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/socket.scm,v 1.3 1991/11/15 05:15:24 cph Exp $ Copyright (c) 1990 Massachusetts Institute of Technology @@ -53,11 +53,8 @@ MIT in each case. |# (make-channel ((ucode-primitive open-unix-stream-socket 1) filename)))))) (define (socket-ports channel) - (let ((input-port (make-generic-input-port channel 64)) - (output-port (make-generic-output-port channel 64))) - (set-input-port/associated-port! input-port output-port) - (set-output-port/associated-port! output-port input-port) - (values input-port output-port))) + (let ((port (make-generic-i/o-port channel channel 64 64))) + (values port port))) (define (open-tcp-server-socket service) (without-interrupts @@ -86,9 +83,6 @@ MIT in each case. |# (and descriptor (make-channel descriptor))))))))) (if channel - (let ((input-port (make-generic-input-port channel 64)) - (output-port (make-generic-output-port channel 64))) - (set-input-port/associated-port! input-port output-port) - (set-output-port/associated-port! output-port input-port) - (values input-port output-port peer-address)) + (let ((port (make-generic-i/o-port channel channel 64 64))) + (values port port peer-address)) (values false false false))))) \ No newline at end of file diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 00c6df034..6103ab752 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.30 1991/11/04 20:29:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.31 1991/11/15 05:14:57 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -246,7 +246,10 @@ MIT in each case. |# ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("boot" . ()) ("queue" . ()) - ("gc" . (RUNTIME GARBAGE-COLLECTOR))))) + ("gc" . (RUNTIME GARBAGE-COLLECTOR)) + ("equals" . ()) + ("list" . (RUNTIME LIST)) + ("record" . (RUNTIME RECORD))))) (if (not (null? files)) (begin (eval (fasload (map-filename (car (car files))) #t) @@ -265,6 +268,8 @@ MIT in each case. |# (lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR)) 'CONSTANT-SPACE/BASE constant-space/base) +(package-initialize '(RUNTIME LIST) 'INITIALIZE-PACKAGE!) +(package-initialize '(RUNTIME RECORD) 'INITIALIZE-PACKAGE!) ;; Load everything else. ((eval (fasload "runtim.bldr" #f) system-global-environment) @@ -277,7 +282,10 @@ MIT in each case. |# (string=? filename "gdatab") (string=? filename "boot") (string=? filename "queue") - (string=? filename "gc"))) + (string=? filename "gc") + (string=? filename "equals") + (string=? filename "list") + (string=? filename "record"))) (eval (fasload (map-filename filename) #t) environment)) unspecific) `((SORT-TYPE . MERGE-SORT) @@ -297,7 +305,6 @@ MIT in each case. |# (RUNTIME SYSTEM-CLOCK) ;; Basic data structures (RUNTIME NUMBER) - (RUNTIME LIST) (RUNTIME CHARACTER) (RUNTIME CHARACTER-SET) (RUNTIME GENSYM) @@ -305,7 +312,6 @@ MIT in each case. |# (RUNTIME 2D-PROPERTY) (RUNTIME HASH) (RUNTIME RANDOM-NUMBER) - (RUNTIME RECORD) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME LAMBDA-ABSTRACTION) @@ -318,18 +324,13 @@ MIT in each case. |# (RUNTIME ERROR-HANDLER) (RUNTIME MICROCODE-ERRORS) ;; I/O - (RUNTIME CONSOLE-INPUT) - (RUNTIME CONSOLE-OUTPUT) + (RUNTIME GENERIC-I/O-PORT) + (RUNTIME FILE-I/O-PORT) + (RUNTIME CONSOLE-I/O-PORT) (RUNTIME TRANSCRIPT) - (RUNTIME GENERIC-INPUT) - (RUNTIME GENERIC-OUTPUT) - (RUNTIME FILE-INPUT) - (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) (RUNTIME STRING-OUTPUT) (RUNTIME TRUNCATED-STRING-OUTPUT) - (RUNTIME INPUT-PORT) - (RUNTIME OUTPUT-PORT) (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME LOAD) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index ea6f72078..088339a9f 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.126 1991/11/05 20:37:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.127 1991/11/15 05:15:17 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -268,23 +268,18 @@ MIT in each case. |# ) (initialization (initialize-package!))) -(define-package (runtime console-input) - (files "ttyin") +(define-package (runtime console-i/o-port) + (files "ttyio") (parent ()) (export () - console-input-port) + console-i/o-port + console-input-port + console-output-port) (export (runtime emacs-interface) hook/read-finish hook/read-start) (initialization (initialize-package!))) -(define-package (runtime console-output) - (files "ttyout") - (parent ()) - (export () - console-output-port) - (initialization (initialize-package!))) - (define-package (runtime continuation) (files "contin") (parent ()) @@ -647,17 +642,12 @@ MIT in each case. |# hook/extended-scode-eval) (initialization (initialize-package!))) -(define-package (runtime file-input) - (files "filein") - (parent ()) - (export () - open-input-file) - (initialization (initialize-package!))) - -(define-package (runtime file-output) - (files "filout") +(define-package (runtime file-i/o-port) + (files "fileio") (parent ()) (export () + open-i/o-file + open-input-file open-output-file) (initialization (initialize-package!))) @@ -667,9 +657,7 @@ MIT in each case. |# (export () transcript-off transcript-on) - (export (runtime console-input) - transcript-port) - (export (runtime console-output) + (export (runtime console-i/o-port) transcript-port) (initialization (initialize-package!))) @@ -745,54 +733,44 @@ MIT in each case. |# hook/record-statistic!) (initialization (initialize-package!))) -(define-package (runtime generic-input) - (files "genin") +(define-package (runtime generic-i/o-port) + (files "genio") (parent ()) (export () + make-generic-i/o-port make-generic-input-port - set-input-port/associated-port!) - (export (runtime console-input) - operation/buffer-size - operation/buffered-chars - operation/channel + make-generic-output-port) + (export (runtime console-i/o-port) + operation/buffered-input-chars + operation/buffered-output-chars operation/char-ready? - operation/set-buffer-size) - (export (runtime file-input) - operation/buffer-size - operation/buffered-chars - operation/channel + operation/input-buffer-size + operation/input-channel + operation/output-buffer-size + operation/output-channel + operation/set-input-buffer-size + operation/set-output-buffer-size) + (export (runtime file-i/o-port) + operation/buffered-input-chars + operation/buffered-output-chars operation/char-ready? operation/chars-remaining operation/close operation/discard-char operation/discard-chars operation/eof? + operation/flush-output + operation/input-buffer-size + operation/input-channel + operation/output-buffer-size + operation/output-channel operation/peek-char operation/read-char operation/read-chars operation/read-string operation/read-substring - operation/set-buffer-size) - (initialization (initialize-package!))) - -(define-package (runtime generic-output) - (files "genout") - (parent ()) - (export () - make-generic-output-port - set-output-port/associated-port!) - (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/set-input-buffer-size + operation/set-output-buffer-size operation/write-char operation/write-string operation/write-substring) @@ -882,22 +860,17 @@ MIT in each case. |# history-untransform) (initialization (initialize-package!))) -(define-package (runtime input-port) - (files "input") +(define-package (runtime port) + (files "port") (parent ()) (export () - call-with-input-file - char-ready? close-input-port - current-input-port - eof-object? - guarantee-input-port + close-output-port + close-port + i/o-port? input-port/channel - input-port/char-ready? input-port/copy input-port/custom-operation - input-port/discard-char - input-port/discard-chars input-port/operation input-port/operation-names input-port/operation/char-ready? @@ -906,25 +879,86 @@ MIT in each case. |# input-port/operation/peek-char input-port/operation/read-char input-port/operation/read-string + input-port/state + input-port? + make-i/o-port + make-input-port + make-output-port + output-port/channel + output-port/copy + output-port/custom-operation + output-port/operation + output-port/operation-names + output-port/operation/flush-output + output-port/operation/write-char + output-port/operation/write-string + output-port/operation/write-substring + output-port/state + output-port? + port/copy + port/input-channel + port/output-channel + port/operation + port/operation-names + port/state + port? + set-input-port/state! + set-output-port/state! + set-port/state!)) + +(define-package (runtime input-port) + (files "input") + (parent ()) + (export () + call-with-input-file + char-ready? + current-input-port + eof-object? + guarantee-input-port + input-port/char-ready? + input-port/discard-char + input-port/discard-chars input-port/peek-char input-port/read-char input-port/read-string - input-port/state - input-port? make-eof-object - make-input-port peek-char read read-char read-char-no-hang read-string set-current-input-port! - set-input-port/state! with-input-from-file with-input-from-port) (export (runtime primitive-io) - eof-object) - (initialization (initialize-package!))) + eof-object)) + +(define-package (runtime output-port) + (files "output") + (parent ()) + (export () + beep + call-with-output-file + clear + current-output-port + display + fresh-line + guarantee-output-port + newline + output-port/flush-output + output-port/write-char + output-port/write-object + output-port/write-string + output-port/write-substring + output-port/x-size + output-port/y-size + set-current-output-port! + with-output-to-file + with-output-to-port + write + write-char + write-line + write-string)) (define-package (runtime interrupt-handler) (files "intrpt") @@ -1289,43 +1323,6 @@ MIT in each case. |# (export () load-option)) -(define-package (runtime output-port) - (files "output") - (parent ()) - (export () - beep - call-with-output-file - clear - close-output-port - current-output-port - display - fresh-line - guarantee-output-port - make-output-port - newline - output-port/channel - output-port/copy - output-port/custom-operation - output-port/flush-output - output-port/operation - output-port/operation-names - output-port/state - output-port/write-char - output-port/write-object - output-port/write-string - output-port/write-substring - output-port/x-size - output-port? - set-current-output-port! - set-output-port/state! - with-output-to-file - with-output-to-port - write - write-char - write-line - write-string) - (initialization (initialize-package!))) - (define-package (runtime parser) (files "parse") (parent ()) @@ -1530,7 +1527,7 @@ MIT in each case. |# make-channel) (export (runtime subprocess) channel-descriptor) - (export (runtime generic-input) + (export (runtime generic-i/o-port) input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1546,8 +1543,6 @@ MIT in each case. |# input-buffer/set-size input-buffer/size make-input-buffer - set-channel-port!) - (export (runtime generic-output) make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1559,15 +1554,13 @@ MIT in each case. |# output-buffer/write-string-block output-buffer/write-substring-block set-channel-port!) - (export (runtime file-input) + (export (runtime file-i/o-port) input-buffer/chars-remaining input-buffer/read-substring make-input-buffer - set-channel-port!) - (export (runtime file-output) make-output-buffer set-channel-port!) - (export (runtime console-input) + (export (runtime console-i/o-port) input-buffer/buffer-contents input-buffer/buffered-chars input-buffer/channel @@ -1579,8 +1572,6 @@ MIT in each case. |# input-buffer/set-size input-buffer/size make-input-buffer - set-channel-port!) - (export (runtime console-output) make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1616,6 +1607,7 @@ MIT in each case. |# make-record-type record-accessor record-constructor + record-copy record-predicate record-type-descriptor record-type-field-names @@ -1966,6 +1958,7 @@ MIT in each case. |# subprocess-get subprocess-global-status-tick subprocess-hangup + subprocess-i/o-port subprocess-id subprocess-input-channel subprocess-input-port -- 2.25.1