(define (->string object)
(if (string? object)
object
- (with-output-to-string (lambda () (display object)))))
+ (call-with-output-string
+ (lambda (port)
+ (display object port)))))
\f
(define (load-ps-copy-file file source-dir dest-dir)
(let ((source-file (merge-pathnames file source-dir))
(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 ()
(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
(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
(and repl
(let ((port (cmdl/port repl)))
(let ((operation
- (port/operation
+ (textual-port-operation
port
'CURRENT-EXPRESSION-CONTEXT)))
(and operation
(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))))))
(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*)
(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)
(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)
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))
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))
(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
#\-)
(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))
\f
(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))))
(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)))
(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)))
(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)))
(+ (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)))
(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
(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*" '())))
(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))))))
\f
(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
(buffer-not-modified! buffer)))))))
\f
(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)))
(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
(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)
(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))
(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)))
(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))
(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
(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
(lambda (port)
(encode-header-field-value value
(lambda (string start end)
- (write-substring string start end port))))))
+ (write-string string port start end))))))
\f
(define (get-first-header-field headers name error?)
(let loop ((headers (->header-fields headers)))
(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)
(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)))
\f
;;;; MIME Bodies
(define-method write-mime-body ((body <mime-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))
(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)))
(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)
(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))
\f
(define (start-imap-transcript pathname)
(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)
(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)
(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)
(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)
(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)
(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)
(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 ()
(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)
(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)))
(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
(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))))))
((< 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))))))
(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
(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
((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:"
(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)))))
\f
(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))
(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))
(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)
(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
((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)))
\f
(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))
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?))))))
\f
(define (method/compiled-code frame)
(let ((get-environment
(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
(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))))
\f
(define (pa procedure)
(guarantee procedure? procedure 'PA)
(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)
(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)
(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)
\f
(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)))))))))
(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)
(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
(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)
(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))
*parser-radix*))
\f
(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 ()
(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)))))))))
(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)))
(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))))
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)))
\f
(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)))
(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)))
(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
((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
(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)))))
(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)))))
\f
;;;; Char-Set Compiler
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))
;; 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)))
(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)))
(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)))
;;;; 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)))
(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))))
\f
(define (open-output-string)
(make-textual-port string-output-type (make-ostate (string-builder) 0)))
(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))))))
(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)
(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)
(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
(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)
(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)
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)
(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
(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))
(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)))
(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)))
\f
(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 ()
(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
(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
(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))
(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
(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
(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))))))
(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
(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
(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)))))
(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)))))
(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)))))
(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)))))
;;;; 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))))
(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))))
(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))))
(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)
(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))))
\f
(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
(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
(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))
(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)
(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 #\\)
(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)))
(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)))))
\f
(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)
(define (file->string filename)
(call-with-input-file filename
(lambda (port)
- ((port/operation port 'REST->STRING) port))))
+ ((textual-port-operation port 'REST->STRING) port))))
\f
(define (search-speed-test text die-length die-skew procedure n-repeats)
(let ((entries (map car (dice-text text die-length die-skew))))
(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
projects / mit-scheme.git / commitdiff