From 63b7f3c67ebd26af83de06f1bf18c56e48bd1791 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 Feb 1999 20:12:28 +0000 Subject: [PATCH] Use new port types mechanism. --- v7/src/edwin/artdebug.scm | 66 +++++++++++++-------------- v7/src/edwin/bufinp.scm | 34 +++++++------- v7/src/edwin/bufout.scm | 34 +++++++------- v7/src/edwin/debug.scm | 78 ++++++++++++++++---------------- v7/src/edwin/intmod.scm | 8 ++-- v7/src/edwin/winout.scm | 26 +++++------ v7/src/runtime/emacs.scm | 40 +++++++--------- v7/src/runtime/fileio.scm | 93 ++++++++++++-------------------------- v7/src/runtime/genio.scm | 44 +++++++++--------- v7/src/runtime/runtime.pkg | 62 +++---------------------- v7/src/runtime/strnin.scm | 31 +++++++------ v7/src/runtime/strott.scm | 16 +++---- v7/src/runtime/strout.scm | 16 +++---- v7/src/runtime/ttyio.scm | 43 ++++++------------ v8/src/runtime/runtime.pkg | 62 +++---------------------- 15 files changed, 250 insertions(+), 403 deletions(-) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 80d488d42..055cf4a55 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: artdebug.scm,v 1.26 1999/01/02 06:11:34 cph Exp $ +;;; $Id: artdebug.scm,v 1.27 1999/02/16 20:12:15 cph Exp $ ;;; ;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology ;;; @@ -87,13 +87,13 @@ and contract subproblems and reductions. (define-variable debugger-confirm-return? "True means to prompt for confirmation in RETURN-FROM and RETURN-TO commands before returning the value." - true + #t boolean?) (define-variable debugger-split-window? "True means use another window for the debugger buffer; false means use the current window." - true + #t boolean?) (define-variable debugger-one-at-a-time? @@ -114,28 +114,28 @@ each time." (define-variable debugger-quit-on-return? "True means quit debugger when executing a \"return\" command." - true + #t boolean?) (define-variable debugger-quit-on-restart? "True means quit debugger when executing a \"restart\" command." - true + #t boolean?) (define-variable debugger-open-markers? "True means newlines are inserted between marker lines." - true + #t boolean?) (define-variable debugger-verbose-mode? "True means display extra information without the user requesting it." - false + #f boolean?) (define-variable debugger-expand-reductions? "True says to insert reductions when reduction motion commands are used in a subproblem whose reductions aren't already inserted." - true + #t boolean?) (define-variable debugger-max-subproblems @@ -149,21 +149,21 @@ or #F meaning no limit." (define-variable debugger-hide-system-code? "True means don't show subproblems created by the runtime system." - true + #t boolean?) (define-variable debugger-show-help-message? "True means show a help message in the debugger buffer." - true + #t boolean?) (define-variable debugger-debug-evaluations? "True means evaluation errors in a debugger buffer start new debuggers." - false + #f boolean?) -(define in-debugger? false) -(define in-debugger-evaluation? false) +(define in-debugger? #f) +(define in-debugger-evaluation? #f) (define (maybe-debug-scheme-error switch-variable condition error-type-name) (if (variable-value switch-variable) @@ -177,7 +177,7 @@ or #F meaning no limit." (ref-variable debugger-start-on-error?)) (or (not (eq? (ref-variable debugger-start-on-error?) 'ASK)) (debug-scheme-error? condition error-type-name))) - (fluid-let ((in-debugger? true)) + (fluid-let ((in-debugger? #t)) ((if (ref-variable debugger-split-window?) select-buffer-other-window select-buffer) @@ -213,7 +213,7 @@ or #F meaning no limit." (if (and (not (null? buffers)) (null? (cdr buffers)) (ref-variable debugger-one-at-a-time?) - (or (eq? true (ref-variable debugger-one-at-a-time?)) + (or (eq? #t (ref-variable debugger-one-at-a-time?)) (prompt-for-confirmation? "Another debugger buffer exists. Delete it"))) (kill-buffer (car buffers)))) @@ -391,7 +391,7 @@ Use \\[kill-buffer] to quit the debugger." (let ((point (mark-left-inserting-copy (current-point)))) (insert-string output point) (guarantee-newlines 1 point) - (insert-string (transcript-value-prefix-string value true) point) + (insert-string (transcript-value-prefix-string value #t) point) (insert-string (transcript-value-string value) point) (insert-newlines 2 point) (mark-temporary! point))) @@ -482,7 +482,7 @@ Use \\[kill-buffer] to quit the debugger." (lambda (region) (let ((environment (dstate-evaluation-environment (start-evaluation region)))) - (fluid-let ((in-debugger-evaluation? true)) + (fluid-let ((in-debugger-evaluation? #t)) (evaluate-region region environment))))) (define (start-evaluation region) @@ -518,7 +518,7 @@ The evaluation occurs in the dynamic state of the current frame." (stack-frame->continuation (dstate/subproblem dstate))) (repl-eval hook/repl-eval)) (fluid-let - ((in-debugger-evaluation? true) + ((in-debugger-evaluation? #t) (hook/repl-eval (lambda (expression environment syntax-table) (let ((unique (cons 'unique 'id))) @@ -662,7 +662,7 @@ Move to the last subproblem if the subproblem number is too high." (write-string string port))) (pp (lambda (obj) (fresh-line port) - (pretty-print obj port true) + (pretty-print obj port #t) (newline port)))) (if (dstate/reduction-number dstate) @@ -683,10 +683,10 @@ Move to the last subproblem if the subproblem number is too high." (if (or argument (invalid-subexpression? sub)) (pp exp) - (fluid-let ((*pp-no-highlights?* false)) + (fluid-let ((*pp-no-highlights?* #f)) (do-hairy)))) ((debugging-info/noise? exp) - (message ((debugging-info/noise exp) true))) + (message ((debugging-info/noise exp) #t))) (else (message "Unknown expression"))))))))))) @@ -899,7 +899,7 @@ Prefix argument means do not kill the debugger buffer." (lambda (continuation arguments) (invoke-continuation continuation arguments - false)))) + #f)))) (invoke-restart restart))))) ;;;; Marker Generation @@ -1009,14 +1009,14 @@ Prefix argument means do not kill the debugger buffer." ((not (debugging-info/undefined-expression? expression)) (print-with-subexpression expression subexpression)) ((debugging-info/noise? expression) - (write-string ((debugging-info/noise expression) false))) + (write-string ((debugging-info/noise expression) #f))) (else (write-string ";undefined expression")))) environment port)))) (define (print-with-subexpression expression subexpression) - (fluid-let ((*unparse-primitives-by-name?* true)) + (fluid-let ((*unparse-primitives-by-name?* #t)) (if (invalid-subexpression? subexpression) (write (unsyntax expression)) (let ((sub (write-to-string (unsyntax subexpression)))) @@ -1036,7 +1036,7 @@ Prefix argument means do not kill the debugger buffer." (define (print-reduction subproblem-number reduction-number reduction port) (print-history-level - false + #f subproblem-number (string-append ", R=" (number->string reduction-number) " --- ") (lambda () @@ -1045,7 +1045,7 @@ Prefix argument means do not kill the debugger buffer." port)) (define (print-reduction-as-subexpression expression) - (fluid-let ((*unparse-primitives-by-name?* true)) + (fluid-let ((*unparse-primitives-by-name?* #t)) (write-string (ref-variable subexpression-start-marker)) (write (unsyntax expression)) (write-string (ref-variable subexpression-end-marker)))) @@ -1226,7 +1226,7 @@ Prefix argument means do not kill the debugger buffer." (if (and reduction-number (positive? (dstate/number-of-reductions dstate))) (change-reduction! dstate reduction-number) - (set-dstate/reduction-number! dstate false)) + (set-dstate/reduction-number! dstate #f)) dstate) (editor-error "Cannot find environment for evaluation."))))) @@ -1236,7 +1236,7 @@ Prefix argument means do not kill the debugger buffer." (if (and (dstate/using-history? dstate) (positive? (dstate/number-of-reductions dstate))) (change-reduction! dstate 0) - (set-dstate/reduction-number! dstate false)))) + (set-dstate/reduction-number! dstate #f)))) (delta (- subproblem-number (dstate/subproblem-number dstate)))) (if (negative? delta) (let ((subproblems @@ -1299,7 +1299,7 @@ Prefix argument means do not kill the debugger buffer." (define (call-with-interface-port mark receiver) (let ((mark (mark-left-inserting-copy mark))) - (let ((value (receiver (port/copy interface-port-template mark)))) + (let ((value (receiver (make-port interface-port-type mark)))) (mark-temporary! mark) value))) @@ -1332,7 +1332,7 @@ Prefix argument means do not kill the debugger buffer." (fresh-line port) (fluid-let ((debugger-pp (lambda (expression indentation port) - (pretty-print expression port true indentation)))) + (pretty-print expression port #t indentation)))) (thunk)) (newline port) (newline port)) @@ -1345,8 +1345,8 @@ Prefix argument means do not kill the debugger buffer." port (prompt-for-confirmation? prompt)) -(define interface-port-template - (make-output-port +(define interface-port-type + (make-output-port-type `((WRITE-CHAR ,operation/write-char) (WRITE-SUBSTRING ,operation/write-substring) (FRESH-LINE ,operation/fresh-line) @@ -1356,4 +1356,4 @@ Prefix argument means do not kill the debugger buffer." (DEBUGGER-PRESENTATION ,debugger-presentation) (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression) (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)) - false)) \ No newline at end of file + #f)) \ No newline at end of file diff --git a/v7/src/edwin/bufinp.scm b/v7/src/edwin/bufinp.scm index ee0f6d047..0772879b5 100644 --- a/v7/src/edwin/bufinp.scm +++ b/v7/src/edwin/bufinp.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: bufinp.scm,v 1.5 1999/01/02 06:11:34 cph Exp $ +;;;$Id: bufinp.scm,v 1.6 1999/02/16 20:12:24 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -40,17 +40,17 @@ (define-structure (buffer-input-port-state (conc-name buffer-input-port-state/)) - (group false read-only true) - (end-index false read-only true) - (current-index false)) + (group #f read-only #t) + (end-index #f read-only #t) + (current-index #f)) (define (make-buffer-input-port mark end) ;; This uses indices, so it can only be used locally ;; where there is no buffer-modification happening. - (input-port/copy buffer-input-port-template - (make-buffer-input-port-state (mark-group mark) - (mark-index end) - (mark-index mark)))) + (make-port buffer-input-port-type + (make-buffer-input-port-state (mark-group mark) + (mark-index end) + (mark-index mark)))) (define (operation/char-ready? port interval) interval ;ignore @@ -122,12 +122,12 @@ (make-mark (buffer-input-port-state/group state) (buffer-input-port-state/current-index state))))) -(define buffer-input-port-template - (make-input-port `((CHAR-READY? ,operation/char-ready?) - (DISCARD-CHAR ,operation/discard-char) - (DISCARD-CHARS ,operation/discard-chars) - (PEEK-CHAR ,operation/peek-char) - (PRINT-SELF ,operation/print-self) - (READ-CHAR ,operation/read-char) - (READ-STRING ,operation/read-string)) - false)) \ No newline at end of file +(define buffer-input-port-type + (make-input-port-type `((CHAR-READY? ,operation/char-ready?) + (DISCARD-CHAR ,operation/discard-char) + (DISCARD-CHARS ,operation/discard-chars) + (PEEK-CHAR ,operation/peek-char) + (PRINT-SELF ,operation/print-self) + (READ-CHAR ,operation/read-char) + (READ-STRING ,operation/read-string)) + #f)) \ No newline at end of file diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm index d2be70c2c..f4736e14f 100644 --- a/v7/src/edwin/bufout.scm +++ b/v7/src/edwin/bufout.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: bufout.scm,v 1.11 1999/01/02 06:11:34 cph Exp $ +;;; $Id: bufout.scm,v 1.12 1999/02/16 20:12:28 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -35,11 +35,11 @@ value))) (define (mark->output-port mark #!optional buffer) - (output-port/copy mark-output-port-template - (cons (mark-left-inserting-copy mark) - (if (default-object? buffer) - false - buffer)))) + (make-port mark-output-port-type + (cons (mark-left-inserting-copy mark) + (if (default-object? buffer) + #f + buffer)))) (define (output-port->mark port) (mark-temporary-copy (port/mark port))) @@ -57,9 +57,9 @@ (for-each (if (mark= mark (buffer-point buffer)) (lambda (window) (set-window-point! window mark) - (window-direct-update! window false)) + (window-direct-update! window #f)) (lambda (window) - (window-direct-update! window false))) + (window-direct-update! window #f))) (buffer-windows buffer))))) (define (operation/fresh-line port) @@ -81,12 +81,12 @@ (define (operation/x-size port) (mark-x-size (port/mark port))) -(define mark-output-port-template - (make-output-port `((CLOSE ,operation/close) - (FLUSH-OUTPUT ,operation/flush-output) - (FRESH-LINE ,operation/fresh-line) - (PRINT-SELF ,operation/print-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring) - (X-SIZE ,operation/x-size)) - false)) \ No newline at end of file +(define mark-output-port-type + (make-output-port-type `((CLOSE ,operation/close) + (FLUSH-OUTPUT ,operation/flush-output) + (FRESH-LINE ,operation/fresh-line) + (PRINT-SELF ,operation/print-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring) + (X-SIZE ,operation/x-size)) + #f)) \ No newline at end of file diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 21f13adb5..0e6511e4c 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.46 1999/02/03 06:12:57 cph Exp $ +;;; $Id: debug.scm,v 1.47 1999/02/16 20:12:04 cph Exp $ ;;; ;;; Copyright (c) 1992-1999 Massachusetts Institute of Technology ;;; @@ -121,7 +121,7 @@ object name (vector) - false + #f '() (make-1d-table)))) (buffer-put! buffer 'BROWSER browser) @@ -147,7 +147,7 @@ (string-append (if (1d-table/get (browser/properties browser) 'VISIBLE-SUB-BUFFERS? - false) + #f) "" " ") prefix @@ -232,24 +232,24 @@ (loop index (- argument 1)) (begin (select-bline bline) - false)))) + #f)))) (else (let ((index (- index 1))) (if (<= 0 index) (loop index (+ argument 1)) (begin (select-bline bline) - false))))))))) + #f))))))))) (let ((point (current-point))) (let ((index (mark->bline-index point))) (cond (index (loop index argument)) ((= argument 0) - false) + #f) (else (let ((n (if (< argument 0) -1 1))) (let find-next ((mark point)) - (let ((mark (line-start mark n false))) + (let ((mark (line-start mark n #f))) (and mark (let ((index (mark->bline-index mark))) (if index @@ -285,7 +285,7 @@ (set-buffer-point! (mark-buffer mark) mark))) (let ((buffer (bline/description-buffer bline))) (if buffer - (pop-up-buffer buffer false))))) + (pop-up-buffer buffer #f))))) (define (highlight-the-number mark) (let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0)))) @@ -313,11 +313,11 @@ (and (subproblem? (bline/object bline)) (system-frame? (subproblem/stack-frame (bline/object bline))))) (buffer - (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER false)) + (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f)) (get-environment (1d-table/get (bline-type/properties (bline/type bline)) 'GET-ENVIRONMENT - false)) + #f)) (env-exists? (if (and get-environment (not system?)) (let ((environment* (get-environment bline))) (environment? environment*)) @@ -329,7 +329,7 @@ (bline-type/write-description (bline/type bline)))) (temporary-message "Computing, please wait...") (and write-description - (let ((buffer (browser/new-buffer (bline/browser bline) false))) + (let ((buffer (browser/new-buffer (bline/browser bline) #f))) (call-with-output-mark (buffer-start buffer) (lambda (port) (write-description bline port) @@ -447,7 +447,7 @@ (bline (mark->bline mark)) (browser (bline/browser bline)) (buffer - (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER false)) + (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f)) (condition (browser/object browser))) (if (condition? condition) @@ -496,7 +496,7 @@ ;;;stuff gets called with uses the minibuffer for prompts (define (call-with-interface-port mark receiver) (let ((mark (mark-left-inserting-copy mark))) - (let ((value (receiver (port/copy interface-port-template mark)))) + (let ((value (receiver (make-port interface-port-type mark)))) (mark-temporary! mark) value))) @@ -530,7 +530,7 @@ (environment-browser-buffer environment)))))) (define (bline/attached-buffer bline type make-buffer) - (let ((buffer (1d-table/get (bline/properties bline) type false))) + (let ((buffer (1d-table/get (bline/properties bline) type #f))) (if (and buffer (buffer-alive? buffer)) buffer (let ((buffer (make-buffer))) @@ -548,7 +548,7 @@ (let ((get-environment (1d-table/get (bline-type/properties (bline/type bline)) 'GET-ENVIRONMENT - false)) + #f)) (lose (lambda () (editor-error "The selected line has no environment.")))) (if get-environment @@ -622,9 +622,9 @@ (set-bline/next! (record-modifier bline-rtd 'NEXT))) (lambda (object type parent prev) (let ((bline - (constructor false object type + (constructor #f object type parent (if parent (+ (bline/depth parent) 1) 0) - false prev (if prev (+ (bline/offset prev) 1) 0) + #f prev (if prev (+ (bline/offset prev) 1) 0) (make-1d-table)))) (if prev (set-bline/next! prev bline)) @@ -735,7 +735,7 @@ (insert-newline mark) (set-bline/start-mark! bline - (make-permanent-mark (mark-group mark) index true)))) + (make-permanent-mark (mark-group mark) index #t)))) blines) (mark-temporary! mark))))) (set-browser/lines! browser bv*)))))) @@ -804,7 +804,7 @@ (write-string "--more--" port)) (define bline-type:continuation-line - (make-bline-type continuation-line/write-summary false 0)) + (make-bline-type continuation-line/write-summary #f 0)) (define (bline/continuation? bline) (eq? (bline/type bline) bline-type:continuation-line)) @@ -850,19 +850,19 @@ Set this variable to #F to disable this limit." (define-variable debugger-confirm-return? "True means prompt for confirmation in \"return\" commands. The prompting occurs prior to returning the value." - true + #t boolean?) (define-variable debugger-quit-on-return? "True means quit debugger when executing a \"return\" command. Quitting the debugger kills the debugger buffer and any associated buffers." - true + #t boolean?) (define-variable debugger-quit-on-restart? "True means quit debugger when executing a \"restart\" command. Quitting the debugger kills the debugger buffer and any associated buffers." - true + #t boolean?) ;;;Limited this bc the bindings are now pretty-printed @@ -1260,7 +1260,7 @@ it has been renamed, it will not be deleted automatically.") (define (continuation->blines continuation limit) (let ((beyond-system-code #f)) (let loop ((frame (continuation/first-subproblem continuation)) - (prev false) + (prev #f) (n 0)) (if (not frame) '() @@ -1272,7 +1272,7 @@ it has been renamed, it will not be deleted automatically.") (walk-reductions (lambda (bline reductions) (cons bline - (let loop ((reductions reductions) (prev false)) + (let loop ((reductions reductions) (prev #f)) (if (null? reductions) (next-subproblem bline) (let ((bline @@ -1292,14 +1292,14 @@ it has been renamed, it will not be deleted automatically.") (let ((bline (make-bline subproblem bline-type:subproblem - false + #f prev))) (cons bline (next-subproblem bline))) (let ((bline (make-bline (car reductions) bline-type:reduction - false + #f prev))) (walk-reductions bline (if (> n 0) @@ -1308,7 +1308,7 @@ it has been renamed, it will not be deleted automatically.") (walk-reductions (make-bline subproblem bline-type:subproblem - false + #f prev) (subproblem/reductions subproblem))))))) (cond ((and (not (ref-variable debugger-hide-system-code?)) @@ -1321,7 +1321,7 @@ it has been renamed, it will not be deleted automatically.") (begin (set! beyond-system-code #t) #t) #f) beyond-system-code) - (list (make-continuation-bline continue false prev))) + (list (make-continuation-bline continue #f prev))) (else (continue)))))))) (define subproblem-rtd @@ -1387,14 +1387,14 @@ it has been renamed, it will not be deleted automatically.") (cond ((debugging-info/compiled-code? expression) (write-string ";unknown compiled code" port)) ((not (debugging-info/undefined-expression? expression)) - (fluid-let ((*unparse-primitives-by-name?* true)) + (fluid-let ((*unparse-primitives-by-name?* #t)) (write (unsyntax (if (invalid-subexpression? subexpression) expression subexpression))))) ((debugging-info/noise? expression) (write-string ";" port) - (write-string ((debugging-info/noise expression) false) + (write-string ((debugging-info/noise expression) #f) port)) (else (write-string ";undefined expression" port)))))))) @@ -1434,7 +1434,7 @@ it has been renamed, it will not be deleted automatically.") expression-indentation port)))) ((debugging-info/noise? expression) - (write-string ((debugging-info/noise expression) true) + (write-string ((debugging-info/noise expression) #t) port)) (else (write-string (if (stack-frame/compiled-code? frame) @@ -1477,7 +1477,7 @@ it has been renamed, it will not be deleted automatically.") (subproblem/number (reduction/subproblem reduction))) port))) (write-string " " port) - (fluid-let ((*unparse-primitives-by-name?* true)) + (fluid-let ((*unparse-primitives-by-name?* #t)) (write (unsyntax (reduction/expression reduction)) port)))) (define (reduction/write-description bline port) @@ -1541,10 +1541,10 @@ it has been renamed, it will not be deleted automatically.") buffer)))) (define (environment->blines environment) - (let loop ((environment environment) (prev false)) - (let ((bline (make-bline environment bline-type:environment false prev))) + (let loop ((environment environment) (prev #f)) + (let ((bline (make-bline environment bline-type:environment #f prev))) (cons bline - (if (eq? true (environment-has-parent? environment)) + (if (eq? #t (environment-has-parent? environment)) (loop (environment-parent environment) bline) '()))))) @@ -1653,7 +1653,7 @@ once it has been renamed, it will not be deleted automatically.") (write limit port) (write-string " shown):" port) (finish (list-head names limit)) - true))))))) + #t))))))) (else (write-string " BINDINGS:" port) (finish @@ -1894,9 +1894,9 @@ once it has been renamed, it will not be deleted automatically.") port (prompt-for-expression prompt)) -(define interface-port-template - (make-output-port +(define interface-port-type + (make-output-port-type `((WRITE-CHAR ,operation/write-char) (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation) (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)) - false)) \ No newline at end of file + #f)) \ No newline at end of file diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 8eb505320..b04c4b4ae 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: intmod.scm,v 1.95 1999/01/02 06:11:34 cph Exp $ +;;; $Id: intmod.scm,v 1.96 1999/02/16 20:12:20 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -708,7 +708,7 @@ If this is an error, the debugger examines the error condition." (define (make-interface-port buffer thread) (letrec ((port - (port/copy interface-port-template + (make-port interface-port-type (make-interface-port-state thread (mark-right-inserting-copy (buffer-end buffer)) @@ -1052,8 +1052,8 @@ If this is an error, the debugger examines the error condition." syntax-table)) #t))) -(define interface-port-template - (make-i/o-port +(define interface-port-type + (make-i/o-port-type `((WRITE-CHAR ,operation/write-char) (WRITE-SUBSTRING ,operation/write-substring) (FRESH-LINE ,operation/fresh-line) diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm index 8035df894..ae561be00 100644 --- a/v7/src/edwin/winout.scm +++ b/v7/src/edwin/winout.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;;$Id: winout.scm,v 1.11 1999/02/16 00:44:11 cph Exp $ +;;;$Id: winout.scm,v 1.12 1999/02/16 20:12:09 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology ;;; @@ -30,7 +30,7 @@ (with-output-to-port (window-output-port window) thunk)) (define (window-output-port window) - (output-port/copy window-output-port-template window)) + (make-port window-output-port-type window)) (define (operation/fresh-line port) (if (not (line-start? (window-point (port/state port)))) @@ -44,7 +44,7 @@ (line-end? point) (buffer-auto-save-modified? buffer) (or (not (window-needs-redisplay? window)) - (window-direct-update! window false))) + (window-direct-update! window #f))) (cond ((and (group-end? point) (char=? char #\newline) (< (1+ (window-point-y window)) (window-y-size window))) @@ -69,7 +69,7 @@ (line-end? point) (buffer-auto-save-modified? buffer) (or (not (window-needs-redisplay? window)) - (window-direct-update! window false)) + (window-direct-update! window #f)) (let loop ((i (- end 1))) (or (< i start) (let ((char (string-ref string i))) @@ -87,7 +87,7 @@ (define (operation/flush-output port) (let ((window (port/state port))) (if (window-needs-redisplay? window) - (window-direct-update! window false)))) + (window-direct-update! window #f)))) (define (operation/x-size port) (window-x-size (port/state port))) @@ -96,11 +96,11 @@ (unparse-string state "to window ") (unparse-object state (port/state port))) -(define window-output-port-template - (make-output-port `((FLUSH-OUTPUT ,operation/flush-output) - (FRESH-LINE ,operation/fresh-line) - (PRINT-SELF ,operation/print-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring) - (X-SIZE ,operation/x-size)) - false)) \ No newline at end of file +(define window-output-port-type + (make-output-port-type `((FLUSH-OUTPUT ,operation/flush-output) + (FRESH-LINE ,operation/fresh-line) + (PRINT-SELF ,operation/print-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring) + (X-SIZE ,operation/x-size)) + #f)) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 16f47c27c..a53293a25 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: emacs.scm,v 14.23 1999/01/02 06:11:34 cph Exp $ +$Id: emacs.scm,v 14.24 1999/02/16 20:11:25 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -210,28 +210,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (initialize-package!) (set! emacs-console-port (make-i/o-port - (let ((operations - `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression) - (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char) - (PROMPT-FOR-COMMAND-EXPRESSION - ,emacs/prompt-for-command-expression) - (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation) - (DEBUGGER-FAILURE ,emacs/debugger-failure) - (DEBUGGER-MESSAGE ,emacs/debugger-message) - (DEBUGGER-PRESENTATION ,emacs/debugger-presentation) - (WRITE-RESULT ,emacs/write-result) - (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory) - (READ-START ,emacs/read-start) - (READ-FINISH ,emacs/read-finish) - (GC-START ,emacs/gc-start) - (GC-FINISH ,emacs/gc-finish)))) - (append-map* operations - (lambda (name) - (if (assq name operations) - '() - `((,name - ,(port/operation the-console-port name))))) - (port/operation-names the-console-port))) + (make-i/o-port-type + `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression) + (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char) + (PROMPT-FOR-COMMAND-EXPRESSION + ,emacs/prompt-for-command-expression) + (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation) + (DEBUGGER-FAILURE ,emacs/debugger-failure) + (DEBUGGER-MESSAGE ,emacs/debugger-message) + (DEBUGGER-PRESENTATION ,emacs/debugger-presentation) + (WRITE-RESULT ,emacs/write-result) + (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory) + (READ-START ,emacs/read-start) + (READ-FINISH ,emacs/read-finish) + (GC-START ,emacs/gc-start) + (GC-FINISH ,emacs/gc-finish)) + the-console-port-type) (port/state the-console-port))) ;; YUCCH! Kludge to copy mutex of console port into emacs port. (set-port/thread-mutex! emacs-console-port diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm index c8080952b..61738febd 100644 --- a/v7/src/runtime/fileio.scm +++ b/v7/src/runtime/fileio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fileio.scm,v 1.15 1999/02/16 05:39:07 cph Exp $ +$Id: fileio.scm,v 1.16 1999/02/16 20:11:34 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -26,65 +26,28 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (initialize-package!) (let ((input-operations - `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars) - (CHAR-READY? ,operation/char-ready?) - (CHARS-REMAINING ,operation/chars-remaining) - (CLOSE-INPUT ,operation/close-input) - (DISCARD-CHAR ,operation/discard-char) - (DISCARD-CHARS ,operation/discard-chars) - (EOF? ,operation/eof?) - (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) - (INPUT-BUFFER-SIZE ,operation/input-buffer-size) - (INPUT-CHANNEL ,operation/input-channel) - (INPUT-OPEN? ,operation/input-open?) - (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) - (LENGTH ,operation/length) - (PEEK-CHAR ,operation/peek-char) - (READ-CHAR ,operation/read-char) - (READ-STRING ,operation/read-string) - (READ-SUBSTRING ,operation/read-substring) - (REST->STRING ,operation/rest->string) - (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) - (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode))) - (output-operations - `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) - (CLOSE-OUTPUT ,operation/close-output) - (FLUSH-OUTPUT ,operation/flush-output) - (FRESH-LINE ,operation/fresh-line) - (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) - (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) - (OUTPUT-CHANNEL ,operation/output-channel) - (OUTPUT-OPEN? ,operation/output-open?) - (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) - (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) - (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) - (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring))) + `((LENGTH ,operation/length) + (REST->STRING ,operation/rest->string))) (other-operations - `((CLOSE ,operation/close) + `((WRITE-SELF ,operation/write-self) (PATHNAME ,operation/pathname) - (WRITE-SELF ,operation/write-self) (TRUENAME ,operation/truename)))) - (set! input-file-template - (make-input-port (append input-operations - other-operations) - #f)) - (set! output-file-template - (make-output-port (append output-operations - other-operations) - #f)) - (set! i/o-file-template - (make-i/o-port (append input-operations - output-operations - other-operations) - #f))) + (set! input-file-type + (make-input-port-type (append input-operations + other-operations) + generic-input-type)) + (set! output-file-type + (make-output-port-type other-operations + generic-output-type)) + (set! i/o-file-type + (make-i/o-port-type (append input-operations + other-operations) + generic-i/o-type))) unspecific) -(define input-file-template) -(define output-file-template) -(define i/o-file-template) +(define input-file-type) +(define output-file-type) +(define i/o-file-type) (define input-buffer-size 512) (define output-buffer-size 512) @@ -93,8 +56,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) (port - (port/copy - input-file-template + (make-port + input-file-type (make-file-state (make-input-buffer channel input-buffer-size @@ -112,8 +75,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (file-open-append-channel filename) (file-open-output-channel filename)))) (port - (port/copy - output-file-template + (make-port + output-file-type (make-file-state #f (make-output-buffer channel @@ -128,8 +91,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (channel (file-open-io-channel (->namestring pathname))) (translation (pathname-newline-translation pathname)) (port - (port/copy - i/o-file-template + (make-port + i/o-file-type (make-file-state (make-input-buffer channel input-buffer-size translation) (make-output-buffer channel output-buffer-size translation) @@ -146,7 +109,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) (port - (port/copy input-file-template + (make-port input-file-type (make-file-state (make-input-buffer channel input-buffer-size #f) @@ -163,7 +126,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (file-open-append-channel filename) (file-open-output-channel filename)))) (port - (port/copy output-file-template + (make-port output-file-type (make-file-state #f (make-output-buffer channel output-buffer-size @@ -176,7 +139,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let* ((pathname (merge-pathnames filename)) (channel (file-open-io-channel (->namestring pathname))) (port - (port/copy i/o-file-template + (make-port i/o-file-type (make-file-state (make-input-buffer channel input-buffer-size #f) @@ -236,7 +199,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (pathname #f read-only #t)) (define (operation/length port) - (channel-file-length (operation/input-channel port))) + (channel-file-length (port/input-channel port))) (define (operation/pathname port) (file-state/pathname (port/state port))) diff --git a/v7/src/runtime/genio.scm b/v7/src/runtime/genio.scm index 4ab4b0818..276d12c30 100644 --- a/v7/src/runtime/genio.scm +++ b/v7/src/runtime/genio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: genio.scm,v 1.13 1999/02/16 05:38:34 cph Exp $ +$Id: genio.scm,v 1.14 1999/02/16 20:11:38 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -63,24 +63,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (other-operations `((CLOSE ,operation/close) (WRITE-SELF ,operation/write-self)))) - (set! generic-input-template - (make-input-port (append input-operations - other-operations) - #f)) - (set! generic-output-template - (make-output-port (append output-operations - other-operations) - #f)) - (set! generic-i/o-template - (make-i/o-port (append input-operations - output-operations - other-operations) - #f))) + (set! generic-input-type + (make-input-port-type (append input-operations + other-operations) + #f)) + (set! generic-output-type + (make-output-port-type (append output-operations + other-operations) + #f)) + (set! generic-i/o-type + (make-i/o-port-type (append input-operations + output-operations + other-operations) + #f))) unspecific) -(define generic-input-template) -(define generic-output-template) -(define generic-i/o-template) +(define generic-input-type) +(define generic-output-type) +(define generic-i/o-type) (define (make-generic-input-port input-channel input-buffer-size #!optional line-translation) @@ -88,7 +88,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (default-object? line-translation) 'DEFAULT line-translation))) - (make-generic-port generic-input-template + (make-generic-port generic-input-type (make-input-buffer input-channel input-buffer-size line-translation) @@ -100,7 +100,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (default-object? line-translation) 'DEFAULT line-translation))) - (make-generic-port generic-output-template + (make-generic-port generic-output-type #f (make-output-buffer output-channel output-buffer-size @@ -118,7 +118,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (default-object? output-line-translation) input-line-translation output-line-translation))) - (make-generic-port generic-i/o-template + (make-generic-port generic-i/o-type (make-input-buffer input-channel input-buffer-size input-line-translation) @@ -126,8 +126,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. output-buffer-size output-line-translation))))) -(define (make-generic-port template input-buffer output-buffer) - (let ((port (port/copy template (vector input-buffer output-buffer)))) +(define (make-generic-port type input-buffer output-buffer) + (let ((port (make-port type (vector input-buffer output-buffer)))) (if input-buffer (set-channel-port! (input-buffer/channel input-buffer) port)) (if output-buffer diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index ded79f0f5..af43cc64e 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.313 1999/02/16 19:49:07 cph Exp $ +$Id: runtime.pkg,v 14.314 1999/02/16 20:11:18 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -387,7 +387,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. console-output-port set-console-i/o-port!) (export (runtime emacs-interface) - the-console-port) + the-console-port + the-console-port-type) (initialization (initialize-package!))) (define-package (runtime continuation) @@ -909,60 +910,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. make-generic-input-port make-generic-output-port) (export (runtime console-i/o-port) - operation/buffered-input-chars - operation/buffered-output-chars - operation/char-ready? - operation/input-blocking-mode - operation/input-buffer-size - operation/input-channel - operation/input-open? - operation/input-terminal-mode - operation/output-blocking-mode - operation/output-buffer-size - operation/output-channel - operation/output-open? - operation/output-terminal-mode - operation/set-input-blocking-mode - operation/set-input-buffer-size - operation/set-input-terminal-mode - operation/set-output-blocking-mode - operation/set-output-buffer-size - operation/set-output-terminal-mode) + generic-i/o-type) (export (runtime file-i/o-port) - operation/buffered-input-chars - operation/buffered-output-chars - operation/char-ready? - operation/chars-remaining - operation/close - operation/close-input - operation/close-output - operation/discard-char - operation/discard-chars - operation/eof? - operation/flush-output - operation/fresh-line - operation/input-blocking-mode - operation/input-buffer-size - operation/input-channel - operation/input-open? - operation/input-terminal-mode - operation/output-blocking-mode - operation/output-buffer-size - operation/output-channel - operation/output-open? - operation/output-terminal-mode - operation/peek-char - operation/read-char - operation/read-string - operation/read-substring - operation/set-input-blocking-mode - operation/set-input-buffer-size - operation/set-input-terminal-mode - operation/set-output-blocking-mode - operation/set-output-buffer-size - operation/set-output-terminal-mode - operation/write-char - operation/write-substring) + generic-i/o-type + generic-input-type + generic-output-type) (initialization (initialize-package!))) (define-package (runtime gensym) diff --git a/v7/src/runtime/strnin.scm b/v7/src/runtime/strnin.scm index ecd6d4816..acf10c638 100644 --- a/v7/src/runtime/strnin.scm +++ b/v7/src/runtime/strnin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strnin.scm,v 14.5 1999/01/02 06:19:10 cph Exp $ +$Id: strnin.scm,v 14.6 1999/02/16 20:11:55 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -25,15 +25,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) (define (initialize-package!) - (set! input-string-template - (make-input-port `((CHAR-READY? ,operation/char-ready?) - (DISCARD-CHAR ,operation/discard-char) - (DISCARD-CHARS ,operation/discard-chars) - (PEEK-CHAR ,operation/peek-char) - (WRITE-SELF ,operation/write-self) - (READ-CHAR ,operation/read-char) - (READ-STRING ,operation/read-string)) - false))) + (set! input-string-port-type + (make-input-port-type `((CHAR-READY? ,operation/char-ready?) + (DISCARD-CHAR ,operation/discard-char) + (DISCARD-CHARS ,operation/discard-chars) + (PEEK-CHAR ,operation/peek-char) + (WRITE-SELF ,operation/write-self) + (READ-CHAR ,operation/read-char) + (READ-STRING ,operation/read-string)) + #f)) + unspecific) (define (with-input-from-string string thunk) (with-input-from-port (string->input-port string) thunk)) @@ -43,8 +44,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (default-object? end) (string-length string) (check-index end (string-length string) 'STRING->INPUT-PORT)))) - (input-port/copy - input-string-template + (make-port + input-string-port-type (make-input-string-state string (if (default-object? start) 0 @@ -58,13 +59,13 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (error:bad-range-argument index procedure)) index) -(define input-string-template) +(define input-string-port-type) (define-structure (input-string-state (type vector) (conc-name input-string-state/)) - (string false read-only true) + (string #f read-only #t) start - (end false read-only true)) + (end #f read-only #t)) (define-integrable (input-port/string port) (input-string-state/string (input-port/state port))) diff --git a/v7/src/runtime/strott.scm b/v7/src/runtime/strott.scm index 6176aa6e5..d2e2aedff 100644 --- a/v7/src/runtime/strott.scm +++ b/v7/src/runtime/strott.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strott.scm,v 14.6 1999/02/16 00:53:21 cph Exp $ +$Id: strott.scm,v 14.7 1999/02/16 20:11:51 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -25,11 +25,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) (define (initialize-package!) - (set! output-string-template - (make-output-port `((WRITE-SELF ,operation/write-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring)) - #f))) + (set! output-string-port-type + (make-output-port-type `((WRITE-SELF ,operation/write-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring)) + #f))) (define (with-output-to-truncated-string max thunk) (call-with-current-continuation @@ -40,11 +40,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (let ((state (make-output-string-state return max '() max))) (with-output-to-port - (output-port/copy output-string-template state) + (make-port output-string-port-type state) thunk) (output-string-state/accumulator state)))))))) -(define output-string-template) +(define output-string-port-type) (define-structure (output-string-state (type vector) (conc-name output-string-state/)) diff --git a/v7/src/runtime/strout.scm b/v7/src/runtime/strout.scm index 8ec9f9c8b..a328611d8 100644 --- a/v7/src/runtime/strout.scm +++ b/v7/src/runtime/strout.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: strout.scm,v 14.9 1999/01/02 06:19:10 cph Exp $ +$Id: strout.scm,v 14.10 1999/02/16 20:11:47 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -25,11 +25,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) (define (initialize-package!) - (set! output-string-template - (make-output-port `((WRITE-SELF ,operation/write-self) - (WRITE-CHAR ,operation/write-char) - (WRITE-SUBSTRING ,operation/write-substring)) - false)) + (set! output-string-port-type + (make-output-port-type `((WRITE-SELF ,operation/write-self) + (WRITE-CHAR ,operation/write-char) + (WRITE-SUBSTRING ,operation/write-substring)) + #f)) unspecific) (define (with-output-to-string thunk) @@ -39,14 +39,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (with-string-output-port generator) (let ((state (make-output-string-state (make-string 16) 0))) - (let ((port (output-port/copy output-string-template state))) + (let ((port (make-port output-string-port-type state))) (generator port) (without-interrupts (lambda () (string-head (output-string-state/accumulator state) (output-string-state/counter state))))))) -(define output-string-template) +(define output-string-port-type) (define-structure (output-string-state (type vector) (conc-name output-string-state/)) diff --git a/v7/src/runtime/ttyio.scm b/v7/src/runtime/ttyio.scm index b2e731925..290e7404f 100644 --- a/v7/src/runtime/ttyio.scm +++ b/v7/src/runtime/ttyio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ttyio.scm,v 1.9 1999/02/16 05:44:54 cph Exp $ +$Id: ttyio.scm,v 1.10 1999/02/16 20:11:30 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -32,45 +32,29 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (output-channel (tty-output-channel))) (set! hook/read-char operation/read-char) (set! hook/peek-char operation/peek-char) - (set! the-console-port - (make-i/o-port + (set! the-console-port-type + (make-i/o-port-type `((BEEP ,operation/beep) - (BUFFERED-INPUT-CHARS ,operation/buffered-input-chars) - (BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars) - (CHAR-READY? ,operation/char-ready?) (CLEAR ,operation/clear) - (DISCARD-CHAR ,operation/read-char) - (DISCRETIONARY-FLUSH-OUTPUT ,operation/discretionary-flush-output) + (DISCRETIONARY-FLUSH-OUTPUT + ,operation/discretionary-flush-output) (FLUSH-OUTPUT ,operation/flush-output) (FRESH-LINE ,operation/fresh-line) - (INPUT-BLOCKING-MODE ,operation/input-blocking-mode) - (INPUT-BUFFER-SIZE ,operation/input-buffer-size) - (INPUT-CHANNEL ,operation/input-channel) - (INPUT-OPEN? ,operation/input-open?) - (INPUT-TERMINAL-MODE ,operation/input-terminal-mode) - (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode) - (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size) - (OUTPUT-CHANNEL ,operation/output-channel) - (OUTPUT-OPEN? ,operation/output-open?) - (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode) (PEEK-CHAR ,(lambda (port) (hook/peek-char port))) - (WRITE-SELF ,operation/write-self) (READ-CHAR ,(lambda (port) (hook/read-char port))) (READ-FINISH ,operation/read-finish) - (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode) - (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size) - (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode) - (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode) - (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size) - (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode) (WRITE-CHAR ,operation/write-char) + (WRITE-SELF ,operation/write-self) (WRITE-SUBSTRING ,operation/write-substring) (X-SIZE ,operation/x-size) (Y-SIZE ,operation/y-size)) - (make-console-port-state - (make-input-buffer input-channel input-buffer-size) - (make-output-buffer output-channel output-buffer-size) - (channel-type=file? input-channel)))) + generic-i/o-type)) + (set! the-console-port + (make-port the-console-port-type + (make-console-port-state + (make-input-buffer input-channel input-buffer-size) + (make-output-buffer output-channel output-buffer-size) + (channel-type=file? input-channel)))) (set-channel-port! input-channel the-console-port) (set-channel-port! output-channel the-console-port)) (add-event-receiver! event:before-exit save-console-input) @@ -79,6 +63,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (set-current-input-port! the-console-port) (set-current-output-port! the-console-port)) +(define the-console-port-type) (define the-console-port) (define input-buffer-size 512) (define output-buffer-size 512) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 1bf746ad6..9642462cb 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.318 1999/02/16 19:49:13 cph Exp $ +$Id: runtime.pkg,v 14.319 1999/02/16 20:11:00 cph Exp $ Copyright (c) 1988-1999 Massachusetts Institute of Technology @@ -386,7 +386,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. console-output-port set-console-i/o-port!) (export (runtime emacs-interface) - the-console-port) + the-console-port + the-console-port-type) (initialization (initialize-package!))) (define-package (runtime continuation) @@ -913,60 +914,11 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. make-generic-input-port make-generic-output-port) (export (runtime console-i/o-port) - operation/buffered-input-chars - operation/buffered-output-chars - operation/char-ready? - operation/input-blocking-mode - operation/input-buffer-size - operation/input-channel - operation/input-open? - operation/input-terminal-mode - operation/output-blocking-mode - operation/output-buffer-size - operation/output-channel - operation/output-open? - operation/output-terminal-mode - operation/set-input-blocking-mode - operation/set-input-buffer-size - operation/set-input-terminal-mode - operation/set-output-blocking-mode - operation/set-output-buffer-size - operation/set-output-terminal-mode) + generic-i/o-type) (export (runtime file-i/o-port) - operation/buffered-input-chars - operation/buffered-output-chars - operation/char-ready? - operation/chars-remaining - operation/close - operation/close-input - operation/close-output - operation/discard-char - operation/discard-chars - operation/eof? - operation/flush-output - operation/fresh-line - operation/input-blocking-mode - operation/input-buffer-size - operation/input-channel - operation/input-open? - operation/input-terminal-mode - operation/output-blocking-mode - operation/output-buffer-size - operation/output-channel - operation/output-open? - operation/output-terminal-mode - operation/peek-char - operation/read-char - operation/read-string - operation/read-substring - operation/set-input-blocking-mode - operation/set-input-buffer-size - operation/set-input-terminal-mode - operation/set-output-blocking-mode - operation/set-output-buffer-size - operation/set-output-terminal-mode - operation/write-char - operation/write-substring) + generic-i/o-type + generic-input-type + generic-output-type) (initialization (initialize-package!))) (define-package (runtime gensym) -- 2.25.1