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

r6rs io

Browse Source 
svn: r8807
This commit is contained in:
Matthew Flatt 2008-02-26 22:15:02 +00:00
parent 54ed23be3b
commit 5a646bfe18
14 changed files with 704 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -277,6 +277,10 @@
col pos
(and pos (+ 1 len)))))]
[(or (eq? char #\tab)
;(eq? char #\newline)
;(eq? char #\return)
;(eq? char #\u85)
;(eqv? char #\u2028)
(eq? (char-general-category char) 'zs))
(let ([wm (regexp-match-positions #px"^(?:\t|\\p{Zs})*(?:\r\n|\r\u85|[\r\n\u85\u2028])(?:\t|\\p{Zs})*"
bytes
@ -285,7 +289,7 @@
(cons (subbytes bytes bpos (caar m)) ; drop matched part
(loop (cdar wm)))
;; This is an eof error if there's only intraline whitespace
((if (regexp-match #px"^(?:\t|\\p{Zs})*$" bytes (+ 1 bpos))
((if (regexp-match? #px"^(?:\t|\\p{Zs})*$" bytes (+ 1 bpos))
raise-read-eof-error
raise-read-error)
"missing <line ending> after `\\<intraline-whitespace>'"
@ -348,7 +352,7 @@
(map
(lambda (s)
(format "|\\p{~a}" s))
'(Lu Lt Lm Lo Mn Nl No Pd Pc Po Sc Sm Sk So Co)))
'(Ll Lu Lt Lm Lo Mn Nl No Pd Pc Po Sc Sm Sk So Co)))
1)
"))")))
(define special-initial "[!$%&*/:<=>?^_~]")
@ -444,10 +448,13 @@
(regexp-match #px"^(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port))
'(#""))))])
(cond
[(regexp-match rx:number thing)
[(regexp-match? #rx#"^[a-zA-Z!$%&*/:<=>?^_~][a-zA-Z0-9+!$%&*/:<=>?^_~.@-]*$" thing)
;; Simple symbol:
(string->symbol (bytes->string/utf-8 thing))]
[(regexp-match? rx:number thing)
(let ([n (string->number
(bytes->string/utf-8
;; MzScheme doesn't hanel mantissa widths, so strip them out:
;; MzScheme doesn't handle mantissa widths, yet, so strip them out:
(regexp-replace* #rx#"[|][0-9]+"
thing
#"")))])
@ -455,7 +462,7 @@
(error 'r6rs-parser "number didn't convert: ~e" thing))
n)]
[(and (not num?)
(regexp-match rx:id thing))
(regexp-match? rx:id thing))
(string->symbol
(bytes->string/utf-8
(let loop ([t thing])

1
collects/r6rs/private/records-core.ss
View File

@ -41,7 +41,6 @@
record? record-rtd)
(import (rnrs base (6))
(rnrs lists (6))
(rnrs io simple (6)) ;; REMOVEME
(r6rs private vector-types))
(define make-field-spec cons)

1
collects/rnrs/arithmetic/info.ss Normal file
View File

@ -0,0 +1 @@
#lang setup/infotab

59
collects/rnrs/base-6.ss
View File

@ -11,7 +11,7 @@
(provide
;; 11.2
(rename-out [r5rs:define define]
(rename-out [r6rs:define define]
[r6rs:define-syntax define-syntax])
;; 11.4.1
@ -128,6 +128,7 @@
;; 11.11
char? char=? char<? char>? char<=? char>=?
integer->char char->integer
;; 11.12
string?
@ -153,8 +154,9 @@
assertion-violation assert
;; 11.15
(rename-out [r5rs:apply apply])
call-with-current-continuation call/cc
(rename-out [r5rs:apply apply]
[r6rs:call/cc call-with-current-continuation]
[r6rs:call/cc call/cc])
values call-with-values
dynamic-wind
@ -306,7 +308,7 @@
(define-syntax-rule (assert expr)
(unless expr
(assrtion-violation #f "assertion failed")))
(assertion-violation #f "assertion failed")))
;; ----------------------------------------
;; quasiquote generalization
@ -314,6 +316,16 @@
(define-generalized-qq r6rs:quasiquote
quasiquote unquote unquote-splicing)
;; ----------------------------------------
;; define
(define-syntax (r6rs:define stx)
(syntax-case stx ()
[(_ id)
(identifier? #'id)
#'(define id (void))]
[(_ . rest) #'(r5rs:define . rest)]))
;; ----------------------------------------
;; define-syntax: wrap a transformer to
;; ensure that the result of an expansion is
@ -358,3 +370,42 @@
(procedure-arity v))
v))
;; ----------------------------------------
(define detect-tail-key (gensym))
(define (mk-k full-k tag)
(lambda args
(if (continuation-prompt-available? tag)
(abort-current-continuation
tag
(lambda () (apply values args)))
(apply full-k args))))
(define (r6rs:call/cc f)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
;; let call/cc report the error:
(call/cc f))
;; To support call/cc-based jumps in exception
;; handlers, we both grab a continuation and set a prompt
(let/cc k
(let ([v (make-continuation-prompt-tag 'r6rs:call/cc)]
[orig-key (continuation-mark-set-first #f detect-tail-key)])
(with-continuation-mark detect-tail-key v
(let ([new-key (continuation-mark-set-first #f detect-tail-key)])
(if (not (eq? new-key orig-key))
;; Old mark surived => not tail wrt old call.
;; Create an escape continuation to use for
;; error escapes. Of course, we rely on the fact
;; that continuation marks are not visible to EoPL
;; programs.
(call-with-continuation-prompt
(lambda ()
(f (mk-k k new-key)))
new-key)
;; Old mark replaced => tail wrt old call.
;; To preserve tail semantics for all but the first call
;; reuse `mark' instead of creating a new escape continuation:
(with-continuation-mark detect-tail-key orig-key
(f (mk-k k orig-key)))))))))

1
collects/rnrs/io/info.ss Normal file
View File

@ -0,0 +1 @@
#lang setup/infotab

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

@ -1,9 +1,13 @@
#lang scheme/base
;; FIXME: newline decoding
(require rnrs/enums-6
rnrs/conditions-6
r6rs/private/io-conds
scheme/port)
r6rs/private/readtable
scheme/port
scheme/pretty)
(provide (all-from-out r6rs/private/io-conds)
file-options
@ -17,6 +21,7 @@
transcoder-codec
transcoder-eol-style
transcoder-error-handling-mode
native-transcoder
;bytevector->string
;string->bytevector
(rename-out [eof eof-object])
@ -38,9 +43,44 @@
open-bytevector-input-port
open-string-input-port
standard-input-port
current-input-port
(rename-out [r6rs:current-input-port current-input-port])
make-custom-binary-input-port
make-custom-textual-input-port)
make-custom-textual-input-port
get-u8
lookahead-u8
get-bytevector-n
get-bytevector-n!
get-bytevector-some
get-bytevector-all
get-char
lookahead-char
get-string-n
get-string-n!
get-string-all
get-line
get-datum
output-port?
flush-output-port
output-port-buffer-mode
open-file-output-port
open-bytevector-output-port
call-with-bytevector-output-port
open-string-output-port
call-with-string-output-port
standard-output-port
standard-error-port
(rename-out [r6rs:current-output-port current-output-port]
[r6rs:current-error-port current-error-port])
make-custom-binary-output-port
make-custom-textual-output-port
put-u8
put-bytevector
put-char
put-string
put-datum
open-file-input/output-port
make-custom-binary-input/output-port
make-custom-textual-input/output-port)
;; ----------------------------------------
@ -53,11 +93,11 @@
(define (buffer-mode? m)
(enum-set-member? m (-buffer-modes none line block)))
(define-enumeration eol-style (lf cr crlf nel crnel ls)
(define-enumeration eol-style (lf cr crlf nel crnel ls none)
-eol-styles)
(define-struct codec (enc))
(define latin-1 (make-codec "latin-1"))
(define latin-1 (make-codec "latin1"))
(define utf-8 (make-codec "utf-8"))
(define utf-16 (make-codec "utf-16"))
@ -87,14 +127,17 @@
[handling-mode 'replace])
(unless (codec? codec)
(raise-type-error 'make-transcoder "codec" codec))
(unless (enum-set-member? eol-style (-eol-styles lf cr crlf nel crnel ls))
(raise-type-error 'make-transcoder "'lf, 'cr, 'crlf, 'nel, 'crnel, or 'ls" eol-style))
(unless (enum-set-member? eol-style (-eol-styles lf cr crlf nel crnel ls none))
(raise-type-error 'make-transcoder "'lf, 'cr, 'crlf, 'nel, 'crnel, 'ls, or 'none" eol-style))
(unless (enum-set-member? handling-mode (-handling-modes ignore raise replace))
(raise-type-error 'make-transcoder "'ignore, 'raise, or 'replace" eol-style))
(make-transcoder codec eol-style handling-mode))
(define utf8-transcoder
(make-transcoder utf-8 'none '?))
(define (native-transcoder)
(make-transcoder utf-8))
utf8-transcoder)
;; ----------------------------------------
@ -196,6 +239,11 @@
(set! disconnected? #t)
port)))
;; For merging two kinds of ports:
(define-struct dual-port (in out)
#:property prop:input-port 0
#:property prop:output-port 1)
;; R6RS functions that generate binary ports wrap them with `binary-...-port'
;; structures, so that the binary ports can be "closed" by `transcoded-port'.
(define-struct binary-input-port (port disconnect get-pos set-pos!)
@ -215,6 +263,7 @@
(define (port-transcoder port)
(cond
[(dual-port? port) (port-transcoder (dual-port-in port))]
[(textual-input-port? port) (textual-input-port-transcoder port)]
[(textual-output-port? port) (textual-output-port-transcoder port)]
[(input-port? port) #f]
@ -224,30 +273,46 @@
(define (textual-port? v)
(if (port? v)
(or (textual-input-port? v)
(textual-output-port? v))
(textual-output-port? v)
(and (dual-port? v)
(textual-port? (dual-port-in v))))
(raise-type-error 'textual-port? "port" v)))
(define (binary-port? v)
(if (port? v)
(not (or (textual-input-port? v)
(textual-output-port? v)))
(textual-output-port? v)
(and (dual-port? v)
(textual-port? (dual-port-in v)))))
(raise-type-error 'binary-port? "port" v)))
(define (wrap-binary-input-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-input-port p)])
(make-binary-input-port p disconnect get-pos set-pos!)))
(define (wrap-binary-output-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-output-port p)])
(make-binary-output-port p disconnect get-pos set-pos!)))
(define (wrap-binary-input/output-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-input-port p)]
[(out-p out-disconnect) (make-disconnectable-output-port p)])
(make-binary-input/output-port p disconnect get-pos set-pos!
out-p out-disconnect)))
(define (transcode-input p t)
(let ([p (if (binary-input-port? p)
((binary-input-port-disconnect p))
p)])
(reencode-input-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))
(if (eq? t utf8-transcoder)
p
(reencode-input-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t))))
(define (transcode-output p t)
(let ([p (cond
@ -256,13 +321,15 @@
[(binary-input/output-port? p)
((binary-input/output-port-out-disconnect p))]
[else p])])
(reencode-output-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))
(if (eq? t utf8-transcoder)
p
(reencode-output-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t))))
(define (transcoded-port p t)
(unless (and (port? p)
@ -272,13 +339,13 @@
(raise-type-error 'transcoded-port "transcoder" t))
(cond
[(and (input-port? p) (output-port? p))
(make-textual-input/output-port (transcode-input p)
(make-textual-input/output-port (transcode-input p t)
t
(transcode-output p))]
(transcode-output p t))]
[(input-port? p)
(make-textual-input-port (transcode-input p t) t)]
[(output-port? p)
(make-textual-input-port (transcode-output p t) t)]))
(make-textual-output-port (transcode-output p t) t)]))
(define (port-has-port-position? p)
(unless (port? p)
@ -292,6 +359,8 @@
(port-has-port-position? (textual-input-port-port p))]
[(textual-output-port? p)
(port-has-port-position? (textual-output-port-port p))]
[(dual-port? p)
(port-has-port-position? (dual-port-in p))]
[else #t]))
(define (port-position p)
@ -304,6 +373,8 @@
(port-position (textual-input-port-port p))]
[(textual-output-port? p)
(port-position (textual-output-port-port p))]
[(dual-port? p)
(port-position (dual-port-in p))]
[else (file-position p)]))
(define (port-has-set-port-position!? p)
@ -318,6 +389,8 @@
(port-has-set-port-position!? (textual-input-port-port p))]
[(textual-output-port? p)
(port-has-set-port-position!? (textual-output-port-port p))]
[(dual-port? p)
(port-has-set-port-position!? (dual-port-in p))]
[else
;; FIXME
(or (file-stream-port? p)
@ -336,6 +409,8 @@
(set-port-position! (textual-input-port-port p) pos)]
[(textual-output-port? p)
(set-port-position! (textual-output-port-port p) pos)]
[(dual-port? p)
(set-port-position! (dual-port-in p))]
[else
(file-position p pos)]))
@ -393,13 +468,19 @@
(define (open-string-input-port str)
(unless (string? str)
(raise-type-error 'open-bytevector-input-port "string" str))
(transcoded-port (open-input-string str) utf-8))
(let ([p (open-input-string str)])
(transcoded-port
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos)))
utf8-transcoder)))
(define standard-input-port
(let ([p (current-input-port)])
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos)))))
(lambda ()
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define input-ports (make-hash-table 'weak))
@ -410,7 +491,7 @@
[(hash-table-get input-ports p #f)
=> ephemeron-value]
[else
(let ([p2 (transcoded-port p utf-8)])
(let ([p2 (transcoded-port p utf8-transcoder)])
(hash-table-put! input-ports p (make-ephemeron p p2))
p2)])))
@ -423,7 +504,7 @@
eof
v)))
#f
close)])
(or close void))])
(wrap-binary-input-port p
get-position
set-position!)))
@ -448,6 +529,390 @@
n)))))
get-position
set-position!
close)))
(or close void))))
;; ----------------------------------------
(define (get-u8 p)
(unless (binary-port? p)
(raise-type-error 'get-u8 "binary port" p))
(read-byte p))
(define (lookahead-u8 p)
(unless (binary-port? p)
(raise-type-error 'lookahead-u8 "binary port" p))
(peek-byte p 0))
(define (get-bytevector-n p cnt)
(unless (binary-port? p)
(raise-type-error 'get-bytevector-n "binary port" p))
(read-bytes cnt p))
(define (get-bytevector-n! p bytes start end)
(unless (binary-port? p)
(raise-type-error 'get-bytevector-n! "binary port" p))
(read-bytes! bytes p start end))
(define (get-bytevector-some p)
(unless (binary-port? p)
(raise-type-error 'get-bytevector-some "binary port" p))
(let ([bytes (make-bytes 4096)])
(let ([n (read-bytes-avail! bytes p)])
(if (eof-object? n)
n
(subbytes bytes 0 n)))))
(define (get-bytevector-all p)
(unless (binary-port? p)
(raise-type-error 'get-bytevector-all "binary port" p))
(let ([p2 (open-output-bytes)])
(copy-port p p2)
(get-output-bytes p #t)))
;; ----------------------------------------
(define (get-char p)
(unless (textual-port? p)
(raise-type-error 'get-char "textual port" p))
(read-char p))
(define (lookahead-char p)
(unless (textual-port? p)
(raise-type-error 'lookahead-char "textual port" p))
(peek-char p))
(define (get-string-n p cnt)
(unless (textual-port? p)
(raise-type-error 'get-string-n "textual port" p))
(read-string cnt p))
(define (get-string-n! p str start end)
(unless (textual-port? p)
(raise-type-error 'get-string-n! "textual port" p))
(read-string! str p start end))
(define (get-string-all p)
(unless (textual-port? p)
(raise-type-error 'get-string-all "textual port" p))
(let ([p2 (open-output-bytes)])
(copy-port p p2)
(get-output-string p)))
(define (get-line p)
(unless (textual-port? p)
(raise-type-error 'get-line "textual port" p))
(read-line p 'linefeed))
(define (get-datum p)
(unless (textual-port? p)
(raise-type-error 'get-datum "textual port" p))
(let loop ([v (with-r6rs-reader-parameters (lambda () (read p)))])
(cond
[(pair? v) (mcons (loop (car v))
(loop (cdr v)))]
[(vector? v) (list->vector
(map loop (vector->list v)))]
[else v])))
;; ----------------------------------------
(define (flush-output-port p)
(flush-output p))
(define (output-port-buffer-mode p)
(file-stream-buffer-mode p))
(define (do-open-file-output-port who
filename
options
buffer-mode
maybe-transcoder
open-output-file
file-position
wrap-binary-port)
(unless (enum-set=? (enum-set-universe options)
(enum-set-universe (file-options)))
(raise-type-error who "file-options enum set" options))
(unless (enum-set-member? buffer-mode (-buffer-modes none line block))
(raise-type-error who "'none, 'line, or 'block" buffer-mode))
(when maybe-transcoder
(unless (transcoder? maybe-transcoder)
(raise-type-error who "transcoder or #f" maybe-transcoder)))
(let ([p (open-output-file filename
#:exists (cond
[(or (enum-set=? options (file-options no-create no-fail no-truncate))
(enum-set=? options (file-options no-create no-truncate)))
'must-update]
[(enum-set=? options (file-options no-fail no-truncate))
'update]
[(enum-set-member? 'no-create) ; no-create, no-create + no-fail
'must-truncate]
[(enum-set-member? options 'no-fail) ; no-fail
'truncate]
[else ; no-truncate, <empty>
'error]))])
(file-stream-buffer-mode p buffer-mode)
(if maybe-transcoder
(transcoded-port p maybe-transcoder)
(wrap-binary-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define (open-file-output-port filename
[options (file-options)]
[buffer-mode 'block]
[maybe-transcoder #f])
(do-open-file-output-port 'open-file-output-port
filename
options
buffer-mode
maybe-transcoder
open-output-file
file-position
wrap-binary-output-port))
(define (open-bytevector-output-port [maybe-transcoder #f])
(when maybe-transcoder
(unless (transcoder? maybe-transcoder)
(raise-type-error 'open-bytevector-output-port "transcoder or #f" maybe-transcoder)))
(let ([p (open-output-bytes)])
(values
(if maybe-transcoder
(transcoded-port p maybe-transcoder)
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))
(lambda () (get-output-bytes p #t)))))
(define (call-with-bytevector-output-port proc [maybe-transcoder #f])
(let-values ([(p get) (open-bytevector-output-port maybe-transcoder)])
(proc p)
(close-output-port p)
(get)))
(define (open-string-output-port)
(let ([p (open-output-string)])
(values
(transcoded-port p utf8-transcoder)
(lambda ()
(bytes->string/utf-8 (get-output-bytes p #t))))))
(define (call-with-string-output-port proc)
(let-values ([(p get) (open-string-output-port)])
(proc p)
(close-output-port p)
(get)))
(define standard-output-port
(let ([p (current-output-port)])
(lambda ()
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define standard-error-port
(let ([p (current-error-port)])
(lambda ()
(wrap-binary-output-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define output-ports (make-hash-table 'weak))
(define (r6rs:current-output-port)
(convert-output-port (current-output-port)))
(define (r6rs:current-error-port)
(convert-output-port (current-error-port)))
(define (convert-output-port p)
(cond
[(textual-port? p) p]
[(hash-table-get output-ports p #f)
=> ephemeron-value]
[else
(let ([p2 (transcoded-port p utf8-transcoder)])
(hash-table-put! output-ports p (make-ephemeron p p2))
p2)]))
(define (make-custom-binary-output-port id write! get-position set-position! close)
(wrap-binary-output-port
(make-output-port
id
always-evt ;; assuming that it never blocks!
(lambda (bytes start end can-block/buffer? enable-break?)
(write! bytes start end))
(or close void)
#f
#f
#f
#f
void
0
#f)
get-position
set-position!))
(define (make-custom-textual-output-port id write! get-position set-position! close)
(transcoded-port
(wrap-binary-output-port
(make-output-port
id
always-evt ;; assuming that it never blocks!
(let-values ([(in out) (make-pipe)]
[(c) #f]
[(cvt-buffer) #f]
[(buffer) #f])
(lambda (bytes start end can-block/buffer? enable-break?)
(let ([direct? (zero? (pipe-content-length in))])
(if (and direct?
(bytes-utf-8-length bytes #f start end))
;; No old bytes saved, and bytes to write form a complete
;; UTF-8 encoding, so we can write directly:
(let ([s (bytes->string/utf-8 bytes #f start end)])
(write! s 0 (string-length s)))
;; Partial or need to use existing bytes, so use pipe
(begin
(write-bytes bytes out start end)
(unless buffer
(set! c (bytes-open-converter "UTF-8-permissive" "UTF-8"))
(set! buffer (make-bytes 4096))
(set! cvt-buffer (make-bytes 4096)))
(let loop ()
(let ([n (peek-bytes-avail!* buffer 0 in)])
(let ([more? ((pipe-content-length in) . > . n)])
(let-values ([(amt used status) (bytes-convert c buffer 0 n cvt-buffer)])
(when (positive? amt)
(read-bytes! buffer in 0 amt)
(let ([s (bytes->string/utf-8 buffer #f 0 amt)])
(write! s 0 (string-length s))))
(when (eq? status 'error)
;; Discard an erroneous byte
(read-byte in))
;; Loop
(unless (and (eq? status 'complete)
(not more?))
(loop)))))))))
(- end start)))
(or close void)
#f
#f
#f
#f
void
0
#f)
get-position
set-position!)
utf8-transcoder))
;; ----------------------------------------
(define (put-u8 port b)
(unless (binary-port? port)
(raise-type-error 'put-u8 "binary port" port))
(write-byte b port))
(define (put-bytevector port bytes [start 0] [count (- (bytes-length bytes) start)])
(unless (binary-port? port)
(raise-type-error 'put-bytevector "binary port" port))
(write-bytes bytes port start (+ start count)))
(define (put-char port ch)
(unless (textual-port? port)
(raise-type-error 'put-u8 "textual port" port))
(write-char ch port))
(define (put-string port str [start 0] [count (- (bytes-length bytes) start)])
(unless (textual-port? port)
(raise-type-error 'put-string "textual port" port))
(write-string (substring str start (+ start count)) port))
(define (put-datum port v)
(unless (textual-port? port)
(raise-type-error 'put-datum "textual port" port))
(parameterize ([print-mpair-curly-braces #f]
[pretty-print-columns 'infinity]
[pretty-print-size-hook
(lambda (v write? p)
(cond
[(string? v)
(and (for/or ([c (in-string v)])
(not (or (char-graphic? c)
(char-blank? c))))
(for/fold ([w 2])
([c (in-string v)])
(cond
[(eq? c #\") 2]
[(eq? c #\\) 2]
[(char-graphic? c) 1]
[(char-blank? c) 1]
[(eq? c #\newline) 2]
[(eq? c #\return) 2]
[else 9])))]
[else #f]))]
[pretty-print-print-hook
(lambda (v write? p)
(cond
[(string? v)
(write-char #\" p)
(for ([c (in-string v)])
(cond
[(eq? c #\") (display "\\\"" p)]
[(eq? c #\\) (display "\\n" p)]
[(char-graphic? c) (write-char c p)]
[(char-blank? c) (write-char c p)]
[(eq? c #\newline) (display "\\\\" p)]
[(eq? c #\return) (display "\\r" p)]
[else
(display "\\x" p)
(let ([s (format "00000~x" (char->integer c))])
(display (substring s (- (string-length s) 6)) p)
(write-char #\; p))]))
(write-char #\" p)]))])
(pretty-print v port)))
;; ----------------------------------------
(define (open-file-input/output-port filename
[options (file-options)]
[buffer-mode 'block]
[maybe-transcoder #f])
(do-open-file-output-port 'open-file-input/output-port
filename
options
buffer-mode
maybe-transcoder
(lambda (name #:exists mode)
(let-values ([(in out) (open-input-output-file name #:exists mode)])
(make-dual-port in out)))
;; Input and output buffering make `file-position' iffy.
(if (eq? buffer-mode 'none)
file-position
#f)
wrap-binary-input/output-port))
(define (make-make-custom-input/output-port
make-custom-input-port
make-custom-output-port)
(lambda (id read! write! get-pos set-pos! close)
(let* ([closed-one? #f]
[close (and close
(lambda ()
(if closed-one?
(close)
(set! closed-one? #t))))])
(let ([in (make-custom-input-port id read! get-pos set-pos! close)]
[out (make-custom-output-port id write! get-pos set-pos! close)])
(make-dual-port in out)))))
(define make-custom-binary-input/output-port
(make-make-custom-input/output-port
make-custom-binary-input-port
make-custom-binary-output-port))
(define make-custom-textual-input/output-port
(make-make-custom-input/output-port
make-custom-textual-input-port
make-custom-textual-output-port))

73
collects/rnrs/io/simple-6.ss
View File

@ -1,35 +1,66 @@
#lang scheme/base
(require r6rs/private/readtable)
(require (prefix-in r6rs: rnrs/io/ports-6))
(provide (rename-out [eof eof-object])
eof-object?
call-with-input-file
call-with-output-file
(rename-out [r6rs:call-with-input-file call-with-input-file]
[r6rs:call-with-output-file call-with-output-file])
input-port?
output-port?
current-input-port
current-output-port
current-error-port
with-input-from-file
with-output-to-file
open-input-file
open-output-file
(rename-out [r6rs:current-input-port current-input-port]
[r6rs:current-output-port current-output-port]
[r6rs:current-error-port current-error-port]
[r6rs:with-input-from-file with-input-from-file]
[r6rs:with-output-to-file with-output-to-file]
[r6rs:open-input-file open-input-file]
[r6rs:open-output-file open-output-file])
close-input-port
close-output-port
read-char
peek-char
(rename-out [r6rs:read read])
(rename-out [r6rs:peek-char peek-char]
[r6rs:read read])
write-char
newline
display
write)
(rename-out [r6rs:write write]))
(define (r6rs:call-with-input-file file proc)
(r6rs:call-with-port
(r6rs:open-input-file file)
proc))
(define (r6rs:call-with-output-file file proc)
(r6rs:call-with-port
(r6rs:open-output-file file)
proc))
(define (r6rs:with-input-from-file file proc)
(let ([p (r6rs:open-input-file file)])
(begin0
(parameterize ([current-input-port p])
(proc))
(close-input-port p))))
(define (r6rs:with-output-to-file file proc)
(let ([p (r6rs:open-output-file file)])
(begin0
(parameterize ([current-output-port p])
(proc))
(close-output-port p))))
(define (r6rs:open-input-file file)
(r6rs:transcoded-port (r6rs:open-file-input-port file) (r6rs:native-transcoder)))
(define (r6rs:open-output-file file)
(r6rs:transcoded-port (r6rs:open-file-output-port file) (r6rs:native-transcoder)))
(define (r6rs:peek-char [in (current-input-port)])
(peek-char in))
(define (r6rs:read [in (r6rs:current-input-port)])
(r6rs:get-datum in))
(define (r6rs:write v [out (r6rs:current-output-port)])
(r6rs:put-datum out v))
(define (r6rs:read [in (current-input-port)])
(let loop ([v (with-r6rs-reader-parameters (lambda () (read in)))])
(cond
[(pair? v) (mcons (loop (car v))
(loop (cdr v)))]
[(vector? v) (list->vector
(map loop (vector->list v)))]
[else v])))

1
collects/rnrs/records/info.ss Normal file
View File

@ -0,0 +1 @@
#lang setup/infotab

34
collects/rnrs/unicode-6.ss
View File

@ -19,7 +19,7 @@
char-upper-case?
char-lower-case?
char-title-case?
char-general-category
(rename-out [r6rs:char-general-category char-general-category])
string-upcase
string-downcase
@ -35,3 +35,35 @@
string-normalize-nfkd
string-normalize-nfc
string-normalize-nfkc)
(define (r6rs:char-general-category ch)
(hash-table-get #hasheq((ll . Ll)
(lu . Lu)
(lt . Lt)
(lm . Lm)
(lo . Lo)
(mn . Mn)
(mc . Mc)
(me . Me)
(nl . Nl)
(no . No)
(nd . Nd)
(zl . Zl)
(zs . Zs)
(zp . Zp)
(pc . Pc)
(pd . Pd)
(ps . Ps)
(pe . Pe)
(pi . Pi)
(pf . Pf)
(po . Po)
(sm . Sm)
(sc . Sc)
(sk . Sk)
(so . So)
(cf . Cf)
(cn . Cn)
(co . Co)
(cc . Cc))
(char-general-category ch)))

4
collects/scheme/private/kw-file.ss
View File

@ -12,10 +12,10 @@
call-with-output-file*)
(define exists-syms
'(error append update replace truncate truncate/replace))
'(error append update replace truncate must-truncate truncate/replace))
(define exists-desc
"'error, 'append, 'update, 'replace, 'truncate, or 'truncate/replace")
"'error, 'append, 'update, 'replace, 'truncate, 'must-truncate, or 'truncate/replace")
(define -open-input-file
(let ([open-input-file (lambda (path #:mode [mode 'binary])

27
collects/scribblings/reference/file-ports.scrbl
View File

@ -64,7 +64,8 @@ A @tech{path} value that is the @tech{cleanse}d version of
@defproc[(open-output-file [path path-string?]
[#:mode mode-flag (one-of/c 'binary 'text) 'binary]
[#:exists exists-flag (one-of/c 'error 'append 'update
'replace 'truncate 'truncate/replace) 'error])
'replace 'truncate
'must-truncate 'truncate/replace) 'error])
output-port?]{
Opens the file specified by @scheme[path] for output. The
@ -86,16 +87,23 @@ Under Windows, @scheme['text] mode works only with regular files;
attempting to use @scheme['text] with other kinds of files triggers an
@scheme[exn:fail:filesystem] exception.
The @scheme[exists-flag] argument specifies how to handle the case
that the file already exists.
The @scheme[exists-flag] argument specifies how to handle/require
files that already exist:
@itemize{
@item{@indexed-scheme['error] --- raise @scheme[exn:fail:filesystem].}
@item{@indexed-scheme['error] --- raise @scheme[exn:fail:filesystem]
if the file exists.}
@item{@indexed-scheme['replace] --- remove the old file and write a new one.}
@item{@indexed-scheme['replace] --- remove the old file, if it
exists, and write a new one.}
@item{@indexed-scheme['truncate] --- removed all old data.}
@item{@indexed-scheme['truncate] --- remove all old data, if the file
exists.}
@item{@indexed-scheme['must-truncate] --- remove all old data in an
existing file; if the file does not exist, the
@exnraise[exn:fail:filesystem].}
@item{@indexed-scheme['truncate/replace] --- try @scheme['truncate];
if it fails (perhaps due to file permissions), try
@ -105,9 +113,10 @@ that the file already exists.
truncating it; if the file does not exist, the
@exnraise[exn:fail:filesystem].}
@item{@indexed-scheme['append] --- append to the end of the file
under @|AllUnix|; under Windows, @scheme['append] is equivalent
to @scheme['update], except that the file position is
@item{@indexed-scheme['append] --- append to the end of the file,
whether it already exists or not; under Windows,
@scheme['append] is equivalent to @scheme['update], except that
the file is not required to exist, and the file position is
immediately set to the end of the file after opening it.}
}

175
src/mzscheme/src/port.c
View File

@ -75,9 +75,6 @@ static int mzerrno = 0;
# endif
extern int osk_not_console; /* set by cmd-line flag */
#endif
#ifdef MAC_FILE_SYSTEM
# include <Carbon.h>
#endif
#include <math.h> /* for fmod , used by default_sleep */
#include "schfd.h"
@ -189,13 +186,6 @@ typedef struct Scheme_Subprocess {
#endif
/******************** Mac Classic input ********************/
#ifdef MAC_FILE_SYSTEM
# define MZ_FDS
# define MAC_FILE_HANDLES
#endif
/******************** file-descriptor I/O ********************/
/* Windows/Mac I/O is piggy-backed on Unix file-descriptor I/O. Making
@ -235,7 +225,7 @@ typedef struct Scheme_FD {
# include <fcntl.h>
#endif
#if defined(WINDOWS_FILE_HANDLES) || defined(MAC_FILE_HANDLES)
#if defined(WINDOWS_FILE_HANDLES)
# define FILENAME_EXN_E "%E"
#else
# define FILENAME_EXN_E "%e"
@ -355,6 +345,7 @@ static void force_close_input_port(Scheme_Object *port);
static Scheme_Object *text_symbol, *binary_symbol;
static Scheme_Object *append_symbol, *error_symbol, *update_symbol;
static Scheme_Object *replace_symbol, *truncate_symbol, *truncate_replace_symbol;
static Scheme_Object *must_truncate_symbol;
Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol;
@ -386,6 +377,7 @@ scheme_init_port (Scheme_Env *env)
REGISTER_SO(truncate_symbol);
REGISTER_SO(truncate_replace_symbol);
REGISTER_SO(update_symbol);
REGISTER_SO(must_truncate_symbol);
text_symbol = scheme_intern_symbol("text");
binary_symbol = scheme_intern_symbol("binary");
@ -395,6 +387,7 @@ scheme_init_port (Scheme_Env *env)
truncate_symbol = scheme_intern_symbol("truncate");
truncate_replace_symbol = scheme_intern_symbol("truncate/replace");
update_symbol = scheme_intern_symbol("update");
must_truncate_symbol = scheme_intern_symbol("must-truncate");
REGISTER_SO(scheme_none_symbol);
REGISTER_SO(scheme_line_symbol);
@ -3649,25 +3642,6 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
return NULL;
}
# ifdef MAC_FILE_SYSTEM
{
FSSpec spec;
SInt16 refnum;
if (scheme_mac_path_to_spec(filename, &spec)) {
errno = FSpOpenDF(&spec, fsRdWrShPerm, &refnum);
if (errno == noErr)
result = make_fd_input_port(refnum, scheme_make_path(filename), 1, mode[1] == 't', NULL, internal);
else {
filename_exn(name, "could not open file", filename, errno);
return NULL;
}
} else {
filename_exn(name, "could not open file", filename, 0);
return NULL;
}
}
# else
regfile = scheme_is_regular_file(filename);
fp = fopen(filename, mode);
@ -3678,7 +3652,6 @@ scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[
scheme_file_open_count++;
result = scheme_make_named_file_input_port(fp, scheme_make_path(filename));
# endif
# endif
#endif
@ -3703,7 +3676,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
# endif
#endif
int e_set = 0, m_set = 0, i;
int existsok = 0;
int existsok = 0, must_exist = 0;
char *filename;
char mode[4];
int typepos;
@ -3731,6 +3704,10 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
} else if (SAME_OBJ(argv[i], truncate_symbol)) {
existsok = -1;
e_set++;
} else if (SAME_OBJ(argv[i], must_truncate_symbol)) {
existsok = -1;
must_exist = 1;
e_set++;
} else if (SAME_OBJ(argv[i], truncate_replace_symbol)) {
existsok = -2;
e_set++;
@ -3795,7 +3772,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
#ifdef USE_FD_PORTS
/* Note: assuming there's no difference between text and binary mode */
flags = (and_read ? O_RDWR : O_WRONLY) | O_CREAT;
flags = (and_read ? O_RDWR : O_WRONLY) | (must_exist ? 0 : O_CREAT);
if (mode[0] == 'a')
flags |= O_APPEND;
@ -3861,12 +3838,17 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
# ifdef WINDOWS_FILE_HANDLES
if (!existsok)
hmode = CREATE_NEW;
else if (existsok < 0)
hmode = OPEN_ALWAYS;
else if (existsok == 1)
else if (existsok < 0) {
if (must_exist)
hmode = TRUNCATE_EXISTING;
else
hmode = OPEN_ALWAYS;
} else if (existsok == 1) {
/* assert: !must_exist */
hmode = CREATE_ALWAYS;
else if (existsok == 2)
hmode = OPEN_ALWAYS;
} else if (existsok == 2) {
hmode = OPEN_EXISTING;
}
fd = CreateFileW(WIDE_PATH(filename),
GENERIC_WRITE | (and_read ? GENERIC_READ : 0),
@ -3948,50 +3930,6 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
}
# ifdef MAC_FILE_SYSTEM
{
FSSpec spec;
SInt16 refnum;
int creating = 0;
if (scheme_mac_path_to_spec(filename, &spec)) {
if (existsok == 1) {
/* In case it's there: */
FSpDelete(&spec);
}
errno = FSpCreate(&spec, 'MrEd', 'TEXT', smSystemScript);
if (errno == dupFNErr) {
if (!existsok) {
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
"%s: file \"%q\" exists", name, filename);
return NULL;
}
} else
creating = 1;
errno = FSpOpenDF(&spec, fsRdWrShPerm, &refnum);
if ((errno == noErr) && (existsok < 0)) {
/* truncate or truncate/replace */
SetEOF(refnum, 0);
}
if (errno == noErr) {
if (creating)
scheme_file_create_hook(filename);
scheme_file_open_count++;
return make_fd_output_port(refnum, scheme_make_path(filename), 1, mode[1] == 't', and_read);
} else {
filename_exn(name, "could not open file", filename, errno);
return NULL;
}
} else {
filename_exn(name, "could not open file", filename, 0);
return NULL;
}
}
# else
if (and_read) {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"%s: not supported on this platform",
@ -4041,7 +3979,6 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
scheme_file_open_count++;
return scheme_make_file_output_port(fp);
# endif
# endif
#endif
}
@ -4659,9 +4596,6 @@ fd_byte_ready (Scheme_Input_Port *port)
return 0;
#else
# ifdef MAC_FILE_HANDLES
return 1;
# else
int r;
DECL_FDSET(readfds, 1);
DECL_FDSET(exnfds, 1);
@ -4697,7 +4631,6 @@ fd_byte_ready (Scheme_Input_Port *port)
# endif
return r;
# endif
#endif
}
}
@ -4865,17 +4798,6 @@ static long fd_get_string_slow(Scheme_Input_Port *port,
}
}
#else
# ifdef MAC_FILE_HANDLES
{
SInt32 cnt = target_size;
errno = FSRead(fip->fd, &cnt, target + target_offset);
if (!cnt && (errno != eofErr))
bc = -1;
else
bc = cnt;
}
# else
if (fip->regfile) {
do {
bc = read(fip->fd, target + target_offset, target_size);
@ -4898,7 +4820,6 @@ static long fd_get_string_slow(Scheme_Input_Port *port,
bc = 0;
}
}
# endif
#endif
if (!none_avail) {
@ -5010,16 +4931,10 @@ fd_close_input(Scheme_Input_Port *port)
}
#else
if (!fip->refcount || !*fip->refcount) {
# ifdef MAC_FILE_HANDLES
FSClose(fip->fd);
# else
{
int cr;
do {
cr = close(fip->fd);
} while ((cr == -1) && (errno == EINTR));
}
# endif
int cr;
do {
cr = close(fip->fd);
} while ((cr == -1) && (errno == EINTR));
}
#endif
@ -5033,11 +4948,8 @@ fd_need_wakeup(Scheme_Input_Port *port, void *fds)
#ifdef WINDOWS_FILE_HANDLES
#else
# ifdef MAC_FILE_HANDLES
# else
void *fds2;
int n;
# endif
#endif
fip = (Scheme_FD *)port->port_data;
@ -5065,13 +4977,10 @@ fd_need_wakeup(Scheme_Input_Port *port, void *fds)
scheme_add_fd_handle((void *)fip->fd, fds, 0);
}
#else
# ifdef MAC_FILE_HANDLES
# else
n = fip->fd;
MZ_FD_SET(n, (fd_set *)fds);
fds2 = MZ_GET_FDSET(fds, 2);
MZ_FD_SET(n, (fd_set *)fds2);
# endif
#endif
}
@ -5676,9 +5585,6 @@ fd_write_ready (Scheme_Object *port)
} else
return 1; /* non-blocking output, such as a console, or haven't written yet */
#else
# ifdef MAC_FILE_HANDLES
return 1;
# else
{
DECL_FDSET(writefds, 1);
DECL_FDSET(exnfds, 1);
@ -5699,7 +5605,6 @@ fd_write_ready (Scheme_Object *port)
return sr;
}
# endif
#endif
}
@ -5712,11 +5617,8 @@ fd_write_need_wakeup(Scheme_Object *port, void *fds)
#ifdef WINDOWS_FILE_HANDLES
#else
# ifdef MAC_FILE_HANDLES
# else
void *fds2;
int n;
# endif
#endif
op = scheme_output_port_record(port);
@ -5728,14 +5630,11 @@ fd_write_need_wakeup(Scheme_Object *port, void *fds)
else
scheme_add_fd_nosleep(fds);
#else
# ifdef MAC_FILE_HANDLES
# else
n = fop->fd;
fds2 = MZ_GET_FDSET(fds, 1);
MZ_FD_SET(n, (fd_set *)fds2);
fds2 = MZ_GET_FDSET(fds, 2);
MZ_FD_SET(n, (fd_set *)fds2);
# endif
#endif
}
@ -6088,17 +5987,6 @@ static long flush_fd(Scheme_Output_Port *op,
}
}
#else
# ifdef MAC_FILE_HANDLES
{
SInt32 put = buflen - offset;
errsaved = FSWrite(fop->fd, &put, bufstr + offset);
if (errsaved != noErr)
len = -1;
else
len = put;
full_write_buffer = 0;
}
# else
int flags;
flags = fcntl(fop->fd, F_GETFL, 0);
@ -6112,7 +6000,6 @@ static long flush_fd(Scheme_Output_Port *op,
fcntl(fop->fd, F_SETFL, flags);
full_write_buffer = (errsaved == EAGAIN);
# endif
#endif
if (len < 0) {
@ -6272,16 +6159,10 @@ fd_close_output(Scheme_Output_Port *port)
}
#else
if (!fop->refcount || !*fop->refcount) {
# ifdef MAC_FILE_HANDLES
FSClose(fop->fd);
# else
{
int cr;
do {
cr = close(fop->fd);
} while ((cr == -1) && (errno == EINTR));
}
# endif
int cr;
do {
cr = close(fop->fd);
} while ((cr == -1) && (errno == EINTR));
}
#endif

2
src/mzscheme/src/portfun.c
View File

@ -4075,7 +4075,7 @@ display_write(char *name,
Scheme_Object *a[2];
a[0] = argv[0];
a[1] = port;
a[1] = (Scheme_Object *)port;
h = op->print_handler;

2
src/mzscheme/src/print.c
View File

@ -841,7 +841,7 @@ print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdispla
char *str;
long len;
op = (Scheme_Output_Port *)port;
op = scheme_output_port_record(port);
if (op->closed)
scheme_raise_exn(MZEXN_FAIL, "%s: output port is closed", name);