From 261d99965d6223eaecca63ab11f779e6093e3fae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Feb 2004 23:24:53 +0000 Subject: [PATCH] . original commit: 5a8d8a19c2846c95338cd979f3e2db27b338afe2 --- collects/mzlib/cm-accomplice.ss | 4 +- collects/mzlib/cm.ss | 79 +++++++++++---------- collects/mzlib/cmdline.ss | 22 +++--- collects/mzlib/file.ss | 4 +- collects/mzlib/include.ss | 4 +- collects/mzlib/process.ss | 5 +- collects/mzlib/string.ss | 118 ++++++++++++++++++++++---------- collects/mzlib/thread.ss | 46 ++++++------- collects/mzlib/traceld.ss | 2 +- 9 files changed, 170 insertions(+), 114 deletions(-) diff --git a/collects/mzlib/cm-accomplice.ss b/collects/mzlib/cm-accomplice.ss index 2320062..14457f0 100644 --- a/collects/mzlib/cm-accomplice.ss +++ b/collects/mzlib/cm-accomplice.ss @@ -2,9 +2,9 @@ (provide register-external-file) (define (register-external-file f) - (unless (and (string? f) + (unless (and (path? f) (complete-path? f)) - (raise-type-error 'register-external-file "complete-path string" f)) + (raise-type-error 'register-external-file "complete path" f)) (let ([param (lambda () void)]) ;; Load the code in a separate thread, so that the dynamic ;; extent of this one (likely a pase-sensitive macro expansion) diff --git a/collects/mzlib/cm.ss b/collects/mzlib/cm.ss index 241b491..e3c37a0 100644 --- a/collects/mzlib/cm.ss +++ b/collects/mzlib/cm.ss @@ -19,18 +19,19 @@ (define (get-deps code path) (let-values ([(imports fs-imports) (module-compiled-imports code)]) - (map (lambda (x) - (resolve-module-path-index x path)) - ;; Filter symbols: - (let loop ([l (append imports fs-imports)]) - (cond - [(null? l) null] - [(symbol? (car l)) (loop (cdr l))] - [else (cons (car l) (loop (cdr l)))]))))) + (map path->bytes + (map (lambda (x) + (resolve-module-path-index x path)) + ;; Filter symbols: + (let loop ([l (append imports fs-imports)]) + (cond + [(null? l) null] + [(symbol? (car l)) (loop (cdr l))] + [else (cons (car l) (loop (cdr l)))])))))) (define (get-compilation-dir+name path) (let-values (((base name-suffix must-be-dir?) (split-path path))) - (let ((name (regexp-replace #rx"\\..?.?.?$" name-suffix ""))) + (let ((name (path-replace-suffix name-suffix #""))) (values (cond ((eq? 'relative base) (build-path "compiled")) @@ -39,7 +40,7 @@ (define (get-compilation-path path) (let-values ([(dir name) (get-compilation-dir+name path)]) - (build-path dir name))) + (path->bytes (build-path dir name)))) (define (get-code-dir path) (let-values (((base name-suffix must-be-dir?) (split-path path))) @@ -48,7 +49,8 @@ (else (build-path base "compiled"))))) (define (write-deps code path external-deps) - (let ((dep-path (string-append (get-compilation-path path) ".dep")) + (let ((dep-path (bytes->path + (bytes-append (get-compilation-path path) #".dep"))) (deps (get-deps code path))) (let ((op (open-output-file dep-path 'replace))) (write (cons (version) @@ -65,14 +67,15 @@ (define (compilation-failure path zo-name date-path) (with-handlers ((not-break-exn? void)) (delete-file zo-name)) - (let ([fail-path (string-append (get-compilation-path path) ".fail")]) + (let ([fail-path (bytes->path + (bytes-append (get-compilation-path path) #".fail"))]) (close-output-port (open-output-file fail-path 'truncate/replace))) ((trace) (format "~afailure" (indent)))) (define (compile-zo path) - ((trace) (format "~acompiling: ~a" (indent) path)) + ((trace) (format "~acompiling: ~a" (indent) (path->bytes path))) (parameterize ([indent (string-append " " (indent))]) - (let ([zo-name (string-append (get-compilation-path path) ".zo")]) + (let ([zo-name (bytes->path (bytes-append (get-compilation-path path) #".zo"))]) (cond [(and (file-exists? zo-name) (trust-existing-zos)) (touch zo-name)] [else @@ -89,7 +92,7 @@ [external-deps null] [code (parameterize ([param (lambda (ext-file) (set! external-deps - (cons ext-file + (cons (path->bytes ext-file) external-deps)))]) (get-module-code path))] [code-dir (get-code-dir path)]) @@ -107,15 +110,15 @@ (when (< zo-sec ss-sec) (error 'compile-zo "date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a" - zo-name + (path->bytes zo-name) (format-date (seconds->date zo-sec)) - path + (path->bytes path) (format-date (seconds->date ss-sec)) (if (> ss-sec (current-seconds)) ", which appears to be in the future" "")))) (write-deps code path external-deps)))]))) - ((trace) (format "~aend compile: ~a" (indent) path))) + ((trace) (format "~aend compile: ~a" (indent) (path->bytes path)))) (define (format-date date) (format "~a:~a:~a:~a:~a:~a" @@ -127,17 +130,19 @@ (date-second date))) (define (append-object-suffix f) - (string-append f (case (system-type) - [(windows) ".dll"] - [else ".so"]))) + (path-replace-suffix f (case (system-type) + [(windows) #".dll"] + [else #".so"]))) + + (define _loader-path (append-object-suffix (bytes->path #"_loader"))) (define (get-compiled-time path w/fail?) - (let-values ([(dir name) (get-compilation-dir+name path)]) + (let*-values ([(dir name) (get-compilation-dir+name path)]) (first-date - (lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix "_loader"))) + (lambda () (build-path dir "native" (system-library-subpath) _loader-path)) (lambda () (build-path dir "native" (system-library-subpath) (append-object-suffix name))) - (lambda () (build-path dir (string-append name ".zo"))) - (and w/fail? (lambda () (build-path dir (string-append name ".zo" ".fail"))))))) + (lambda () (build-path dir (path-replace-suffix name #".zo"))) + (and w/fail? (lambda () (build-path dir (path-replace-suffix name #".zo" #".fail"))))))) (define first-date (case-lambda @@ -157,12 +162,12 @@ (cond (stamp stamp) (else - ((trace) (format "~achecking: ~a" (indent) path)) + ((trace) (format "~achecking: ~a" (indent) (path->bytes path))) (let ((path-zo-time (get-compiled-time path #f)) (path-time (with-handlers ((exn:i/o:filesystem? (lambda (ex) - ((trace) (format "~a~a does not exist" (indent) path)) + ((trace) (format "~a~a does not exist" (indent) (path->bytes path))) #f))) (file-or-directory-modify-seconds path)))) (cond @@ -174,7 +179,8 @@ (compile-zo path)) (else (let ((deps (with-handlers ((exn:i/o:filesystem? (lambda (ex) (list (version))))) - (call-with-input-file (string-append (get-compilation-path path) ".dep") + (call-with-input-file (bytes->path + (bytes-append (get-compilation-path path) #".dep")) read)))) (cond ((or (not (pair? deps)) @@ -185,7 +191,8 @@ ;; str => str is a module file name (check transitive dates) ;; (cons 'ext str) => str is an non-module file (check date) (let ([t (cond - [(string? d) (compile-root d up-to-date)] + [(bytes? d) (compile-root (bytes->path d) up-to-date)] + [(path? d) (compile-root d up-to-date)] [(and (pair? d) (eq? (car d) 'ext)) (with-handlers ((exn:i/o:filesystem? (lambda (ex) +inf.0))) @@ -221,29 +228,29 @@ (lambda (path mod-name) (cond [(not mod-name) - ((trace) (format "~askipping: ~a mod-name ~s" (indent) path mod-name)) + ((trace) (format "~askipping: ~a mod-name ~s" (indent) (path->bytes path) mod-name)) (default-handler path mod-name)] [(eq? 'none (use-compiled-file-kinds)) - ((trace) (format "~askipping: ~a file-kinds ~s" (indent) path (use-compiled-file-kinds))) + ((trace) (format "~askipping: ~a file-kinds ~s" (indent) (path->bytes path) (use-compiled-file-kinds))) (default-handler path mod-name)] [(not (eq? compilation-manager-load-handler (current-load/use-compiled))) ((trace) (format "~askipping: ~a current-load/use-compiled changed ~s" - (indent) path (current-load/use-compiled))) + (indent) (path->bytes path) (current-load/use-compiled))) (default-handler path mod-name)] [(not (eq? orig-eval (current-eval))) ((trace) (format "~askipping: ~a orig-eval ~s current-eval ~s" - (indent) path orig-eval (current-eval))) + (indent) (path->bytes path) orig-eval (current-eval))) (default-handler path mod-name)] [(not (eq? orig-load (current-load))) ((trace) (format "~askipping: ~a orig-load ~s current-load ~s" - (indent) path orig-load (current-load))) + (indent) (path->bytes path) orig-load (current-load))) (default-handler path mod-name)] [(not (eq? orig-namespace (current-namespace))) ((trace) (format "~askipping: ~a orig-namespace ~s current-namespace ~s" - (indent) path orig-namespace (current-namespace))) + (indent) (path->bytes path) orig-namespace (current-namespace))) (default-handler path mod-name)] [else - ((trace) (format "~aprocessing: ~a" (indent) path)) + ((trace) (format "~aprocessing: ~a" (indent) (path->bytes path))) (compile-root path cache) (default-handler path mod-name)]))]) compilation-manager-load-handler)))) diff --git a/collects/mzlib/cmdline.ss b/collects/mzlib/cmdline.ss index 8f54a43..3e86f2a 100644 --- a/collects/mzlib/cmdline.ss +++ b/collects/mzlib/cmdline.ss @@ -212,13 +212,13 @@ [(program arguments table finish finish-help help) (parse-command-line program arguments table finish finish-help help (lambda (flag) - (error (string->symbol program) "unknown flag: ~s" flag)))] + (error (string->symbol (bytes->string/locale program #\?)) "unknown flag: ~s" flag)))] [(program arguments table finish finish-help help unknown-flag) - (unless (string? program) - (raise-type-error 'parse-command-line "program name string" program)) + (unless (or (string? program) (bytes? program)) + (raise-type-error 'parse-command-line "program name string or byte string" program)) (unless (and (vector? arguments) - (andmap string? (vector->list arguments))) - (raise-type-error 'parse-command-line "argument vector of strings" arguments)) + (andmap bytes? (vector->list arguments))) + (raise-type-error 'parse-command-line "argument vector of byte strings" arguments)) (unless (and (list? table) (let ([bad-table (lambda (reason) @@ -405,7 +405,7 @@ [c (length args)]) (if (procedure-arity-includes? finish (add1 c)) (apply finish options args) - (error (string->symbol program) + (error (string->symbol (format "~a" program)) (format "expects~a on the command line, given ~a argument~a~a" (if (null? finish-help) " no arguments" @@ -424,7 +424,9 @@ (let loop ([args args]) (if (null? args) "" - (string-append (car args) " " (loop (cdr args))))))))))] + (string-append (bytes->string/locale (car args) #\?) + " " + (loop (cdr args))))))))))] [call-handler (lambda (handler flag args r-acc k) (let* ([a (procedure-arity handler)] @@ -436,7 +438,7 @@ (sub1 a) remaining)]) (if (< remaining needed) - (error (string->symbol program) + (error (string->symbol (format "~a" program)) "the ~s flag needs ~a argument~a, but ~a~a provided" flag needed (if (> needed 1) "s" "") (if (zero? remaining) "" "only ") @@ -465,7 +467,7 @@ (let ([set (caar table)]) (if (car set) (let ([flags (cdr set)]) - (error (string->symbol program) + (error (string->symbol (format "~a" program)) (let ([s (if (= 1 (length flags)) (format "the ~a flag can only be specified once" (car flags)) (format "only one instance of one flag from ~a is allowed" flags))]) @@ -485,7 +487,7 @@ (set-car! set #t)))) (call-handler (caddar table) flag args r-acc k)] [else (loop (cdr table))])))]) - (let loop ([args (vector->list arguments)][r-acc null]) + (let loop ([args (map (lambda (s) (bytes->string/locale s #\?)) (vector->list arguments))][r-acc null]) (if (null? args) (done args r-acc) (let ([arg (car args)] diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss index cbb3957..7c4dc7a 100644 --- a/collects/mzlib/file.ss +++ b/collects/mzlib/file.ss @@ -172,7 +172,7 @@ (define file-name-from-path (lambda (name) (let-values ([(base file dir?) (split-path name)]) - (if (and (not dir?) (string? file)) + (if (and (not dir?) (path? file)) file #f)))) @@ -181,7 +181,7 @@ (let-values ([(base file dir?) (split-path name)]) (cond [dir? name] - [(string? base) base] + [(path? base) base] [else #f])))) ;; name can be any string; we just look for a dot diff --git a/collects/mzlib/include.ss b/collects/mzlib/include.ss index 70414a5..c88ea15 100644 --- a/collects/mzlib/include.ss +++ b/collects/mzlib/include.ss @@ -111,7 +111,7 @@ [(build-path elem1 elem ...) (andmap (lambda (e) - (or (string? (syntax-e e)) + (or (path-string? (syntax-e e)) (and (identifier? e) (or (module-identifier=? e (quote-syntax up)) @@ -121,7 +121,7 @@ [(lib filename ...) (andmap (lambda (e) - (string? (syntax-e e))) + (path-string? (syntax-e e))) (syntax->list (syntax (filename ...)))) 'ok] [_else (raise-syntax-error #f "bad syntax" stx fn)])) diff --git a/collects/mzlib/process.ss b/collects/mzlib/process.ss index a2be257..b0e3b30 100644 --- a/collects/mzlib/process.ss +++ b/collects/mzlib/process.ss @@ -15,7 +15,7 @@ (define (shell-path/args who argstr) (case (system-type) - ((unix macosx) (append '("/bin/sh" "-c") (list argstr))) + ((unix macosx) (append '(#"/bin/sh" #"-c") (list argstr))) ((windows) (let ([cmd (let ([d (find-system-path 'sys-dir)]) (let ([cmd (build-path d "cmd.exe")]) @@ -28,7 +28,8 @@ (build-path d 'up "command.com"))))))]) (list cmd 'exact - (format "~a /c ~a" cmd argstr)))) + (string->bytes/utf-8 + (format "~a /c ~a" cmd argstr))))) (else (raise-mismatch-error who (format "~a: don't know what shell to use for platform: " who) diff --git a/collects/mzlib/string.ss b/collects/mzlib/string.ss index 516feae..e543b79 100644 --- a/collects/mzlib/string.ss +++ b/collects/mzlib/string.ss @@ -106,12 +106,31 @@ (let ([port (open-output-string)]) (write v port) (get-output-string port)))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Regexp helpers + + (define (bstring-length s) + (if (string? s) + (string-length s) + (bytes-length s))) + + (define (subbstring s st e) + (if (string? s) + (substring s st e) + (subbytes s st e))) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Regexp helpers (define regexp-quote (opt-lambda (s [case-sens? #t]) - (unless (string? s) - (raise-type-error 'regexp-quote "string" s)) - (list->string + (unless (or (string? s) + (bytes? s)) + (raise-type-error 'regexp-quote "string or byte string" s)) + ((if (bytes? s) + (lambda (l) (list->bytes (map char->integer l))) + list->string) (apply append (map @@ -119,16 +138,21 @@ (cond [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^)) (list #\\ c)] - [(and (char-alphabetic? c) - (not case-sens?)) + [(and (not case-sens?) + (not (char=? (char-upcase c) (char-downcase c)))) (list #\[ (char-upcase c) (char-downcase c) #\])] [else (list c)])) - (string->list s)))))) + (if (bytes? s) + (map integer->char (bytes->list s)) + (string->list s))))))) (define (regexp-replace-quote s) - (unless (string? s) - (raise-type-error 'regexp-replace-quote "string" s)) - (regexp-replace* "&" (regexp-replace* "\\\\" s "\\\\\\\\") "\\\\&")) + (unless (or (string? s) + (bytes? s)) + (raise-type-error 'regexp-replace-quote "string or byte string" s)) + (if (bytes? s) + (regexp-replace* #rx"&" (regexp-replace* #rx"\\\\" s "\\\\\\\\") "\\\\&") + (regexp-replace* #rx#"&" (regexp-replace* #rx#"\\\\" s #"\\\\\\\\") #"\\\\&"))) (define regexp-match/fail-without-reading (opt-lambda (pattern input-port [start-k 0] [end-k #f] [out #f]) @@ -138,74 +162,87 @@ (raise-type-error 'regexp-match/fail-without-reading "output port or #f" out)) (let ([m (regexp-match-peek-positions pattern input-port start-k end-k)]) (and m - ;; What happens if someone swipes our chars before we can get them? + ;; What happens if someone swipes our bytes before we can get them? (let ([drop (caar m)]) ;; drop prefix before match: - (let ([s (read-string drop input-port)]) + (let ([s (read-bytes drop input-port)]) (when out (display s out))) ;; Get the matching part, and shift matching indicies - (let ([s (read-string (- (cdar m) drop) input-port)]) + (let ([s (read-bytes (- (cdar m) drop) input-port)]) (cons s (map (lambda (p) - (and p (substring s (- (car p) drop) (- (cdr p) drop)))) + (and p (subbytes s (- (car p) drop) (- (cdr p) drop)))) (cdr m))))))))) ;; Helper function for the regexp functions below. (define (regexp-fn name success-k port-success-k failure-k port-failure-k need-leftover? peek?) (lambda (pattern string start end) - - (unless (or (string? pattern) (regexp? pattern)) - (raise-type-error name "regexp or string" pattern)) + (unless (or (string? pattern) (bytes? pattern) + (regexp? pattern) (byte-regexp? pattern)) + (raise-type-error name "regexp, byte regexp, string, or byte string" pattern)) (if peek? (unless (input-port? string) - (raise-type-error name "input-port" string)) - (unless (or (string? string) (input-port? string)) - (raise-type-error name "string or input-port" string))) + (raise-type-error name "input port" string)) + (unless (or (string? string) + (bytes? string) + (input-port? string)) + (raise-type-error name "string, byte string or input port" string))) (unless (and (number? start) (exact? start) (integer? start) (start . >= . 0)) (raise-type-error name "non-negative exact integer" start)) (unless (or (not end) (and (number? end) (exact? end) (integer? end) (end . >= . 0))) (raise-type-error name "non-negative exact integer or false" end)) (unless (or (input-port? string) - (start . <= . (string-length string))) + (and (string? string) + (start . <= . (string-length string))) + (and (bytes? string) + (start . <= . (bytes-length string)))) (raise-mismatch-error name (format "starting offset index out of range [0,~a]: " - (string-length string)) + (if (string? string) + (string-length string) + (bytes-length string))) start)) (unless (or (not end) (and (start . <= . end) (or (input-port? string) - (end . <= . (string-length string))))) + (and (string? string) + (end . <= . (string-length string))) + (and (bytes? string) + (end . <= . (bytes-length string)))))) (raise-mismatch-error name (format "ending offset index out of range [~a,~a]: " end - (string-length string)) + (if (string? string) + (string-length string) + (bytes-length string))) start)) (when (and (positive? start) (input-port? string) need-leftover?) ;; Skip start chars: - (let ([s (make-string 4096)]) + (let ([s (make-bytes 4096)]) (let loop ([n 0]) (unless (= n start) - (let ([m (read-string-avail! s string 0 (min (- start n) 4096))]) + (let ([m (read-bytes-avail! s string 0 (min (- start n) 4096))]) (unless (eof-object? m) (loop (+ n m)))))))) - (let ((expr (if (regexp? pattern) - pattern - (regexp pattern)))) + (let ((expr (cond + [(string? pattern) (regexp pattern)] + [(bytes? pattern) (byte-regexp pattern)] + [else pattern]))) (if (and (input-port? string) port-success-k) ;; Input port match, get string (let ([discarded 0] [leftover-port (and need-leftover? - (open-output-string))]) + (open-output-bytes))]) (let ([match (regexp-match expr string (if need-leftover? 0 start) (and end (if need-leftover? (- end start) end)) @@ -220,14 +257,17 @@ void void)))] [leftovers (and need-leftover? - (get-output-string leftover-port))]) + (if (and (regexp? pattern) + (string? string)) + (get-output-string leftover-port) + (get-output-bytes leftover-port)))]) (if match (port-success-k expr string (car match) (and end (- end (if need-leftover? - (+ (string-length leftovers) start) + (+ (bstring-length leftovers) start) discarded) - (string-length (car match)))) + (bstring-length (car match)))) leftovers) (port-failure-k leftovers)))) ;; String/port match, get positions @@ -299,7 +339,7 @@ ;; success-k (lambda (expr string start end match-start match-end) (cons - (substring string start match-start) + (subbstring string start match-start) (regexp-split expr string match-end end))) ;; port-success-k: (lambda (expr string match-string new-end leftovers) @@ -309,7 +349,7 @@ ;; failure-k: (lambda (expr string start end) (list - (substring string start (or end (string-length string))))) + (subbstring string start (or end (bstring-length string))))) ;; port-fail-k (lambda (leftover) (list leftover)) @@ -323,7 +363,7 @@ ;; success-k: (lambda (expr string start end match-start match-end) (cons - (substring string match-start match-end) + (subbstring string match-start match-end) (regexp-match* expr string match-end end))) ;; port-success-k: (lambda (expr string match-string new-end leftovers) @@ -345,4 +385,10 @@ (let ([m (regexp-match-positions p s)]) (and m (zero? (caar m)) - (= (string-length s) (cdar m))))))) + (if (or (byte-regexp? p) + (bytes? p) + (bytes? s)) + (= (cdar m) (if (bytes? s) + (bytes-length s) + (string-utf-8-length s))) + (= (cdar m) (string-length s)))))))) diff --git a/collects/mzlib/thread.ss b/collects/mzlib/thread.ss index b9a5286..37e39e5 100644 --- a/collects/mzlib/thread.ss +++ b/collects/mzlib/thread.ss @@ -108,15 +108,15 @@ (unless (output-port? dest) (raise-type-error 'copy-port "output-port" dest))) (cons dest dests)) - (let ([s (make-string 4096)]) + (let ([s (make-bytes 4096)]) (let loop () - (let ([c (read-string-avail! s src)]) + (let ([c (read-bytes-avail! s src)]) (unless (eof-object? c) (for-each (lambda (dest) (let loop ([start 0]) (unless (= start c) - (let ([c2 (write-string-avail s dest start c)]) + (let ([c2 (write-bytes-avail s dest start c)]) (loop (+ start c2)))))) (cons dest dests)) (loop)))))) @@ -200,7 +200,7 @@ ;; and get rid of it if the result is eof (if (null? ports) eof - (let ([n (read-string-avail!* str (car ports))]) + (let ([n (read-bytes-avail!* str (car ports))]) (cond [(eq? n 0) (car ports)] [(eof-object? n) @@ -214,7 +214,7 @@ (let loop ([ports ports][skip skip]) (if (null? ports) eof - (let ([n (peek-string-avail!* str skip (car ports))]) + (let ([n (peek-bytes-avail!* str skip (car ports))]) (cond [(eq? n 0) ;; Not ready, yet. @@ -232,9 +232,9 @@ (define (convert-stream from from-port to to-port) - (let ([c (string-open-converter from to)] - [in (make-string 4096)] - [out (make-string 4096)]) + (let ([c (bytes-open-converter from to)] + [in (make-bytes 4096)] + [out (make-bytes 4096)]) (unless c (error 'convert-stream "could not create converter from ~e to ~e" from to)) @@ -242,41 +242,41 @@ void (lambda () (let loop ([got 0]) - (let ([n (read-string-avail! in from-port got)]) + (let ([n (read-bytes-avail! in from-port got)]) (let ([got (+ got (if (eof-object? n) 0 n))]) - (let-values ([(wrote used ok?) (string-convert c in 0 got out)]) - (unless ok? + (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) + (when (eq? status 'error) (error 'convert-stream "conversion error")) (unless (zero? wrote) - (write-string out to-port 0 wrote)) - (string-copy! in used in 0 got) + (write-bytes out to-port 0 wrote)) + (bytes-copy! in used in 0 got) (if (eof-object? n) (begin (unless (= got used) (error 'convert-stream "input stream ended with a partial conversion")) - (let-values ([(wrote ok?) (string-convert-end c out)]) - (unless ok? + (let-values ([(wrote status) (bytes-convert-end c out)]) + (when (eq? status 'error) (error 'convert-stream "conversion-end error")) (unless (zero? wrote) - (write-string out to-port 0 wrote)) + (write-bytes out to-port 0 wrote)) ;; Success (void))) (loop (- got used)))))))) - (lambda () (string-close-converter c))))) + (lambda () (bytes-close-converter c))))) ;; Helper for input-port-append; given a skip count ;; and an input port, determine how many characters ;; (up to upto) are left in the port. We figure this ;; out using binary search. (define (compute-avail-to-skip upto p) - (let ([str (make-string 1)]) + (let ([str (make-bytes 1)]) (let loop ([upto upto][skip 0]) (if (zero? upto) skip (let* ([half (quotient upto 2)] - [n (peek-string-avail!* str (+ skip half) p)]) + [n (peek-bytes-avail!* str (+ skip half) p)]) (if (eq? n 1) (loop (- upto half 1) (+ skip half 1)) (loop half skip))))))) @@ -286,19 +286,19 @@ (let ([got 0]) (make-custom-input-port (lambda (str) - (let ([count (min (- limit got) (string-length str))]) + (let ([count (min (- limit got) (bytes-length str))]) (if (zero? count) eof - (let ([n (read-string-avail!* str port 0 count)]) + (let ([n (read-bytes-avail!* str port 0 count)]) (cond [(eq? n 0) port] [(number? n) (set! got (+ got n)) n] [else n]))))) (lambda (str skip) - (let ([count (max 0 (min (- limit got skip) (string-length str)))]) + (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) (if (zero? count) eof - (let ([n (peek-string-avail!* str skip port 0 count)]) + (let ([n (peek-bytes-avail!* str skip port 0 count)]) (if (eq? n 0) port n))))) diff --git a/collects/mzlib/traceld.ss b/collects/mzlib/traceld.ss index 23065b9..bcb9263 100644 --- a/collects/mzlib/traceld.ss +++ b/collects/mzlib/traceld.ss @@ -16,7 +16,7 @@ (dynamic-wind (lambda () (set! tab (string-append " " tab))) (lambda () - (if (regexp-match "_loader" filename) + (if (regexp-match #rx#"_loader" (path->bytes filename)) (let ([f (load filename #f)]) (lambda (sym) (fprintf ep