suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

minor r6rs work

Browse Source 
svn: r8817
This commit is contained in:
Matthew Flatt 2008-02-27 14:53:41 +00:00
parent eff876671d
commit c9a326111d
5 changed files with 38 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/port.ss
View File

@ -1321,7 +1321,8 @@
(when (or (> ready-end ready-start) (when (or (> ready-end ready-start)
(< (- (bytes-length out-bytes) out-end) 100)) (< (- (bytes-length out-bytes) out-end) 100))
;; Make room for conversion. ;; Make room for conversion.
(flush-some #f enable-break?)) (flush-some #f enable-break?) ;; convert some
(flush-some #f enable-break?)) ;; write converted
;; Make room in buffer ;; Make room in buffer
(when (positive? out-start) (when (positive? out-start)
(bytes-copy! out-bytes 0 out-bytes out-start out-end) (bytes-copy! out-bytes 0 out-bytes out-start out-end)

23
collects/r6rs/private/readtable.ss
View File

@ -441,23 +441,21 @@
(define (do-read-symbol-or-number num? prefix port src line col pos) (define (do-read-symbol-or-number num? prefix port src line col pos)
;; Read a delimited sequence (using an extended notion of delimiter), ;; Read a delimited sequence (using an extended notion of delimiter),
;; then make sure it's a number or identifier. ;; then make sure it's a number or identifier.
(let ([thing (bytes-append (let ([thing (string-append
(string->bytes/utf-8 prefix) prefix
(bytes->string/utf-8
(car (or (if (string=? prefix "\\") (car (or (if (string=? prefix "\\")
(regexp-match #px"^x[0-9a-fA-F]+;(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port) (regexp-match #px"^x[0-9a-fA-F]+;(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port)
(regexp-match #px"^(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port)) (regexp-match #px"^(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port))
'(#""))))]) '(#"")))))])
(cond (cond
[(regexp-match? #rx#"^[a-zA-Z!$%&*/:<=>?^_~][a-zA-Z0-9+!$%&*/:<=>?^_~.@-]*$" thing) [(regexp-match? #rx"^[a-zA-Z!$%&*/:<=>?^_~][a-zA-Z0-9+!$%&*/:<=>?^_~.@-]*$" thing)
;; Simple symbol: ;; Simple symbol:
(string->symbol (bytes->string/utf-8 thing))] (string->symbol thing)]
[(regexp-match? rx:number thing) [(regexp-match? rx:number thing)
(let ([n (string->number (let ([n (string->number
(bytes->string/utf-8
;; MzScheme doesn't handle mantissa widths, yet, so strip them out: ;; MzScheme doesn't handle mantissa widths, yet, so strip them out:
(regexp-replace* #rx#"[|][0-9]+" (regexp-replace* #rx"[|][0-9]+" thing ""))])
thing
#"")))])
(unless n (unless n
(error 'r6rs-parser "number didn't convert: ~e" thing)) (error 'r6rs-parser "number didn't convert: ~e" thing))
n)] n)]
@ -465,7 +463,7 @@
(regexp-match? rx:id thing)) (regexp-match? rx:id thing))
(string->symbol (string->symbol
(bytes->string/utf-8 (bytes->string/utf-8
(let loop ([t thing]) (let loop ([t (string->bytes/utf-8 thing)])
(let ([m (regexp-match #rx#"^(.*)\\\\x([0-9a-fA-F]+);(.*)$" t)]) (let ([m (regexp-match #rx#"^(.*)\\\\x([0-9a-fA-F]+);(.*)$" t)])
(if m (if m
(loop (bytes-append (loop (bytes-append
@ -483,10 +481,9 @@
(loop (cadddr m)))) (loop (cadddr m))))
t)))))] t)))))]
[else [else
(let ([str (bytes->string/utf-8 thing)])
(raise-read-error (raise-read-error
(format "not a number or identifier: `~a'" str) (format "not a number or identifier: `~a'" thing)
src line col pos (and pos (string-length str))))]))) src line col pos (and pos (string-length thing)))])))
(define (read-symbol-or-number ch port src line col pos) (define (read-symbol-or-number ch port src line col pos)

4
collects/rnrs/files-6.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme/base
(provide file-exists?
delete-file)

12
collects/rnrs/io/ports-6.ss
View File

@ -300,11 +300,17 @@
(make-binary-input/output-port p disconnect get-pos set-pos! (make-binary-input/output-port p disconnect get-pos set-pos!
out-p out-disconnect))) out-p out-disconnect)))
(define (no-op-transcoder? t)
(or (eq? t utf8-transcoder)
(and (eq? utf-8 (transcoder-codec t))
(memq (transcoder-eol-style t) '(lf none))
(eq? 'replace (transcoder-error-handling-mode t)))))
(define (transcode-input p t) (define (transcode-input p t)
(let ([p (if (binary-input-port? p) (let ([p (if (binary-input-port? p)
((binary-input-port-disconnect p)) ((binary-input-port-disconnect p))
p)]) p)])
(if (eq? t utf8-transcoder) (if (no-op-transcoder? t)
p p
(reencode-input-port p (reencode-input-port p
(codec-enc (transcoder-codec t)) (codec-enc (transcoder-codec t))
@ -645,9 +651,9 @@
'must-update] 'must-update]
[(enum-set=? options (file-options no-fail no-truncate)) [(enum-set=? options (file-options no-fail no-truncate))
'update] 'update]
[(enum-set-member? 'no-create) ; no-create, no-create + no-fail [(enum-set-member? 'no-create options) ; no-create, no-create + no-fail
'must-truncate] 'must-truncate]
[(enum-set-member? options 'no-fail) ; no-fail [(enum-set-member? 'no-fail options) ; no-fail
'truncate] 'truncate]
[else ; no-truncate, <empty> [else ; no-truncate, <empty>
'error]))]) 'error]))])

7
collects/rnrs/programs-6.ss Normal file
View File

@ -0,0 +1,7 @@
#lang scheme/base
(provide command-line exit)
(define (command-line)
(cons (path->string (find-system-path 'run-file))
(vector->list (current-command-line-arguments))))