From: Chris Hanson Date: Tue, 25 Apr 2017 06:26:29 +0000 (-0700) Subject: Eliminate the low-hangin references to deprecated bindings. X-Git-Tag: mit-scheme-pucked-9.2.12~153^2~11 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cdc121125e5478d234d19bc8a92ba75515de166d;p=mit-scheme.git Eliminate the low-hangin references to deprecated bindings. --- diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm index 0d364246c..f92766834 100644 --- a/src/6001/edextra.scm +++ b/src/6001/edextra.scm @@ -301,7 +301,9 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh. (define (->string object) (if (string? object) object - (with-output-to-string (lambda () (display object))))) + (call-with-output-string + (lambda (port) + (display object port))))) (define (load-ps-copy-file file source-dir dest-dir) (let ((source-file (merge-pathnames file source-dir)) diff --git a/src/6001/floppy.scm b/src/6001/floppy.scm index 327a7cd35..1adeec2d4 100644 --- a/src/6001/floppy.scm +++ b/src/6001/floppy.scm @@ -619,7 +619,7 @@ M-x rename-file, or use the `r' command in Dired.") (if (= start end) '() (let ((eol - (or (substring-find-next-char string start end #\newline) + (or (string-find-next-char string #\newline start end) end))) (with-values (lambda () @@ -897,8 +897,8 @@ M-x rename-file, or use the `r' command in Dired.") (valid-name? (lambda (end) (and (<= 1 end 8) - (not (substring-find-next-char-in-set filename 0 end - invalid-chars)) + (not (string-find-next-char-in-set filename invalid-chars + 0 end)) (not (any (lambda (name) (substring=? filename 0 end @@ -911,8 +911,8 @@ M-x rename-file, or use the `r' command in Dired.") (valid-name? end) (and (valid-name? dot) (<= 2 (- end dot) 4) - (not (substring-find-next-char-in-set filename (+ dot 1) end - invalid-chars))))))))) + (not (string-find-next-char-in-set filename invalid-chars + (+ dot 1) end))))))))) (define dos-filename-description diff --git a/src/6001/nodefs.scm b/src/6001/nodefs.scm index c5d0fb3df..9bf33b730 100644 --- a/src/6001/nodefs.scm +++ b/src/6001/nodefs.scm @@ -39,7 +39,7 @@ USA. (and repl (let ((port (cmdl/port repl))) (let ((operation - (port/operation + (textual-port-operation port 'CURRENT-EXPRESSION-CONTEXT))) (and operation diff --git a/src/compiler/base/debug.scm b/src/compiler/base/debug.scm index 38a3425af..5331e6cc9 100644 --- a/src/compiler/base/debug.scm +++ b/src/compiler/base/debug.scm @@ -78,7 +78,7 @@ USA. (define (write-rtl-instructions rtl port) (write-instructions (lambda () - (with-output-to-port port + (parameterize* (list (cons current-output-port port)) (lambda () (for-each show-rtl-instruction rtl)))))) diff --git a/src/compiler/base/toplev.scm b/src/compiler/base/toplev.scm index 2b2de22e2..06f269d16 100644 --- a/src/compiler/base/toplev.scm +++ b/src/compiler/base/toplev.scm @@ -1065,7 +1065,7 @@ USA. (parameterize* (list (cons param:unparser-radix 16) (cons param:unparse-uninterned-symbols-by-name? #t)) (lambda () - (with-output-to-port port + (parameterize* (list (cons current-output-port port)) (lambda () (write-string "LAP for object ") (write *recursive-compilation-number*) diff --git a/src/compiler/machines/C/cout.scm b/src/compiler/machines/C/cout.scm index 4e7012d92..72f59b078 100644 --- a/src/compiler/machines/C/cout.scm +++ b/src/compiler/machines/C/cout.scm @@ -541,8 +541,8 @@ USA. (let loop ((src 0) (dst 0)) (if (fix:>= src len) (substring temp 0 dst) - (let ((index (substring-find-next-char-in-set - string src len char-set:C-string-quoted))) + (let ((index (string-find-next-char-in-set + string char-set:C-string-quoted src len))) (if (not index) (begin (substring-move! string src len temp dst) diff --git a/src/compiler/machines/C/cutl.scm b/src/compiler/machines/C/cutl.scm index 8add3804c..216751e78 100644 --- a/src/compiler/machines/C/cutl.scm +++ b/src/compiler/machines/C/cutl.scm @@ -223,13 +223,13 @@ USA. (lambda (port) (let ((end (string-length comment))) (let loop ((start 0) (index index)) - (write-substring comment start index port) + (write-string comment port start index) (write-string "*\\/" port) (let ((index (+ index 2))) (cond ((substring-search-forward "*/" comment index end) => (lambda (index*) (loop index index*))) (else - (write-substring comment index end port)))))))))) + (write-string comment port index end)))))))))) (else comment))) (define (c:string . content) diff --git a/src/compiler/machines/i386/dassm1.scm b/src/compiler/machines/i386/dassm1.scm index d084e2569..2057f614a 100644 --- a/src/compiler/machines/i386/dassm1.scm +++ b/src/compiler/machines/i386/dassm1.scm @@ -126,8 +126,10 @@ USA. offset (lambda () (if comment - (let ((s (with-output-to-string - (lambda () (display instruction))))) + (let ((s + (call-with-output-string + (lambda (port) + (display instruction port))))) (if (< (string-length s) 40) (write-string (string-pad-right s 40)) (write-string s)) diff --git a/src/compiler/machines/x86-64/dassm1.scm b/src/compiler/machines/x86-64/dassm1.scm index d084e2569..2057f614a 100644 --- a/src/compiler/machines/x86-64/dassm1.scm +++ b/src/compiler/machines/x86-64/dassm1.scm @@ -126,8 +126,10 @@ USA. offset (lambda () (if comment - (let ((s (with-output-to-string - (lambda () (display instruction))))) + (let ((s + (call-with-output-string + (lambda (port) + (display instruction port))))) (if (< (string-length s) 40) (write-string (string-pad-right s 40)) (write-string s)) diff --git a/src/edwin/artdebug.scm b/src/edwin/artdebug.scm index ba3d96b7c..dfa4e5a37 100644 --- a/src/edwin/artdebug.scm +++ b/src/edwin/artdebug.scm @@ -1062,7 +1062,11 @@ Prefix argument means do not kill the debugger buffer." (write-string (string-pad-right (string-append - (cdr (with-output-to-truncated-string pad-width expression-thunk)) + (cdr + (call-with-truncated-output-string pad-width + (lambda (port) + (parameterize* (list (cons current-output-port port)) + expression-thunk)))) " ") pad-width #\-) diff --git a/src/edwin/bufcom.scm b/src/edwin/bufcom.scm index 9d105591a..15610b091 100644 --- a/src/edwin/bufcom.scm +++ b/src/edwin/bufcom.scm @@ -274,7 +274,8 @@ When locked, the buffer's major mode may not be changed." (define (with-output-to-temporary-buffer name properties thunk) (call-with-output-to-temporary-buffer name properties (lambda (port) - (with-output-to-port port thunk)))) + (parameterize* (list (cons current-output-port port)) + thunk)))) (define (call-with-temporary-buffer name procedure) (let ((buffer)) diff --git a/src/edwin/bufinp.scm b/src/edwin/bufinp.scm index 7053348d2..443ca3a05 100644 --- a/src/edwin/bufinp.scm +++ b/src/edwin/bufinp.scm @@ -30,15 +30,18 @@ USA. (define (with-input-from-mark mark thunk #!optional receiver) (let ((port (make-buffer-input-port mark (group-end mark)))) - (let ((value (with-input-from-port port thunk))) + (let ((value + (parameterize* (list (cons current-input-port port)) + thunk))) (if (default-object? receiver) value (receiver value (input-port/mark port)))))) (define (with-input-from-region region thunk) - (with-input-from-port - (make-buffer-input-port (region-start region) (region-end region)) - thunk)) + (parameterize* (list (cons current-input-port + (make-buffer-input-port (region-start region) + (region-end region)))) + thunk)) (define (call-with-input-mark mark procedure) (procedure (make-buffer-input-port mark (group-end mark)))) @@ -57,7 +60,7 @@ USA. (mark-index start)))) (define (input-port/mark port) - (let ((operation (port/operation port 'BUFFER-MARK))) + (let ((operation (textual-port-operation port 'BUFFER-MARK))) (if (not operation) (error:bad-range-argument port 'INPUT-PORT/MARK)) (operation port))) diff --git a/src/edwin/bufout.scm b/src/edwin/bufout.scm index 2ebc95843..59979c4e1 100644 --- a/src/edwin/bufout.scm +++ b/src/edwin/bufout.scm @@ -32,7 +32,8 @@ USA. (define (with-output-to-mark mark thunk) (call-with-output-mark mark (lambda (port) - (with-output-to-port port thunk)))) + (parameterize* (list (cons current-output-port port)) + thunk)))) (define (call-with-output-mark mark procedure) (let ((port (mark->output-port mark))) diff --git a/src/edwin/debug.scm b/src/edwin/debug.scm index dbcbbae1f..30cc5d47e 100644 --- a/src/edwin/debug.scm +++ b/src/edwin/debug.scm @@ -696,14 +696,16 @@ USA. (bline/depth bline))))) (insert-horizontal-space indentation mark) (let ((summary - (with-output-to-truncated-string - (max summary-minimum-columns - (- columns indentation 4)) - (lambda () - ((bline-type/write-summary - (bline/type bline)) - bline - (current-output-port)))))) + (call-with-truncated-output-string + (max summary-minimum-columns + (- columns indentation 4)) + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + ((bline-type/write-summary + (bline/type bline)) + bline + (current-output-port)))))))) (insert-string (cdr summary) mark) (if (car summary) (insert-string " ..." mark))) @@ -1586,12 +1588,9 @@ once it has been renamed, it will not be deleted automatically.") (+ (string-length name1) (string-length separator)))) (write-string (string-tail - (with-output-to-string + (call-with-output-string (lambda () - (pretty-print value - (current-output-port) - #t - indentation))) + (pretty-print value port #t indentation))) indentation) port)))))) (debugger-newline port))) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index 193aed4c0..83ef83d57 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -417,14 +417,18 @@ Set by Scheme evaluation code to update the mode line." (define (editor-eval buffer sexp environment) (let ((core (lambda () - (with-input-from-port dummy-i/o-port + (parameterize* (list (cons current-input-port dummy-i/o-port)) (lambda () (let ((value)) (let ((output-string - (with-output-to-string - (lambda () - (set! value (eval-with-history sexp environment)) - unspecific)))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port + port)) + (lambda () + (set! value + (eval-with-history sexp environment)) + unspecific)))))) (let ((evaluation-output-receiver (ref-variable evaluation-output-receiver buffer))) (if evaluation-output-receiver @@ -482,13 +486,16 @@ Set by Scheme evaluation code to update the mode line." (let ((output-port (mark->output-port (buffer-end buffer) buffer))) (fresh-line output-port) - (with-output-to-port output-port thunk)))))) + (parameterize* (list (cons current-output-port output-port)) + thunk)))))) (let ((value)) (let ((output - (with-output-to-string - (lambda () - (set! value (thunk)) - unspecific)))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + (set! value (thunk)) + unspecific)))))) (if (and (not (string-null? output)) (not (ref-variable evaluation-output-receiver))) (string->temporary-buffer output "*Unsolicited-Output*" '()))) diff --git a/src/edwin/eystep.scm b/src/edwin/eystep.scm index 032f90800..fde80d695 100644 --- a/src/edwin/eystep.scm +++ b/src/edwin/eystep.scm @@ -61,7 +61,7 @@ USA. (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (with-input-from-port dummy-i/o-port + (parameterize* (list (cons current-input-port dummy-i/o-port)) (lambda () (with-output-to-transcript-buffer thunk)))))) diff --git a/src/edwin/fileio.scm b/src/edwin/fileio.scm index 2503fdc5c..1f8a51da1 100644 --- a/src/edwin/fileio.scm +++ b/src/edwin/fileio.scm @@ -216,7 +216,7 @@ of the predicates is satisfied, the file is written in the usual way." (lambda (port) (if (not (ref-variable translate-file-data-on-input group)) (port/set-line-ending port 'NEWLINE)) - (let ((length ((port/operation port 'LENGTH) port))) + (let ((length ((textual-port-operation port 'LENGTH) port))) (bind-condition-handler (list condition-type:allocation-failure) (lambda (condition) condition diff --git a/src/edwin/hlpcom.scm b/src/edwin/hlpcom.scm index c60226365..8962f5c29 100644 --- a/src/edwin/hlpcom.scm +++ b/src/edwin/hlpcom.scm @@ -316,7 +316,11 @@ If you want VALUE to be a string, you must surround it with doublequotes." (buffer-not-modified! buffer))))))) (define (with-output-to-help-display thunk) - (string->temporary-buffer (with-output-to-string thunk) + (string->temporary-buffer (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port + port)) + thunk))) "*Help*" '(READ-ONLY))) diff --git a/src/edwin/process.scm b/src/edwin/process.scm index 4f858d5a6..c2d8f6fd8 100644 --- a/src/edwin/process.scm +++ b/src/edwin/process.scm @@ -221,7 +221,7 @@ Initialized from the SHELL environment variable." (or (let ((port (subprocess-input-port (process-subprocess (car processes))))) (and port - (port/open? port) + (textual-port-open? port) (call-with-current-continuation (lambda (k) (bind-condition-handler @@ -244,7 +244,7 @@ Initialized from the SHELL environment variable." (define (poll-process-for-output process) (let ((port (subprocess-input-port (process-subprocess process)))) - (and (port/open? port) + (and (textual-port-open? port) (let ((n (call-with-current-continuation (lambda (k) diff --git a/src/edwin/sendmail.scm b/src/edwin/sendmail.scm index 345817a63..c73536b23 100644 --- a/src/edwin/sendmail.scm +++ b/src/edwin/sendmail.scm @@ -920,7 +920,7 @@ the user from the mailer." (append-message (buffer-length buffer) port))) (call-with-append-file pathname (lambda (port) - (append-message ((port/operation port 'LENGTH) port) + (append-message ((textual-port-operation port 'LENGTH) port) port))))))) pathnames)) diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index 60eca3a70..5d7cee0f9 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -97,7 +97,7 @@ USA. (terminal-output-baud-rate channel)))) (define (output-port/buffered-bytes port) - (let ((operation (port/operation port 'BUFFERED-OUTPUT-BYTES))) + (let ((operation (textual-port-operation port 'BUFFERED-OUTPUT-BYTES))) (if operation (operation port) 0))) diff --git a/src/edwin/winout.scm b/src/edwin/winout.scm index 91b685521..a0b879e21 100644 --- a/src/edwin/winout.scm +++ b/src/edwin/winout.scm @@ -33,7 +33,8 @@ USA. (with-output-to-window-point (current-window) thunk)) (define (with-output-to-window-point window thunk) - (with-output-to-port (window-output-port window) thunk)) + (parameterize* (list (cons current-output-port (window-output-port window))) + thunk)) (define (window-output-port window) (make-port window-output-port-type window)) diff --git a/src/edwin/world-monitor.scm b/src/edwin/world-monitor.scm index da4d62b04..a98bd4c6b 100644 --- a/src/edwin/world-monitor.scm +++ b/src/edwin/world-monitor.scm @@ -55,8 +55,9 @@ it, and spawn a thread to update it after every (thread-flags (list (cons (current-thread) "edwin")))) (define (new-report) - (with-output-to-string - (lambda () (world-report (current-output-port) thread-flags)))) + (call-with-output-string + (lambda (port) + (world-report port thread-flags)))) (define (sleep) (sleep-current-thread diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm index 6d4a83b26..f48523d12 100644 --- a/src/imail/imail-core.scm +++ b/src/imail/imail-core.scm @@ -1028,12 +1028,12 @@ USA. (define (write-header-fields headers port) (encode-header-fields headers (lambda (string start end) - (write-substring string start end port)))) + (write-string string port start end)))) (define (write-header-field header port) (encode-header-field header (lambda (string start end) - (write-substring string start end port)))) + (write-string string port start end)))) (define (header-fields->string headers) (call-with-output-string @@ -1050,7 +1050,7 @@ USA. (lambda (port) (encode-header-field-value value (lambda (string start end) - (write-substring string start end port)))))) + (write-string string port start end)))))) (define (get-first-header-field headers name error?) (let loop ((headers (->header-fields headers))) diff --git a/src/imail/imail-imap.scm b/src/imail/imail-imap.scm index 57613456f..34f7c52bc 100644 --- a/src/imail/imail-imap.scm +++ b/src/imail/imail-imap.scm @@ -2155,7 +2155,7 @@ USA. (let ((n (read-string! buffer input-port))) (if (fix:> n 0) (begin - (write-substring buffer 0 n output-port) + (write-string buffer output-port 0 n) (loop))))))))) (define (delete-file-recursively pathname) diff --git a/src/imail/imail-mime.scm b/src/imail/imail-mime.scm index f1b018c61..b62850cf9 100644 --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@ -66,7 +66,7 @@ USA. (define-method write-mime-entity-body (mime-entity port) (guarantee-mime-entity mime-entity 'WRITE-MIME-ENTITY-BODY) (receive (string start end) (mime-entity-body-substring mime-entity) - (write-substring string start end port))) + (write-string string port start end))) ;;;; MIME Bodies @@ -96,7 +96,7 @@ USA. (define-method write-mime-body ((body ) port) (receive (string start end) (mime-body-substring body) - (write-substring string start end port))) + (write-string string port start end))) (define (mime-body-type-string body) (string-append (symbol->string (mime-body-type body)) @@ -565,7 +565,7 @@ USA. (lambda (output-port) (with-mime-best-effort (lambda () - (write-substring string start end output-port))))))))))) + (write-string string output-port start end))))))))))) (define (mime:get-boundary parameters) (let ((parameter (assq 'BOUNDARY parameters))) diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index cf92ac1f1..8dce7d435 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -425,7 +425,7 @@ USA. (define (read-file-into-string pathname) (call-with-legacy-binary-input-file pathname (lambda (port) - (let ((n-bytes ((port/operation port 'LENGTH) port))) + (let ((n-bytes ((textual-port-operation port 'LENGTH) port))) (let ((string (make-string n-bytes))) (let loop ((start 0)) (if (< start n-bytes) diff --git a/src/imail/imap-response.scm b/src/imail/imap-response.scm index e975d88f3..df690348a 100644 --- a/src/imail/imap-response.scm +++ b/src/imail/imap-response.scm @@ -552,7 +552,7 @@ USA. (define (read-substring!-internal string start end port) (let ((n-read (read-string! string port start end))) (if imap-transcript-port - (write-substring string start (+ start n-read) imap-transcript-port)) + (write-string string imap-transcript-port start (+ start n-read))) n-read)) (define (start-imap-transcript pathname) @@ -572,9 +572,9 @@ USA. (write-char char imap-transcript-port))) (define (imap-transcript-write-substring string start end port) - (write-substring string start end port) + (write-string string port start end) (if imap-transcript-port - (write-substring string start end imap-transcript-port))) + (write-string string imap-transcript-port start end))) (define (imap-transcript-write-string string port) (write-string string port) diff --git a/src/microcode/makegen/makegen.scm b/src/microcode/makegen/makegen.scm index c12246011..24770606b 100644 --- a/src/microcode/makegen/makegen.scm +++ b/src/microcode/makegen/makegen.scm @@ -188,7 +188,7 @@ USA. (let ((n (read-substring! buffer 0 4096 input))) (if (> n 0) (begin - (write-substring buffer 0 n output) + (write-string buffer output 0 n) (loop))))))))) (define (maybe-update-dependencies deps-filename source-files) diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index 319e5ebe0..f71f8c228 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -260,7 +260,7 @@ USA. (lambda (object width) (let ((output (write-to-string object width))) (if (car output) - (substring-fill! (cdr output) (- width 3) width #\.)) + (string-fill! (cdr output) #\. (- width 3) width)) (write-string (cdr output) port))))) (if (default-object? result) (write-string "[Entering " port) diff --git a/src/runtime/blowfish.scm b/src/runtime/blowfish.scm index fdf2aed66..3b898cabb 100644 --- a/src/runtime/blowfish.scm +++ b/src/runtime/blowfish.scm @@ -54,7 +54,7 @@ USA. (let ((m (blowfish-cfb64 input-buffer 0 n output-buffer 0 key init-vector m encrypt?))) - (write-substring output-buffer 0 n output) + (write-string output-buffer output 0 n) (loop m)))))) (lambda () (string-fill! input-buffer #\NUL) diff --git a/src/runtime/chrset.scm b/src/runtime/chrset.scm index 9557846e9..49c3ab78f 100644 --- a/src/runtime/chrset.scm +++ b/src/runtime/chrset.scm @@ -567,11 +567,11 @@ USA. (char-set (cons start end))) (define (%char-set-table char-set) - (let ((table (make-vector-8b #x100))) + (let ((table (make-bytevector #x100))) (do ((cp 0 (fix:+ cp 1))) ((not (fix:< cp #x100))) - (vector-8b-set! table cp - (if (%code-point-in-char-set? cp char-set) 1 0))) + (bytevector-u8-set! table cp + (if (%code-point-in-char-set? cp char-set) 1 0))) table)) (define (8-bit-char-set? char-set) diff --git a/src/runtime/crypto.scm b/src/runtime/crypto.scm index bcc5b5ba8..9587e8e22 100644 --- a/src/runtime/crypto.scm +++ b/src/runtime/crypto.scm @@ -403,7 +403,7 @@ USA. (define (mcrypt-encrypt context input input-start input-end output output-start encrypt?) (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT) - (substring-move! input input-start input-end output output-start) + (string-copy! output output-start input input-start input-end) (let ((code ((if encrypt? (ucode-primitive mcrypt_generic 4) @@ -497,7 +497,7 @@ USA. (begin (mcrypt-encrypt context input-buffer 0 n output-buffer 0 encrypt?) - (write-substring output-buffer 0 n output) + (write-string output-buffer output 0 n) (loop))))) (mcrypt-end context)) (lambda () diff --git a/src/runtime/dbgutl.scm b/src/runtime/dbgutl.scm index 25f146386..50e6512ab 100644 --- a/src/runtime/dbgutl.scm +++ b/src/runtime/dbgutl.scm @@ -88,9 +88,13 @@ USA. (write-string ">") (exit unspecific)) thunk)))))) - (let ((x (with-output-to-truncated-string length thunk))) + (let ((x + (call-with-truncated-output-string length + (lambda (port) + (parameterize* (list (cons current-output-port port)) + thunk))))) (if (and (car x) (> length 4)) - (substring-move! " ..." 0 4 (cdr x) (- length 4))) + (string-copy! (cdr x) (- length 4) " ...")) (cdr x)))) (define (show-frames environment depth port) diff --git a/src/runtime/dosdir.scm b/src/runtime/dosdir.scm index f19bb84fd..63be1d995 100644 --- a/src/runtime/dosdir.scm +++ b/src/runtime/dosdir.scm @@ -122,7 +122,7 @@ USA. (lambda (posn) (let* ((len (string-length pattern)) (posn* - (substring-find-next-char pattern (1+ posn) len #\*))) + (string-find-next-char pattern #\* (1+ posn) len))) (if (not posn*) (simple-wildcard-matcher pattern posn) (let ((prefix (substring pattern 0 posn))) @@ -132,7 +132,7 @@ USA. (posn posn*)) (let* ((start (1+ posn)) (posn* - (substring-find-next-char pattern start len #\*))) + (string-find-next-char pattern #\* start len))) (if (not posn*) (full-wildcard-matcher prefix diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm index ce039864c..283fa2e1b 100644 --- a/src/runtime/dospth.scm +++ b/src/runtime/dospth.scm @@ -167,7 +167,7 @@ USA. (define (substring-components string start end delimiters) (let loop ((start start)) - (let ((index (substring-find-next-char-in-set string start end delimiters))) + (let ((index (string-find-next-char-in-set string delimiters start end))) (if index (cons (substring string start index) (loop (fix:+ index 1))) (list (substring string start end)))))) diff --git a/src/runtime/dragon4.scm b/src/runtime/dragon4.scm index 4a6302ca1..c09572add 100644 --- a/src/runtime/dragon4.scm +++ b/src/runtime/dragon4.scm @@ -114,13 +114,13 @@ not much different to numbers within a few orders of magnitude of 1. ((< k+1-l (- n)) (scientific-output digits k radix 0)) ((negative? k) - (string-append "." (make-legacy-string (- k+1) #\0) digits)) + (string-append "." (make-string (- k+1) #\0) digits)) ((negative? k+1-l) (string-append (string-head digits k+1) "." (string-tail digits k+1))) ((<= k n) - (string-append digits (make-legacy-string k+1-l #\0) ".")) + (string-append digits (make-string k+1-l #\0) ".")) (else (scientific-output digits k radix 0)))))) @@ -137,7 +137,7 @@ not much different to numbers within a few orders of magnitude of 1. (cond ((= l 0) (string-append "0e" exponent)) ((< l i) - (string-append digits (make-legacy-string (- i l) #\0) "e" exponent)) + (string-append digits (make-string (- i l) #\0) "e" exponent)) ((= l i) (string-append digits "e" exponent)) (else diff --git a/src/runtime/emacs.scm b/src/runtime/emacs.scm index ece60c73c..5b56ea257 100644 --- a/src/runtime/emacs.scm +++ b/src/runtime/emacs.scm @@ -198,7 +198,7 @@ USA. (let ((buffer (make-string buffer-length))) (string-set! buffer 0 #\altmode) (string-set! buffer 1 type) - (substring-move! string 0 length buffer 2) + (string-copy! buffer 2 string 0 length) (string-set! buffer (- buffer-length 1) #\altmode) (output-port/flush-output port) (with-absolutely-no-interrupts diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 35d70416b..ca6ba622c 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -292,7 +292,7 @@ USA. ((string-prefix? "dlname='" line) (let* ((start 8) (end (string-length line)) - (close (substring-find-next-char line start end #\'))) + (close (string-find-next-char line #\' start end))) (if close (substring line start close) (error "No closing delimiter in dlname setting:" @@ -613,7 +613,7 @@ USA. (with-notification (lambda (port) (write-string "Loading " port) - (write-string (string-upcase (symbol-name name)) port) + (write-string (string-upcase (symbol->string name)) port) (write-string " option" port)) kernel))))) diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm index ff02f0d1b..2c31a8145 100644 --- a/src/runtime/fileio.scm +++ b/src/runtime/fileio.scm @@ -231,7 +231,8 @@ USA. (define ((make-with-input-from-file call) input-specifier thunk) (call input-specifier (lambda (port) - (with-input-from-port port thunk)))) + (parameterize* (list (cons current-input-port port)) + thunk)))) (define with-input-from-file (make-with-input-from-file call-with-input-file)) @@ -242,7 +243,8 @@ USA. (define ((make-with-output-to-file call) output-specifier thunk) (call output-specifier (lambda (port) - (with-output-to-port port thunk)))) + (parameterize* (list (cons current-output-port port)) + thunk)))) (define with-output-to-file (make-with-output-to-file call-with-output-file)) diff --git a/src/runtime/format.scm b/src/runtime/format.scm index 28233b6e7..f60d63684 100644 --- a/src/runtime/format.scm +++ b/src/runtime/format.scm @@ -61,7 +61,7 @@ USA. (format-loop port format-string arguments) (output-port/discretionary-flush port)))) (cond ((not destination) - (with-output-to-string (lambda () (start (current-output-port))))) + (call-with-output-string start)) ((eq? destination true) (start (current-output-port))) ((output-port? destination) @@ -86,7 +86,10 @@ USA. (define (parse-dispatch port string supplied-arguments parsed-arguments modifiers) - ((vector-ref format-dispatch-table (vector-8b-ref string 0)) + ((let ((cp (char->integer (string-ref string 0)))) + (if (fix:< cp #x100) + (vector-ref format-dispatch-table cp) + parse-default)) port string supplied-arguments @@ -199,9 +202,9 @@ USA. ((if (memq 'AT modifiers) string-pad-left string-pad-right) - (with-output-to-string - (lambda () - (write (car arguments)))) + (call-with-output-string + (lambda (port) + (write (car arguments) port))) n-columns))) (format-loop port string (cdr arguments))) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index 312532bf1..bbb7f86fa 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -40,12 +40,12 @@ USA. (define (stack-frame/debugging-info/default frame) (values (make-debugging-info/noise (lambda (long?) - (with-output-to-string - (lambda () - (display "Unknown (methodless) ") + (call-with-output-string + (lambda (port) + (display "Unknown (methodless) " port) (if long? - (pp frame) - (write frame)))))) + (pp frame port) + (write frame port)))))) undefined-environment undefined-expression)) @@ -187,9 +187,11 @@ USA. undefined-expression)) (define ((hardware-trap-noise frame) long?) - (with-output-to-string - (lambda () - (hardware-trap-frame/describe frame long?)))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + (hardware-trap-frame/describe frame long?)))))) (define (method/compiled-code frame) (let ((get-environment diff --git a/src/runtime/gdatab.scm b/src/runtime/gdatab.scm index df276d8b4..bd45765e3 100644 --- a/src/runtime/gdatab.scm +++ b/src/runtime/gdatab.scm @@ -78,6 +78,6 @@ USA. (define (convert-old-method method) (lambda (state object) - (with-output-to-port (unparser-state/port state) + (parameterize* (list (cons current-output-port (unparser-state/port state))) (lambda () (method object))))) \ No newline at end of file diff --git a/src/runtime/global.scm b/src/runtime/global.scm index dc9b9fd97..7d7bef281 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -149,9 +149,10 @@ USA. (define with-values call-with-values) (define (write-to-string object #!optional max) - (if (or (default-object? max) (not max)) - (with-output-to-string (lambda () (write object))) - (with-output-to-truncated-string max (lambda () (write object))))) + ((if (or (default-object? max) (not max)) + call-with-output-string + call-with-truncated-output-string) + (lambda (port) (write object port)))) (define (pa procedure) (guarantee procedure? procedure 'PA) diff --git a/src/runtime/httpio.scm b/src/runtime/httpio.scm index cfb7db94b..777191446 100644 --- a/src/runtime/httpio.scm +++ b/src/runtime/httpio.scm @@ -285,7 +285,7 @@ USA. (let ((m (read-string! buffer port 0 (min n len)))) (if (= m 0) (error "Premature EOF in HTTP message body.")) - (write-substring buffer 0 m output) + (write-string buffer output 0 m) (loop (- n m))))))) (define (%read-delimited-body headers port) @@ -313,7 +313,7 @@ USA. (let ((n (read-string! buffer port))) (if (> n 0) (begin - (write-substring buffer 0 n output) + (write-string buffer output 0 n) (loop))))))))) (define (%no-read-body) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 6f3c10395..3e50b8aeb 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -516,7 +516,7 @@ USA. (define (retry-with-bigger-output-buffer) (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4))) (nbuffer (make-legacy-string new-size))) - (substring-move! buffer 0 buffer-size nbuffer 0) + (string-copy! nbuffer 0 buffer) (parse-command bp cp ip ip-end nbuffer new-size))) (define (refill-input-buffer-and-retry needed) diff --git a/src/runtime/load.scm b/src/runtime/load.scm index b47301de5..7916feb66 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -203,14 +203,14 @@ USA. (define (fasl-file? pathname) (and (file-regular? pathname) - (call-with-legacy-binary-input-file pathname + (call-with-binary-input-file pathname (lambda (port) (let ((n (bytes-per-object))) - (let ((marker (make-legacy-string n))) - (and (eqv? (read-string! marker port) n) + (let ((marker (make-bytevector n))) + (and (eqv? (read-bytevector! marker port) n) (let loop ((i 0)) (if (fix:< i n) - (and (fix:= (vector-8b-ref marker i) #xFA) + (and (fix:= (bytevector-u8-ref marker i) #xFA) (loop (fix:+ i 1))) #t))))))))) diff --git a/src/runtime/mime-codec.scm b/src/runtime/mime-codec.scm index dd1d356bf..61b14035f 100644 --- a/src/runtime/mime-codec.scm +++ b/src/runtime/mime-codec.scm @@ -81,7 +81,7 @@ USA. (start (fix:start-index start end caller))) (if (qp-encoding-context/text? context) (let loop ((start start)) - (let ((i (substring-find-next-char string start end #\newline))) + (let ((i (string-find-next-char string #\newline start end))) (if i (begin (encode-qp context string start i 'line-end) @@ -216,7 +216,7 @@ USA. (end (fix:end-index end (string-length string) caller)) (start (fix:start-index start end caller))) (let loop ((start start)) - (let ((i (substring-find-next-char string start end #\newline))) + (let ((i (string-find-next-char string #\newline start end))) (if i (begin (decode-qp context @@ -245,8 +245,8 @@ USA. (define (loop start) (let ((i - (substring-find-next-char-in-set string start end* - char-set:qp-encoded))) + (string-find-next-char-in-set string char-set:qp-encoded + start end*))) (if i (begin (write-string string port start i) @@ -910,7 +910,7 @@ USA. (define (update string start end) (if (and (not (eq? state 'finished)) (fix:< start end)) - (let ((nl (substring-find-next-char string start end #\newline))) + (let ((nl (string-find-next-char string #\newline start end))) (if nl (begin (builder (string-slice string start nl)) diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 47d77e5a2..aaf84327a 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -75,11 +75,11 @@ USA. *parser-radix*)) (define (parse-object port) - (let ((read-operation (port/operation port 'read))) + (let ((read-operation (textual-port-operation port 'read))) (if read-operation (read-operation port) (begin - (let ((read-start (port/operation port 'read-start))) + (let ((read-start (textual-port-operation port 'read-start))) (if read-start (read-start port))) (let restart () @@ -88,7 +88,8 @@ USA. (if (eq? object restart-parsing) (restart) (begin - (let ((read-finish (port/operation port 'read-finish))) + (let ((read-finish + (textual-port-operation port 'read-finish))) (if read-finish (read-finish port))) (finish-parsing object db))))))))) @@ -840,7 +841,8 @@ USA. (make-db port (make-shared-objects) '() - (let ((operation (port/operation port 'discretionary-write-char))) + (let ((operation + (textual-port-operation port 'discretionary-write-char))) (if operation (lambda (char) (operation port char)) (lambda (char) char unspecific))) @@ -852,12 +854,12 @@ USA. (required-unary-port-operation port 'read-char))) (define (required-unary-port-operation port operator) - (let ((operation (port/operation port operator))) + (let ((operation (textual-port-operation port operator))) (lambda () (operation port)))) (define (optional-unary-port-operation port operator default-value) - (let ((operation (port/operation port operator))) + (let ((operation (textual-port-operation port operator))) (if operation (lambda () (operation port)) (lambda () default-value)))) diff --git a/src/runtime/pgsql.scm b/src/runtime/pgsql.scm index d3ac49a81..f224583a6 100644 --- a/src/runtime/pgsql.scm +++ b/src/runtime/pgsql.scm @@ -209,10 +209,10 @@ USA. string #t))) (if regs - (write-substring string - (re-match-start-index 2 regs) - (re-match-end-index 2 regs) - port) + (write-string string + port + (re-match-start-index 2 regs) + (re-match-end-index 2 regs)) (write-string string port)))) (write-string "." port))) diff --git a/src/runtime/port.scm b/src/runtime/port.scm index ebf5d0652..df3eed44c 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -538,7 +538,7 @@ USA. (define (transcribe-substring string start end port) (let ((tport (textual-port-transcript port))) (if tport - (write-substring string start end tport)))) + (write-string string tport start end)))) (define (flush-transcript port) (let ((tport (textual-port-transcript port))) diff --git a/src/runtime/rexp.scm b/src/runtime/rexp.scm index 583aff844..c4e78dee3 100644 --- a/src/runtime/rexp.scm +++ b/src/runtime/rexp.scm @@ -216,8 +216,7 @@ USA. (let ((end (string-length s))) (let loop ((start 0) (parts '())) (let ((index - (substring-find-next-char-in-set s start end - char-set:alphabetic))) + (string-find-next-char-in-set s char-set:alphabetic start end))) (if index (loop (fix:+ index 1) (cons* (let ((char (string-ref s index))) diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm index ffb880dc4..9d6dbbbe4 100644 --- a/src/runtime/rfc2822-headers.scm +++ b/src/runtime/rfc2822-headers.scm @@ -164,10 +164,7 @@ USA. (lambda (out) (let loop ((line line)) (let ((end (skip-wsp-right line 0 (string-length line)))) - (write-substring line - (skip-wsp-left line 0 end) - end - out)) + (write-string line out (skip-wsp-left line 0 end) end)) (if (let ((char (peek-char port))) (if (eof-object? char) (parse-error port diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm index b5e52785a..ecb243f6b 100644 --- a/src/runtime/rgxcmp.scm +++ b/src/runtime/rgxcmp.scm @@ -212,14 +212,13 @@ USA. ((fix:< n 256) (vector-8b-set! result p re-code:exact-n) (vector-8b-set! result (fix:1+ p) n) - (substring-move! string i (fix:+ i n) - result (fix:+ p 2)) + (string-copy! result (fix:+ p 2) string i (fix:+ i n)) (make-compiled-regexp result case-fold?)) (else (vector-8b-set! result p re-code:exact-n) (vector-8b-set! result (fix:1+ p) 255) (let ((j (fix:+ i 255))) - (substring-move! string i j result (fix:+ p 2)) + (string-copy! result (fix:+ p 2) string i j) (loop (fix:- n 255) j (fix:+ p 257))))))))))))) (define char-set:re-special @@ -230,8 +229,8 @@ USA. (let ((n (let loop ((start 0) (n 0)) (let ((index - (substring-find-next-char-in-set string start end - char-set:re-special))) + (string-find-next-char-in-set string char-set:re-special + start end))) (if index (loop (1+ index) (1+ n)) n))))) @@ -240,18 +239,18 @@ USA. (let ((result (make-legacy-string (+ end n)))) (let loop ((start 0) (i 0)) (let ((index - (substring-find-next-char-in-set string start end - char-set:re-special))) + (string-find-next-char-in-set string char-set:re-special + start end))) (if index (begin - (substring-move! string start index result i) + (string-copy! result i string start index) (let ((i (+ i (- index start)))) (string-set! result i #\\) (string-set! result (1+ i) (string-ref string index)) (loop (1+ index) (+ i 2)))) - (substring-move! string start end result i)))) + (string-copy! result i string start end)))) result))))) ;;;; Char-Set Compiler diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index afffca8e2..a7b447297 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -165,14 +165,14 @@ USA. unspecific) (define (socket/close-input port) - (if (port/open? port) + (if (textual-port-open? port) ((ucode-primitive shutdown-socket 2) (channel-descriptor (input-port-channel port)) 1)) (generic-io/close-input port)) (define (socket/close-output port) - (if (port/open? port) + (if (textual-port-open? port) ((ucode-primitive shutdown-socket 2) (channel-descriptor (input-port-channel port)) 2)) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index fdb765a60..ea30480fd 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -33,7 +33,8 @@ USA. ;; obsolete (define (with-input-from-string string thunk) - (with-input-from-port (open-input-string string) thunk)) + (parameterize* (list (cons current-input-port (open-input-string string))) + thunk)) (define (call-with-input-string string procedure) (procedure (open-input-string string))) @@ -74,7 +75,7 @@ USA. (let ((ss (textual-port-state port))) (if (fix:< (istate-next ss) (istate-end ss)) (string-ref (istate-string ss) (istate-next ss)) - (make-eof-object port)))) + (eof-object)))) (define (string-in/read-char port) (let ((ss (textual-port-state port))) @@ -84,7 +85,7 @@ USA. (if (char=? char #\newline) (set-istate-line-number! ss (fix:+ 1 (istate-line-number ss)))) char) - (make-eof-object port)))) + (eof-object)))) (define (string-in/input-line port) (istate-line-number (textual-port-state port))) @@ -155,10 +156,10 @@ USA. ;;;; Output as characters (define (get-output-string port) - ((port/operation port 'extract-output) port)) + ((textual-port-operation port 'extract-output) port)) (define (get-output-string! port) - ((port/operation port 'extract-output!) port)) + ((textual-port-operation port 'extract-output!) port)) (define (call-with-output-string generator) (let ((port (open-output-string))) @@ -174,13 +175,15 @@ USA. (define (with-output-to-string thunk) (call-with-output-string (lambda (port) - (with-output-to-port port thunk)))) + (parameterize* (list (cons current-output-port port)) + thunk)))) ;; deprecated (define (with-output-to-truncated-string limit thunk) (call-with-truncated-output-string limit (lambda (port) - (with-output-to-port port thunk)))) + (parameterize* (list (cons current-output-port port)) + thunk)))) (define (open-output-string) (make-textual-port string-output-type (make-ostate (string-builder) 0))) @@ -247,7 +250,7 @@ USA. (loop (fix:+ i 1) (new-column (string-ref string i) column)) (set-ostate-column! os column))))) - (let ((nl (substring-find-previous-char string start end #\newline))) + (let ((nl (string-find-previous-char string #\newline start end))) (if nl (loop (fix:+ nl 1) 0) (loop start (ostate-column os)))))) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index dda4b7f71..1ed7c6762 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -306,7 +306,7 @@ USA. (let ((p (make-textual-port repl-port-type socket))) (dynamic-wind (lambda () unspecific) - (lambda () (with-output-to-port p thunk)) + (lambda () (parameterize* (list (cons current-output-port p)) thunk)) (lambda () (flush-output-port p))))) (define repl-port-type) @@ -383,11 +383,13 @@ USA. (define (swank:disassemble-symbol socket string) socket - (with-output-to-string - (lambda () - ((environment-lookup #f 'compiler:disassemble) - (eval (read-from-string string) - (buffer-env)))))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + ((environment-lookup #f 'compiler:disassemble) + (eval (read-from-string string) + (buffer-env)))))))) ;;;; Directory Functions (define (swank:default-directory socket) @@ -407,13 +409,18 @@ USA. (type (environment-reference-type env symbol)) (binding (if (eq? type 'normal) (environment-lookup env symbol) #f)) (binding-type (if binding (get-object-type-name binding) #f)) - (params (if (and binding (procedure? binding)) (procedure-parameters symbol env) #f))) + (params + (if (and binding (procedure? binding)) + (procedure-parameters symbol env) + #f))) (string-append - (format #f "~a in package ~a~a of type ~a.~%~%" (string-upcase (symbol->string symbol)) + (format #f "~a in package ~a~a of type ~a.~%~%" + (string-upcase (symbol->string symbol)) package (if (and binding (procedure? binding)) - (format #f " [originally defined in package ~a]" (env->pstring (procedure-environment binding))) + (format #f " [originally defined in package ~a]" + (env->pstring (procedure-environment binding))) "") (if binding-type binding-type type)) (if binding @@ -423,7 +430,8 @@ USA. (format #f "~%Signature: ~a.~%~%" params) "") (if binding - (format #f "It is:~%~%~a~%" (with-output-to-string (lambda () (pp binding)))) + (format #f "It is:~%~%~a~%" + (call-with-output-string (lambda (port) (pp binding port)))) "")))) (define (swank:describe-function socket function) @@ -473,10 +481,11 @@ USA. (define (swank:swank-macroexpand-all socket string) socket - (with-output-to-string - (lambda () + (call-with-output-string + (lambda (port) (pp (syntax (read-from-string string) - (buffer-env)))))) + (buffer-env)) + port)))) (define swank:swank-macroexpand-1 swank:swank-macroexpand-all) (define swank:swank-macroexpand swank:swank-macroexpand-all) @@ -485,10 +494,13 @@ USA. socket (let ((v (ignore-errors (lambda () - (with-output-to-string - (lambda () - (carefully-pa - (eval (read-from-string name) (pstring->env pstring))))))))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + (carefully-pa + (eval (read-from-string name) + (pstring->env pstring))))))))))) (if (condition? v) 'NIL v))) (define (carefully-pa o) @@ -535,8 +547,14 @@ USA. (let ((binding (environment-lookup env symbol))) (if (and binding (procedure? binding)) - (cons symbol (read-from-string (string-trim (with-output-to-string - (lambda () (pa binding)))))) + (cons symbol + (read-from-string + (string-trim + (call-with-output-string + (lambda (port) + (parameterize* + (list (cons current-output-port port)) + (lambda () (pa binding)))))))) #f)) (let ((extra (assq symbol swank-extra-documentation))) (if extra @@ -685,7 +703,7 @@ swank:xref (define (sldb-restarts restarts) (map (lambda (r) (list (symbol->string (restart/name r)) - (with-string-output-port + (call-with-output-string (lambda (p) (write-restart-report r p))))) restarts)) @@ -1058,9 +1076,12 @@ swank:xref (lambda () (procedure-environment o)))))) (else (stream (iline "block" (compiled-entry/block o)) - (with-output-to-string - (lambda () - ((environment-lookup #f 'compiler:disassemble) o))))))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + ((environment-lookup #f 'compiler:disassemble) + o))))))))) (define (inspect-code-block block) (let loop ((i (compiled-code-block/constants-start block))) @@ -1069,9 +1090,12 @@ swank:xref (loop (+ i compiled-code-block/bytes-per-object))) (stream (iline "debuginfo" (compiled-code-block/debugging-info block)) (iline "env" (compiled-code-block/environment block)) - (with-output-to-string - (lambda () - ((environment-lookup #f 'compiler:disassemble) block))))))) + (call-with-output-string + (lambda (port) + (parameterize* (list (cons current-output-port port)) + (lambda () + ((environment-lookup #f 'compiler:disassemble) + block))))))))) (define (inspect-scode o) (stream (pprint-to-string o))) diff --git a/src/runtime/syncproc.scm b/src/runtime/syncproc.scm index 3189220f4..366adf4d3 100644 --- a/src/runtime/syncproc.scm +++ b/src/runtime/syncproc.scm @@ -192,7 +192,7 @@ USA. (define (call-with-input-copier process process-input nonblock? bsize receiver) (let ((port (subprocess-output-port process))) - (let ((output-port/close (port/operation port 'CLOSE-OUTPUT))) + (let ((output-port/close (textual-port-operation port 'CLOSE-OUTPUT))) (if process-input (handle-broken-pipe process (lambda () @@ -232,8 +232,8 @@ USA. (define (call-with-output-copier process process-output nonblock? bsize receiver) (let ((port (subprocess-input-port process))) - (let ((input-port/open? (port/operation port 'INPUT-OPEN?)) - (input-port/close (port/operation port 'CLOSE-INPUT))) + (let ((input-port/open? (textual-port-operation port 'INPUT-OPEN?)) + (input-port/close (textual-port-operation port 'CLOSE-INPUT))) (if process-output (let ((buffer (make-string bsize))) (let ((copy-output diff --git a/src/runtime/system.scm b/src/runtime/system.scm index 3eeca778d..be464007e 100644 --- a/src/runtime/system.scm +++ b/src/runtime/system.scm @@ -118,9 +118,10 @@ USA. (define (match-entry? name entry) (let ((s (car entry))) - (substring-ci=? name 0 (string-length name) - s 0 - (or (string-find-next-char s #\space) - (string-length s))))) + (string-ci=? name + (let ((space (string-find-next-char s #\space))) + (if space + (string-slice s 0 space) + s))))) (define subsystem-identifications '()) \ No newline at end of file diff --git a/src/runtime/ttyio.scm b/src/runtime/ttyio.scm index ba1088f14..81812ef21 100644 --- a/src/runtime/ttyio.scm +++ b/src/runtime/ttyio.scm @@ -55,8 +55,8 @@ USA. (set-channel-port! output-channel port) (set! the-console-port port) (set-console-i/o-port! port) - (set-current-input-port! port) - (set-current-output-port! port)))) + (current-input-port port) + (current-output-port port)))) (set! port/echo-input? (generic-i/o-port-accessor 0)) (add-event-receiver! event:before-exit save-console-input) (add-event-receiver! event:after-restore reset-console)) diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 2999dab3f..90744cb75 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -379,7 +379,7 @@ USA. (buffer-length 8192)) (if (zero? source-length) 0 - (let* ((buffer (make-legacy-string buffer-length)) + (let* ((buffer (make-bytevector buffer-length)) (transfer (lambda (length) (let ((n-read @@ -475,7 +475,7 @@ USA. (pathname-as-directory (substring string start end))))) (let loop ((start 0)) (if (< start end) - (let ((index (substring-find-next-char string start end #\:))) + (let ((index (string-find-next-char string #\: start end))) (if index (cons (if (= index start) #f diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm index 5613efe52..1831c545f 100644 --- a/src/runtime/unxpth.scm +++ b/src/runtime/unxpth.scm @@ -127,7 +127,7 @@ USA. (define (substring-components string start end delimiter) (let loop ((start start)) - (let ((index (substring-find-next-char string start end delimiter))) + (let ((index (string-find-next-char string delimiter start end))) (if index (cons (substring string start index) (loop (fix:+ index 1))) (list (substring string start end)))))) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index f00a1698e..59f0305c7 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -37,7 +37,8 @@ USA. (environment (optional-environment environment 'PROMPT-FOR-COMMAND-EXPRESSION)) (level (nearest-cmdl/level))) - (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-EXPRESSION))) + (let ((operation + (textual-port-operation port 'PROMPT-FOR-COMMAND-EXPRESSION))) (if operation (operation port environment prompt level) (begin @@ -67,7 +68,7 @@ USA. (define (%prompt-for-expression port environment prompt caller) (let ((prompt (canonicalize-prompt prompt ": "))) - (let ((operation (port/operation port 'PROMPT-FOR-EXPRESSION))) + (let ((operation (textual-port-operation port 'PROMPT-FOR-EXPRESSION))) (if operation (operation port environment prompt) (begin @@ -96,7 +97,7 @@ USA. (let ((prompt (canonicalize-command-prompt prompt)) (port (if (default-object? port) (interaction-i/o-port) port)) (level (nearest-cmdl/level))) - (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-CHAR))) + (let ((operation (textual-port-operation port 'PROMPT-FOR-COMMAND-CHAR))) (if operation (operation port prompt level) (default/prompt-for-command-char port prompt level))))) @@ -120,7 +121,7 @@ USA. (define (prompt-for-confirmation prompt #!optional port) (let ((prompt (canonicalize-prompt prompt " (y or n)? ")) (port (if (default-object? port) (interaction-i/o-port) port))) - (let ((operation (port/operation port 'PROMPT-FOR-CONFIRMATION))) + (let ((operation (textual-port-operation port 'PROMPT-FOR-CONFIRMATION))) (if operation (operation port prompt) (default/prompt-for-confirmation port prompt))))) @@ -165,7 +166,7 @@ USA. (define (prompt-for-string prompt #!optional port) ;; Returns a string (the normal, "cooked" input line) or eof-object. (let ((port (if (default-object? port) (interaction-i/o-port) port))) - (let ((operation (port/operation port 'PROMPT-FOR-STRING))) + (let ((operation (textual-port-operation port 'PROMPT-FOR-STRING))) (if operation (operation port prompt) (default/prompt-for-string port prompt))))) @@ -188,7 +189,7 @@ USA. (begin (guarantee textual-i/o-port? port 'call-with-pass-phrase) port)))) - (let ((operation (port/operation port 'call-with-pass-phrase))) + (let ((operation (textual-port-operation port 'call-with-pass-phrase))) (if operation (operation port prompt receiver) (default/call-with-pass-phrase port prompt receiver))))) @@ -291,7 +292,7 @@ USA. ;;;; Debugger Support (define (port/debugger-failure port message) - (let ((operation (port/operation port 'DEBUGGER-FAILURE))) + (let ((operation (textual-port-operation port 'DEBUGGER-FAILURE))) (if operation (operation port message) (default/debugger-failure port message)))) @@ -301,7 +302,7 @@ USA. (default/debugger-message port message)) (define (port/debugger-message port message) - (let ((operation (port/operation port 'DEBUGGER-MESSAGE))) + (let ((operation (textual-port-operation port 'DEBUGGER-MESSAGE))) (if operation (operation port message) (default/debugger-message port message)))) @@ -311,7 +312,7 @@ USA. (write-string message port)) (define (port/debugger-presentation port thunk) - (let ((operation (port/operation port 'DEBUGGER-PRESENTATION))) + (let ((operation (textual-port-operation port 'DEBUGGER-PRESENTATION))) (if operation (operation port thunk) (default/debugger-presentation port thunk)))) @@ -324,7 +325,7 @@ USA. (define (port/write-result port expression value hash-number #!optional environment) - (let ((operation (port/operation port 'WRITE-RESULT)) + (let ((operation (textual-port-operation port 'WRITE-RESULT)) (environment (if (default-object? environment) (nearest-repl/environment) @@ -355,32 +356,32 @@ USA. (define write-result:undefined-value-is-special? true) (define (port/set-default-directory port directory) - (let ((operation (port/operation port 'SET-DEFAULT-DIRECTORY))) + (let ((operation (textual-port-operation port 'SET-DEFAULT-DIRECTORY))) (if operation (operation port directory)))) (define (port/set-default-environment port environment) - (let ((operation (port/operation port 'SET-DEFAULT-ENVIRONMENT))) + (let ((operation (textual-port-operation port 'SET-DEFAULT-ENVIRONMENT))) (if operation (operation port environment)))) (define (port/gc-start port) - (let ((operation (port/operation port 'GC-START))) + (let ((operation (textual-port-operation port 'GC-START))) (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/gc-finish port) - (let ((operation (port/operation port 'GC-FINISH))) + (let ((operation (textual-port-operation port 'GC-FINISH))) (if (and operation (not (*within-restore-window?*))) (operation port)))) (define (port/read-start port) - (let ((operation (port/operation port 'READ-START))) + (let ((operation (textual-port-operation port 'READ-START))) (if operation (operation port)))) (define (port/read-finish port) - (let ((operation (port/operation port 'READ-FINISH))) + (let ((operation (textual-port-operation port 'READ-FINISH))) (if operation (operation port)))) @@ -444,7 +445,7 @@ USA. (define (operation/x-size port) (let ((port* (textual-port-state port))) - (let ((op (port/operation port* 'X-SIZE))) + (let ((op (textual-port-operation port* 'X-SIZE))) (and op (let ((n (op port*))) (and n @@ -453,7 +454,7 @@ USA. (define (operation/column port) (let ((port* (textual-port-state port))) - (let ((op (port/operation port* 'COLUMN))) + (let ((op (textual-port-operation port* 'COLUMN))) (and op (let ((n (op port*))) (and n diff --git a/src/runtime/win32-registry.scm b/src/runtime/win32-registry.scm index eb80ab497..c57bfbc43 100644 --- a/src/runtime/win32-registry.scm +++ b/src/runtime/win32-registry.scm @@ -398,7 +398,7 @@ USA. (define (burst-string string delimiter) (let ((end (string-length string))) (let loop ((start 0) (result '())) - (let ((index (substring-find-next-char string start end delimiter))) + (let ((index (string-find-next-char string delimiter start end))) (if index (loop (fix:+ index 1) (cons (substring string start index) result)) diff --git a/src/ssp/mod-lisp.scm b/src/ssp/mod-lisp.scm index 025e4e44e..c3d349124 100644 --- a/src/ssp/mod-lisp.scm +++ b/src/ssp/mod-lisp.scm @@ -795,7 +795,7 @@ USA. (cond ((not n) (loop)) ((> n 0) - (write-substring buffer 0 n output) + (write-string buffer output 0 n) (loop))))))) (define (for-each-file-line pathname procedure) diff --git a/src/xml/rdf-nt.scm b/src/xml/rdf-nt.scm index 2f1602c3a..564290b28 100644 --- a/src/xml/rdf-nt.scm +++ b/src/xml/rdf-nt.scm @@ -131,7 +131,7 @@ USA. (loop))) (call-with-parser-buffer-tail b p (lambda (string start end) - (write-substring string start end port)))))) + (write-string string port start end)))))) (let ((char (let ((p (get-parser-buffer-pointer b))) (and (match-parser-buffer-char b #\\) diff --git a/src/xml/turtle.scm b/src/xml/turtle.scm index 44ed2eb64..96042c3ff 100644 --- a/src/xml/turtle.scm +++ b/src/xml/turtle.scm @@ -365,7 +365,7 @@ USA. (define (copy p) (call-with-parser-buffer-tail buffer p (lambda (string start end) - (write-substring string start end output)))) + (write-string string output start end)))) (define (finish) (vector (get-output-string output))) @@ -939,7 +939,7 @@ USA. (if (*match-string match:name s start end) (begin (write-string (symbol->string prefix) port) - (write-substring s start end port)) + (write-string s port start end)) (write-rdf/nt-uri uri port))) (write-rdf/nt-uri uri port))))) diff --git a/src/xml/xml-parser.scm b/src/xml/xml-parser.scm index e99111a09..2b4025984 100644 --- a/src/xml/xml-parser.scm +++ b/src/xml/xml-parser.scm @@ -891,7 +891,7 @@ USA. (let ((builder (string-builder))) (let loop ((start 0)) (let ((index - (substring-find-next-char string start end #\return))) + (string-find-next-char string #\return start end))) (if index (begin (builder #\newline) diff --git a/tests/runtime/test-boyer-moore.scm b/tests/runtime/test-boyer-moore.scm index 6d686b698..fdd5c2a28 100644 --- a/tests/runtime/test-boyer-moore.scm +++ b/tests/runtime/test-boyer-moore.scm @@ -74,7 +74,7 @@ USA. (define (file->string filename) (call-with-input-file filename (lambda (port) - ((port/operation port 'REST->STRING) port)))) + ((textual-port-operation port 'REST->STRING) port)))) (define (search-speed-test text die-length die-skew procedure n-repeats) (let ((entries (map car (dice-text text die-length die-skew)))) diff --git a/tests/runtime/test-dynamic-env.scm b/tests/runtime/test-dynamic-env.scm index 301630e88..7e9e68b32 100644 --- a/tests/runtime/test-dynamic-env.scm +++ b/tests/runtime/test-dynamic-env.scm @@ -73,7 +73,8 @@ USA. (assert-equal (call-with-output-string (lambda (port) - (with-output-to-port port complicated-dynamic-parameter))) + (parameterize* (list (cons current-output-port port)) + complicated-dynamic-parameter))) "1 2 1