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

5
collects/mzlib/port.ss
View File

@ -1319,9 +1319,10 @@
(- c out-len)))))])]
[else
(when (or (> ready-end ready-start)
(< (- (bytes-length out-bytes) out-end) 100))
(< (- (bytes-length out-bytes) out-end) 100))
;; 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
(when (positive? out-start)
(bytes-copy! out-bytes 0 out-bytes out-start out-end)

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

@ -441,23 +441,21 @@
(define (do-read-symbol-or-number num? prefix port src line col pos)
;; Read a delimited sequence (using an extended notion of delimiter),
;; then make sure it's a number or identifier.
(let ([thing (bytes-append
(string->bytes/utf-8 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]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port))
'(#""))))])
(let ([thing (string-append
prefix
(bytes->string/utf-8
(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]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port))
'(#"")))))])
(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:
(string->symbol (bytes->string/utf-8 thing))]
(string->symbol thing)]
[(regexp-match? rx:number thing)
(let ([n (string->number
(bytes->string/utf-8
;; MzScheme doesn't handle mantissa widths, yet, so strip them out:
(regexp-replace* #rx#"[|][0-9]+"
thing
#"")))])
;; MzScheme doesn't handle mantissa widths, yet, so strip them out:
(regexp-replace* #rx"[|][0-9]+" thing ""))])
(unless n
(error 'r6rs-parser "number didn't convert: ~e" thing))
n)]
@ -465,7 +463,7 @@
(regexp-match? rx:id thing))
(string->symbol
(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)])
(if m
(loop (bytes-append
@ -483,10 +481,9 @@
(loop (cadddr m))))
t)))))]
[else
(let ([str (bytes->string/utf-8 thing)])
(raise-read-error
(format "not a number or identifier: `~a'" str)
src line col pos (and pos (string-length str))))])))
(raise-read-error
(format "not a number or identifier: `~a'" thing)
src line col pos (and pos (string-length thing)))])))
(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!
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)
(let ([p (if (binary-input-port? p)
((binary-input-port-disconnect p))
p)])
(if (eq? t utf8-transcoder)
(if (no-op-transcoder? t)
p
(reencode-input-port p
(codec-enc (transcoder-codec t))
@ -645,9 +651,9 @@
'must-update]
[(enum-set=? options (file-options no-fail no-truncate))
'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]
[(enum-set-member? options 'no-fail) ; no-fail
[(enum-set-member? 'no-fail options) ; no-fail
'truncate]
[else ; no-truncate, <empty>
'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))))