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

'must-update file mode; R6RS tests and bug fixes

Browse Source 
svn: r9511
This commit is contained in:
Matthew Flatt 2008-04-28 16:32:50 +00:00
parent 4c893aa7dc
commit f579d40b82
15 changed files with 875 additions and 342 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mzlib/port.ss
View File

@ -1193,7 +1193,7 @@
(cond (cond
[(and (mcdr c) (= buf-start buf-end)) [(and (mcdr c) (= buf-start buf-end))
;; No more bytes to convert; provide single ;; No more bytes to convert; provide single
;; saved byte if it's not #\return, other report 'aborts ;; saved byte if it's not #\return, otherwise report 'aborts
(if (eq? (mcdr c) (char->integer #\return)) (if (eq? (mcdr c) (char->integer #\return))
(values 0 0 'aborts) (values 0 0 'aborts)
(begin (begin
@ -1293,7 +1293,11 @@
(define reencode-input-port (define reencode-input-port
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]
[newline-convert? #f]) [newline-convert? #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) (let ([c (let ([c (bytes-open-converter encoding "UTF-8")])
(if newline-convert? (if newline-convert?
(mcons c #f) (mcons c #f)
@ -1386,8 +1390,7 @@
bytes-convert) bytes-convert)
c buf buf-start buf-end ready-bytes)]) c buf buf-start buf-end ready-bytes)])
(unless (memq status '(continues complete)) (unless (memq status '(continues complete))
(error 'reencode-input-port-read (decode-error "unable to make decoding progress"
"unable to make decoding progress: ~e"
port)) port))
(set! ready-start 0) (set! ready-start 0)
(set! ready-end got-c) (set! ready-end got-c)
@ -1407,9 +1410,7 @@
(set! ready-start 0) (set! ready-start 0)
(set! ready-end (- (bytes-length error-bytes) cnt)) (set! ready-end (- (bytes-length error-bytes) cnt))
cnt)) cnt))
(error (decode-error "decoding error in input stream"
'converting-input-port
"decoding error in input stream: ~e"
port))) port)))
(unless c (unless c
@ -1437,7 +1438,11 @@
(define reencode-output-port (define reencode-output-port
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]
[convert-newlines-to #f]) [convert-newlines-to #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(let ([c (bytes-open-converter "UTF-8" encoding)] (let ([c (bytes-open-converter "UTF-8" encoding)]
[ready-bytes (make-bytes 1024)] [ready-bytes (make-bytes 1024)]
[ready-start 0] [ready-start 0]
@ -1711,16 +1716,14 @@
;; Raise an exception: ;; Raise an exception:
(begin (begin
(set! out-start (add1 out-start)) (set! out-start (add1 out-start))
(error (decode-error
'reencode-output-port "error decoding output to stream"
"error decoding output to stream: ~e"
port)))))))) port))))))))
;; This error is used when decoding wants more bytes to make progress even ;; This error is used when decoding wants more bytes to make progress even
;; though we've supplied hundreds of bytes ;; though we've supplied hundreds of bytes
(define (raise-insane-decoding-length) (define (raise-insane-decoding-length)
(error 'reencode-output-port-write (decode-error "unable to make decoding progress"
"unable to make decoding progress: ~e"
port)) port))
;; Check that a decoder is available: ;; Check that a decoder is available:

273
collects/r6rs/private/conds.ss
View File

@ -1,8 +1,271 @@
#lang scheme #lang scheme/base
(provide (struct-out exn:fail:r6rs) (require rnrs/records/syntactic-6
(struct-out exn:fail:contract:r6rs)) rnrs/records/procedural-6
scheme/mpair
"exns.ss"
(for-syntax scheme/base))
(define-struct (exn:fail:r6rs exn:fail) (who irritants)) (provide &condition
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants)) condition?
condition
simple-conditions
condition-predicate
condition-accessor
define-condition-type
&message make-message-condition message-condition? condition-message
&warning make-warning warning?
&serious make-serious-condition serious-condition?
&error make-error error?
&violation make-violation violation?
&assertion make-assertion-violation assertion-violation?
&irritants make-irritants-condition irritants-condition? condition-irritants
&who make-who-condition who-condition? condition-who
&non-continuable make-non-continuable-violation non-continuable-violation?
&implementation-restriction make-implementation-restriction-violation implementation-restriction-violation?
&lexical make-lexical-violation lexical-violation?
&syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
&undefined make-undefined-violation undefined-violation?
&i/o make-i/o-error i/o-error?
&i/o-read make-i/o-read-error i/o-read-error?
&i/o-write make-i/o-write-error i/o-write-error?
&i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position
&i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename
&i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error?
&i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error?
&i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error?
&i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?
&i/o-port make-i/o-port-error i/o-port-error? i/o-error-port)
(define-record-type &condition (fields))
(define-struct (compound-condition exn) (conditions) #:transparent)
(define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)
(define (condition? v)
(or (&condition? v)
(compound-condition? v)
(compound-condition:fail? v)
(exn? v)))
(define (condition . conds)
(for-each (lambda (c)
(unless (condition? c)
(raise-type-error 'condition "condition" c)))
conds)
(let ([conditions
(apply append
(map simple-conditions/list conds))])
((if (ormap serious-condition? conditions)
make-compound-condition:fail
make-compound-condition)
(or (ormap (lambda (c)
(and (message-condition? c)
(condition-message c)))
conditions)
"exception")
(or (ormap (lambda (c)
(and (has-continuation-marks? c)
(has-continuation-marks-marks c)))
conditions)
(current-continuation-marks))
conditions)))
(define (condition-predicate rtd)
(let ([pred (record-predicate rtd)])
(lambda (v)
(and (condition? v)
(ormap pred (simple-conditions/list v))))))
(define (condition-accessor rtd proc)
(let ([pred (record-predicate rtd)])
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'condition-accessor "procedure (arity 1)" proc))
(lambda (v)
(let ([v (ormap (lambda (x)
(and (pred x) x))
(simple-conditions/list v))])
(if v
(proc v)
(raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
(define (simple-conditions/list c)
(cond
[(&condition? c) (list c)]
[(compound-condition? c)
(compound-condition-conditions c)]
[(compound-condition:fail? c)
(compound-condition:fail-conditions c)]
[(exn? c)
(append
(list
(make-message-condition (exn-message c))
(make-has-continuation-marks (exn-continuation-marks c)))
(if (exn:fail? c)
(list (make-error))
null)
(if (exn:fail:contract? c)
(list (make-assertion-violation))
null)
(if (exn:fail:r6rs? c)
(append
(if (exn:fail:r6rs-who c)
(list (make-who-condition (exn:fail:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:r6rs-irritants c))))
null)
(if (exn:fail:contract:r6rs? c)
(append
(if (exn:fail:contract:r6rs-who c)
(list (make-who-condition (exn:fail:contract:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
null)
(list (make-non-continuable-violation))
(if (or (exn:fail:unsupported? c)
(exn:fail:contract:divide-by-zero? c))
(list (make-implementation-restriction-violation))
null)
(if (exn:fail:read? c)
(list (make-lexical-violation))
null)
(if (exn:fail:syntax? c)
(let ([forms (exn:fail:syntax-exprs c)])
(list (make-syntax-violation
(if (pair? forms)
(car forms)
#f)
(if (and (pair? forms)
(pair? (cdr forms)))
(cadr forms)
#f))))
null)
(if (exn:fail:contract:variable? c)
(list (make-undefined-violation))
null)
(if (exn:fail:filesystem:exists? c)
(list (make-i/o-file-already-exists-error "???"))
null)
(if (exn:fail:filesystem:exists-not? c)
(list (make-i/o-file-does-not-exist-error
(exn:fail:filesystem:exists-not-filename
c)))
null))]
[else (raise-type-error 'simple-conditions
"condition"
c)]))
(define (simple-conditions c)
(list->mlist (simple-conditions/list c)))
(define-syntax (define-condition-type stx)
(syntax-case stx ()
[(_ type supertype
constructor predicate
(field accessor) ...)
(with-syntax ([(tmp-acc ...) (generate-temporaries #'(field ...))])
#'(begin
(define-record-type (type constructor base-predicate)
(fields (immutable field tmp-acc) ...)
(parent supertype))
(define predicate (condition-predicate type))
(define accessor (condition-accessor type tmp-acc)) ...))]))
(define-condition-type &message &condition
make-message-condition message-condition?
(message condition-message))
(define-condition-type &cont-marks &condition
make-has-continuation-marks has-continuation-marks?
(marks has-continuation-marks-marks))
(define-condition-type &warning &condition
make-warning warning?)
(define-condition-type &serious &condition
make-serious-condition serious-condition?)
(define-condition-type &error &serious
make-error error?)
(define-condition-type &violation &serious
make-violation violation?)
(define-condition-type &assertion &violation
make-assertion-violation assertion-violation?)
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
(irritants condition-irritants))
(define-condition-type &who &condition
make-who-condition who-condition?
(who condition-who))
(define-condition-type &non-continuable &violation
make-non-continuable-violation
non-continuable-violation?)
(define-condition-type &implementation-restriction
&violation
make-implementation-restriction-violation
implementation-restriction-violation?)
(define-condition-type &lexical &violation
make-lexical-violation lexical-violation?)
(define-condition-type &syntax &violation
make-syntax-violation syntax-violation?
(form syntax-violation-form)
(subform syntax-violation-subform))
;; ----------------------------------------
;; i/o
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)
(define-condition-type &i/o &error
make-i/o-error i/o-error?)
(define-condition-type &i/o-read &i/o
make-i/o-read-error i/o-read-error?)
(define-condition-type &i/o-write &i/o
make-i/o-write-error i/o-write-error?)
(define-condition-type &i/o-invalid-position &i/o
make-i/o-invalid-position-error
i/o-invalid-position-error?
(position i/o-error-position))
(define-condition-type &i/o-filename &i/o
make-i/o-filename-error i/o-filename-error?
(filename i/o-error-filename))
(define-condition-type &i/o-file-protection
&i/o-filename
make-i/o-file-protection-error
i/o-file-protection-error?)
(define-condition-type &i/o-file-is-read-only
&i/o-file-protection
make-i/o-file-is-read-only-error
i/o-file-is-read-only-error?)
(define-condition-type &i/o-file-already-exists
&i/o-filename
make-i/o-file-already-exists-error
i/o-file-already-exists-error?)
(define-condition-type &i/o-file-does-not-exist
&i/o-filename
make-i/o-file-does-not-exist-error
i/o-file-does-not-exist-error?)
(define-condition-type &i/o-port &i/o
make-i/o-port-error i/o-port-error?
(port i/o-error-port))

10
collects/r6rs/private/exns.ss Normal file
View File

@ -0,0 +1,10 @@
#lang scheme
(provide (struct-out exn:fail:r6rs)
(struct-out exn:fail:contract:r6rs)
(struct-out exn:fail:filesystem:exists-not))
(define-struct (exn:fail:r6rs exn:fail) (who irritants))
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants))
(define-struct (exn:fail:filesystem:exists-not exn:fail:filesystem) (filename))

45
collects/r6rs/private/io-conds.ss
View File

@ -11,47 +11,4 @@
&i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error? &i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error?
&i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? &i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?
&i/o-port make-i/o-port-error i/o-port-error? i/o-error-port) &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port)
(import (rnrs base (6)) (import (r6rs private conds)))
(rnrs conditions (6)))
(define-condition-type &i/o &error
make-i/o-error i/o-error?)
(define-condition-type &i/o-read &i/o
make-i/o-read-error i/o-read-error?)
(define-condition-type &i/o-write &i/o
make-i/o-write-error i/o-write-error?)
(define-condition-type &i/o-invalid-position &i/o
make-i/o-invalid-position-error
i/o-invalid-position-error?
(position i/o-error-position))
(define-condition-type &i/o-filename &i/o
make-i/o-filename-error i/o-filename-error?
(filename i/o-error-filename))
(define-condition-type &i/o-file-protection
&i/o-filename
make-i/o-file-protection-error
i/o-file-protection-error?)
(define-condition-type &i/o-file-is-read-only
&i/o-file-protection
make-i/o-file-is-read-only-error
i/o-file-is-read-only-error?)
(define-condition-type &i/o-file-already-exists
&i/o-filename
make-i/o-file-already-exists-error
i/o-file-already-exists-error?)
(define-condition-type &i/o-file-does-not-exist
&i/o-filename
make-i/o-file-does-not-exist-error
i/o-file-does-not-exist-error?)
(define-condition-type &i/o-port &i/o
make-i/o-port-error i/o-port-error?
(port i/o-error-port)))

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

@ -252,16 +252,27 @@
(define (default-protocol rtd) (define (default-protocol rtd)
(let ((parent (record-type-parent rtd))) (let ((parent (record-type-parent rtd)))
(if (not parent) (if (not parent)
(lambda (p) (lambda (p) p)
(lambda field-values (let ((parent-field-count (field-count parent))
(apply p field-values))) (count (field-count rtd)))
(let ((parent-field-count (field-count parent)))
(lambda (p) (lambda (p)
(lambda all-field-values (lambda all-field-values
(if (= (length all-field-values) count)
(call-with-values (call-with-values
(lambda () (split-at all-field-values parent-field-count)) (lambda () (split-at all-field-values parent-field-count))
(lambda (parent-field-values this-field-values) (lambda (parent-field-values this-field-values)
(apply (apply p parent-field-values) this-field-values))))))))) (apply (apply p parent-field-values) this-field-values)))
(assertion-violation (string->symbol
(string-append
(symbol->string (record-type-name rtd))
" constructor"))
(string-append
"wrong number of arguments (given "
(number->string (length all-field-values))
", expected "
(number->string count)
")")
all-field-values))))))))
(define (record-constructor-descriptor-rtd desc) (define (record-constructor-descriptor-rtd desc)
(typed-vector-ref :record-constructor-descriptor desc 0)) (typed-vector-ref :record-constructor-descriptor desc 0))

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

@ -3,7 +3,7 @@
(require (for-syntax r6rs/private/base-for-syntax (require (for-syntax r6rs/private/base-for-syntax
scheme/base) scheme/base)
r6rs/private/qq-gen r6rs/private/qq-gen
r6rs/private/conds r6rs/private/exns
(prefix-in r5rs: r5rs) (prefix-in r5rs: r5rs)
(only-in r6rs/private/readtable rx:number) (only-in r6rs/private/readtable rx:number)
scheme/bool) scheme/bool)

184
collects/rnrs/conditions-6.ss
View File

@ -1,10 +1,6 @@
#lang scheme/base #lang scheme/base
(require rnrs/records/syntactic-6 (require r6rs/private/conds)
rnrs/records/procedural-6
r6rs/private/conds
scheme/mpair
(for-syntax scheme/base))
(provide &condition (provide &condition
condition? condition?
@ -27,181 +23,3 @@
&lexical make-lexical-violation lexical-violation? &lexical make-lexical-violation lexical-violation?
&syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform &syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
&undefined make-undefined-violation undefined-violation?) &undefined make-undefined-violation undefined-violation?)
(define-record-type &condition (fields))
(define-struct (compound-condition exn) (conditions) #:transparent)
(define-struct (compound-condition:fail exn:fail) (conditions) #:transparent)
(define (condition? v)
(or (&condition? v)
(compound-condition? v)
(compound-condition:fail? v)
(exn? v)))
(define (condition . conds)
(for-each (lambda (c)
(unless (condition? c)
(raise-type-error 'condition "condition" c)))
conds)
(let ([conditions
(apply append
(map simple-conditions/list conds))])
((if (ormap serious-condition? conditions)
make-compound-condition:fail
make-compound-condition)
(or (ormap (lambda (c)
(and (message-condition? c)
(condition-message c)))
conditions)
"exception")
(or (ormap (lambda (c)
(and (has-continuation-marks? c)
(has-continuation-marks-marks c)))
conditions)
(current-continuation-marks))
conditions)))
(define (condition-predicate rtd)
(let ([pred (record-predicate rtd)])
(lambda (v)
(and (condition? v)
(ormap pred (simple-conditions/list v))))))
(define (condition-accessor rtd proc)
(let ([pred (record-predicate rtd)])
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'condition-accessor "procedure (arity 1)" proc))
(lambda (v)
(let ([v (ormap (lambda (x)
(and (pred x) x))
(simple-conditions/list v))])
(if v
(proc v)
(raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
(define (simple-conditions/list c)
(cond
[(&condition? c) (list c)]
[(compound-condition? c)
(compound-condition-conditions c)]
[(compound-condition:fail? c)
(compound-condition:fail-conditions c)]
[(exn? c)
(append
(list
(make-message-condition (exn-message c))
(make-has-continuation-marks (exn-continuation-marks c)))
(if (exn:fail? c)
(list (make-error))
null)
(if (exn:fail:contract? c)
(list (make-assertion-violation))
null)
(if (exn:fail:r6rs? c)
(append
(if (exn:fail:r6rs-who c)
(list (make-who-condition (exn:fail:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:r6rs-irritants c))))
null)
(if (exn:fail:contract:r6rs? c)
(append
(if (exn:fail:contract:r6rs-who c)
(list (make-who-condition (exn:fail:contract:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
null)
(list (make-non-continuable-violation))
(if (or (exn:fail:unsupported? c)
(exn:fail:contract:divide-by-zero? c))
(list (make-implementation-restriction-violation))
null)
(if (exn:fail:read? c)
(list (make-lexical-violation))
null)
(if (exn:fail:syntax? c)
(let ([forms (exn:fail:syntax-exprs c)])
(list (make-syntax-violation
(if (pair? forms)
(car forms)
#f)
(if (and (pair? forms)
(pair? (cdr forms)))
(cadr forms)
#f))))
null)
(if (exn:fail:contract:variable? c)
(list (make-undefined-violation))
null))]
[else (raise-type-error 'simple-conditions
"condition"
c)]))
(define (simple-conditions c)
(list->mlist (simple-conditions/list c)))
(define-syntax (define-condition-type stx)
(syntax-case stx ()
[(_ type supertype
constructor predicate
(field accessor) ...)
(with-syntax ([(tmp-acc ...) (generate-temporaries #'(field ...))])
#'(begin
(define-record-type (type constructor base-predicate)
(fields (immutable field tmp-acc) ...)
(parent supertype))
(define predicate (condition-predicate type))
(define accessor (condition-accessor type tmp-acc)) ...))]))
(define-condition-type &message &condition
make-message-condition message-condition?
(message condition-message))
(define-condition-type &cont-marks &condition
make-has-continuation-marks has-continuation-marks?
(marks has-continuation-marks-marks))
(define-condition-type &warning &condition
make-warning warning?)
(define-condition-type &serious &condition
make-serious-condition serious-condition?)
(define-condition-type &error &serious
make-error error?)
(define-condition-type &violation &serious
make-violation violation?)
(define-condition-type &assertion &violation
make-assertion-violation assertion-violation?)
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
(irritants condition-irritants))
(define-condition-type &who &condition
make-who-condition who-condition?
(who condition-who))
(define-condition-type &non-continuable &violation
make-non-continuable-violation
non-continuable-violation?)
(define-condition-type &implementation-restriction
&violation
make-implementation-restriction-violation
implementation-restriction-violation?)
(define-condition-type &lexical &violation
make-lexical-violation lexical-violation?)
(define-condition-type &syntax &violation
make-syntax-violation syntax-violation?
(form syntax-violation-form)
(subform syntax-violation-subform))
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)

4
collects/rnrs/enums-6.ss
View File

@ -239,14 +239,14 @@
#'(begin #'(begin
(define enum-universe (make-enumeration-universe (mlist 'sym ...))) (define enum-universe (make-enumeration-universe (mlist 'sym ...)))
(define-syntax (type-name stx) (define-syntax (type-name stx)
(syntax-case stx (sym ...) (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ sym) #''sym] [(_ sym) #''sym]
... ...
[(_ other) [(_ other)
(identifier? #'other) (identifier? #'other)
(raise-syntax-error #f "not in enumeration" stx #'other)])) (raise-syntax-error #f "not in enumeration" stx #'other)]))
(define-syntax (bit-value stx) (define-syntax (bit-value stx)
(syntax-case stx (sym ...) (syntax-case* stx (sym ...) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ orig sym) #'val] [(_ orig sym) #'val]
... ...
[(_ orig s) [(_ orig s)

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

@ -6,6 +6,7 @@
rnrs/conditions-6 rnrs/conditions-6
r6rs/private/io-conds r6rs/private/io-conds
r6rs/private/readtable r6rs/private/readtable
r6rs/private/exns
scheme/port scheme/port
scheme/pretty) scheme/pretty)
@ -182,7 +183,8 @@
1 1
(case-lambda (case-lambda
[() (check-disconnect) (file-stream-buffer-mode port)] [() (check-disconnect) (file-stream-buffer-mode port)]
[(mode) (check-disconnect) (file-stream-buffer-mode port mode)])) [(mode) (check-disconnect) (file-stream-buffer-mode port
(if (eq? mode 'line) 'block mode))]))
(lambda () (lambda ()
(set! disconnected? #t) (set! disconnected? #t)
port))) port)))
@ -199,14 +201,16 @@
(lambda (bytes start end can-buffer/block? enable-breaks?) (lambda (bytes start end can-buffer/block? enable-breaks?)
(check-disconnect) (check-disconnect)
(if (= start end) (if (= start end)
(begin
(flush-output port) (flush-output port)
0)
(cond (cond
[enable-breaks? [enable-breaks?
(parameterize-break #t (write-bytes (subbytes start end) port))] (parameterize-break #t (write-bytes (subbytes bytes start end) port))]
[can-buffer/block? [can-buffer/block?
(write-bytes (subbytes start end) port)] (write-bytes (subbytes start end) port)]
[else [else
(write-bytes-avail* (subbytes start end) port)]))) (write-bytes-avail* (subbytes bytes start end) port)])))
(lambda () (lambda ()
(unless disconnected? (unless disconnected?
(close-output-port port))) (close-output-port port)))
@ -316,6 +320,7 @@
p)]) p)])
(if (no-op-transcoder? t) (if (no-op-transcoder? t)
p p
(letrec ([self
(reencode-input-port p (reencode-input-port p
(codec-enc (transcoder-codec t)) (codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t) (case (transcoder-error-handling-mode t)
@ -324,7 +329,15 @@
[(replace) (string->bytes/utf-8 "\uFFFD")]) [(replace) (string->bytes/utf-8 "\uFFFD")])
#t #t
(object-name p) (object-name p)
(not (eq? (transcoder-eol-style t) 'none)))))) (not (eq? (transcoder-eol-style t) 'none))
(lambda (msg port)
(raise
(condition
(make-message-condition
(format "~a: ~e" msg port))
(make-i/o-decoding-error
self)))))])
self))))
(define (transcode-output p t) (define (transcode-output p t)
(let ([p (cond (let ([p (cond
@ -335,6 +348,7 @@
[else p])]) [else p])])
(if (no-op-transcoder? t) (if (no-op-transcoder? t)
p p
(letrec ([self
(reencode-output-port p (reencode-output-port p
(codec-enc (transcoder-codec t)) (codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t) (case (transcoder-error-handling-mode t)
@ -351,7 +365,16 @@
[(crnel) (string->bytes/utf-8 "\r\u85")] [(crnel) (string->bytes/utf-8 "\r\u85")]
[(ls) (string->bytes/utf-8 "\u2028")] [(ls) (string->bytes/utf-8 "\u2028")]
[else (error 'transcoded-port "unknown eol style: ~e" [else (error 'transcoded-port "unknown eol style: ~e"
(transcoder-eol-style t))]))))) (transcoder-eol-style t))])
(lambda (msg port)
(raise
(condition
(make-message-condition
(format "~a: ~e" msg port))
(make-i/o-encoding-error
self
#\?)))))])
self))))
(define (transcoded-port p t) (define (transcoded-port p t)
(unless (and (port? p) (unless (and (port? p)
@ -374,9 +397,9 @@
(raise-type-error 'port-has-port-position? "port" p)) (raise-type-error 'port-has-port-position? "port" p))
(cond (cond
[(binary-input-port? p) [(binary-input-port? p)
(and (binary-input-port-get-pos p))] (and (binary-input-port-get-pos p) #t)]
[(binary-output-port? p) [(binary-output-port? p)
(and (binary-output-port-get-pos p))] (and (binary-output-port-get-pos p) #t)]
[(textual-input-port? p) [(textual-input-port? p)
(port-has-port-position? (textual-input-port-port p))] (port-has-port-position? (textual-input-port-port p))]
[(textual-output-port? p) [(textual-output-port? p)
@ -467,7 +490,9 @@
(unless (transcoder? maybe-transcoder) (unless (transcoder? maybe-transcoder)
(raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder))) (raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder)))
(let ([p (open-input-file filename)]) (let ([p (open-input-file filename)])
(file-stream-buffer-mode p buffer-mode) (file-stream-buffer-mode p (if (eq? buffer-mode 'line)
'block
buffer-mode))
(if maybe-transcoder (if maybe-transcoder
(transcoded-port p maybe-transcoder) (transcoded-port p maybe-transcoder)
(wrap-binary-input-port p (wrap-binary-input-port p
@ -589,7 +614,7 @@
(raise-type-error 'get-bytevector-all "binary port" p)) (raise-type-error 'get-bytevector-all "binary port" p))
(let ([p2 (open-output-bytes)]) (let ([p2 (open-output-bytes)])
(copy-port p p2) (copy-port p p2)
(get-output-bytes p #t))) (get-output-bytes p2 #t)))
;; ---------------------------------------- ;; ----------------------------------------
@ -618,7 +643,7 @@
(raise-type-error 'get-string-all "textual port" p)) (raise-type-error 'get-string-all "textual port" p))
(let ([p2 (open-output-bytes)]) (let ([p2 (open-output-bytes)])
(copy-port p p2) (copy-port p p2)
(get-output-string p))) (get-output-string p2)))
(define (get-line p) (define (get-line p)
(unless (textual-port? p) (unless (textual-port? p)
@ -660,25 +685,36 @@
(when maybe-transcoder (when maybe-transcoder
(unless (transcoder? maybe-transcoder) (unless (transcoder? maybe-transcoder)
(raise-type-error who "transcoder or #f" maybe-transcoder))) (raise-type-error who "transcoder or #f" maybe-transcoder)))
(let ([p (open-output-file filename (let ([exists-mode (cond
#:exists (cond
[(or (enum-set=? options (file-options no-create no-fail no-truncate)) [(or (enum-set=? options (file-options no-create no-fail no-truncate))
(enum-set=? options (file-options no-create no-truncate))) (enum-set=? options (file-options no-create no-truncate)))
'must-update]
[(enum-set=? options (file-options no-fail no-truncate))
'update] 'update]
[(enum-set=? options (file-options no-fail no-truncate))
'can-update]
[(enum-set-member? 'no-create options) ; 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? 'no-fail options) ; no-fail [(enum-set-member? 'no-fail options) ; no-fail
'truncate] 'truncate]
[else ; no-truncate, <empty> [else ; no-truncate, <empty>
'error]))]) 'error])])
(let ([p (with-handlers ([exn:fail:filesystem?
(lambda (exn)
(if (and (or (eq? exists-mode 'update)
(eq? exists-mode 'must-truncate))
(not (file-exists? filename)))
(raise
(make-exn:fail:filesystem:exists-not
(exn-message exn)
(exn-continuation-marks exn)
filename))
(raise exn)))])
(open-output-file filename #:exists exists-mode))])
(file-stream-buffer-mode p buffer-mode) (file-stream-buffer-mode p buffer-mode)
(if maybe-transcoder (if maybe-transcoder
(transcoded-port p maybe-transcoder) (transcoded-port p maybe-transcoder)
(wrap-binary-port p (wrap-binary-port p
(lambda () (file-position p)) (lambda () (file-position p))
(lambda (pos) (file-position p pos)))))) (lambda (pos) (file-position p pos)))))))
(define (open-file-output-port filename (define (open-file-output-port filename
[options (file-options)] [options (file-options)]
@ -697,14 +733,17 @@
(when maybe-transcoder (when maybe-transcoder
(unless (transcoder? maybe-transcoder) (unless (transcoder? maybe-transcoder)
(raise-type-error 'open-bytevector-output-port "transcoder or #f" maybe-transcoder))) (raise-type-error 'open-bytevector-output-port "transcoder or #f" maybe-transcoder)))
(let ([p (open-output-bytes)]) (let* ([p (open-output-bytes)]
(values [p2 (if maybe-transcoder
(if maybe-transcoder
(transcoded-port p maybe-transcoder) (transcoded-port p maybe-transcoder)
(wrap-binary-output-port p (wrap-binary-output-port p
(lambda () (file-position p)) (lambda () (file-position p))
(lambda (pos) (file-position p pos)))) (lambda (pos) (file-position p pos))))])
(lambda () (get-output-bytes p #t))))) (values
p2
(lambda ()
(flush-output p2)
(get-output-bytes p #t)))))
(define (call-with-bytevector-output-port proc [maybe-transcoder #f]) (define (call-with-bytevector-output-port proc [maybe-transcoder #f])
(let-values ([(p get) (open-bytevector-output-port maybe-transcoder)]) (let-values ([(p get) (open-bytevector-output-port maybe-transcoder)])
@ -943,14 +982,14 @@
(unless (transcoder? t) (unless (transcoder? t)
(raise-type-error 'bytevector->string "transcoder" t)) (raise-type-error 'bytevector->string "transcoder" t))
(let ([p #f]) (let ([p #f])
(dynamic-require (dynamic-wind
(lambda () (lambda ()
(set! p (open-bytevector-input-port bv t))) (set! p (open-bytevector-input-port bv t)))
(lambda () (lambda ()
(apply (apply
string-append string-append
(let loop () (let loop ()
(let ([s (get-string-n p)]) (let ([s (get-string-n p 4096)])
(if (eof-object? s) (if (eof-object? s)
null null
(cons s (loop))))))) (cons s (loop)))))))
@ -961,11 +1000,11 @@
(raise-type-error 'string->bytevector "transcoder" t)) (raise-type-error 'string->bytevector "transcoder" t))
(let ([p #f] (let ([p #f]
[result #f]) [result #f])
(dynamic-require (dynamic-wind
(lambda () (lambda ()
(set!-values (p result) (open-bytevector-output-port t))) (set!-values (p result) (open-bytevector-output-port t)))
(lambda () (lambda ()
(put-string s p) (put-string p s)
(result)) (result))
(lambda () (close-output-port p))))) (lambda () (close-output-port p)))))

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

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

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

@ -63,7 +63,7 @@ A @tech{path} value that is the @tech{cleanse}d version of
@defproc[(open-output-file [path path-string?] @defproc[(open-output-file [path path-string?]
[#:mode mode-flag (one-of/c 'binary 'text) 'binary] [#:mode mode-flag (one-of/c 'binary 'text) 'binary]
[#:exists exists-flag (one-of/c 'error 'append 'update [#:exists exists-flag (one-of/c 'error 'append 'update 'can-update
'replace 'truncate 'replace 'truncate
'must-truncate 'truncate/replace) 'error]) 'must-truncate 'truncate/replace) 'error])
output-port?]{ output-port?]{
@ -113,6 +113,9 @@ files that already exist:
truncating it; if the file does not exist, the truncating it; if the file does not exist, the
@exnraise[exn:fail:filesystem].} @exnraise[exn:fail:filesystem].}
@item{@indexed-scheme['can-update] --- open an existing file without
truncating it, or create the file if it does not exist.}
@item{@indexed-scheme['append] --- append to the end of the file, @item{@indexed-scheme['append] --- append to the end of the file,
whether it already exists or not; under Windows, whether it already exists or not; under Windows,
@scheme['append] is equivalent to @scheme['update], except that @scheme['append] is equivalent to @scheme['update], except that

14
collects/scribblings/reference/port-lib.scrbl
View File

@ -188,7 +188,9 @@ it defaults to @scheme[0].}
[error-bytes (or/c false/c bytes?)] [error-bytes (or/c false/c bytes?)]
[close? any/c #t] [close? any/c #t]
[name any/c (object-name in)] [name any/c (object-name in)]
[convert-newlines? any/c #f]) [convert-newlines? any/c #f]
[enc-error (string? input-port? . -> . any)
(lambda (msg port) (error ...))])
input-port?]{ input-port?]{
Produces an input port that draws bytes from @scheme[in], but converts Produces an input port that draws bytes from @scheme[in], but converts
@ -201,7 +203,7 @@ are all converted to the UTF-8 encoding of @scheme["\n"].
If @scheme[error-bytes] is provided and not @scheme[#f], then the If @scheme[error-bytes] is provided and not @scheme[#f], then the
given byte sequence is used in place of bytes from @scheme[in] that given byte sequence is used in place of bytes from @scheme[in] that
trigger conversion errors. Otherwise, if a conversion is encountered, trigger conversion errors. Otherwise, if a conversion is encountered,
the @exnraise[exn:fail]. @scheme[enc-error] is called, which must raise an exception.
If @scheme[close?] is true, then closing the result input port also If @scheme[close?] is true, then closing the result input port also
closes @scheme[in]. The @scheme[name] argument is used as the name of closes @scheme[in]. The @scheme[name] argument is used as the name of
@ -220,7 +222,9 @@ incomplete encoding sequence.)}
[error-bytes (or/c false/c bytes?)] [error-bytes (or/c false/c bytes?)]
[close? any/c #t] [close? any/c #t]
[name any/c (object-name out)] [name any/c (object-name out)]
[newline-bytes (or/c false/c bytes?) #f]) [newline-bytes (or/c false/c bytes?) #f]
[enc-error (string? output-port? . -> . any)
(lambda (msg port) (error ...))])
output-port?]{ output-port?]{
Produces an output port that directs bytes to @scheme[out], but Produces an output port that directs bytes to @scheme[out], but
@ -233,8 +237,8 @@ encoding of @scheme["\n"] are first converted to
If @scheme[error-bytes] is provided and not @scheme[#f], then the If @scheme[error-bytes] is provided and not @scheme[#f], then the
given byte sequence is used in place of bytes send to the output port given byte sequence is used in place of bytes send to the output port
that trigger conversion errors. Otherwise, if a conversion is that trigger conversion errors. Otherwise, @scheme[enc-error] is
encountered, the @exnraise[exn:fail]. called, which must raise an exception.
If @scheme[close?] is true, then closing the result output port also If @scheme[close?] is true, then closing the result output port also
closes @scheme[out]. The @scheme[name] argument is used as the name of closes @scheme[out]. The @scheme[name] argument is used as the name of

61
collects/tests/r6rs/conditions.ss
View File

@ -187,6 +187,67 @@
(make-undefined-violation) (make-undefined-violation)
undefined-violation?) undefined-violation?)
;; These tests really belong in io/ports.ss:
(test-cond &i/o &error
(make-i/o-error)
i/o-error?)
(test-cond &i/o-read &i/o
(make-i/o-read-error)
i/o-read-error?)
(test-cond &i/o-write &i/o
(make-i/o-write-error)
i/o-write-error?)
(test-cond &i/o-invalid-position &i/o
(make-i/o-invalid-position-error 10)
i/o-invalid-position-error?
i/o-error-position)
(test-cond &i/o-filename &i/o
(make-i/o-filename-error "bad.txt")
i/o-filename-error?
i/o-error-filename)
(test-cond &i/o-file-protection &i/o-filename
(make-i/o-file-protection-error "private.txt")
i/o-file-protection-error?
i/o-error-filename)
(test-cond &i/o-file-is-read-only &i/o-file-protection
(make-i/o-file-is-read-only-error "const.txt")
i/o-file-is-read-only-error?
i/o-error-filename)
(test-cond &i/o-file-already-exists &i/o-filename
(make-i/o-file-already-exists-error "x.txt")
i/o-file-already-exists-error?
i/o-error-filename)
(test-cond &i/o-file-does-not-exist &i/o-filename
(make-i/o-file-does-not-exist-error "unicorn.txt")
i/o-file-does-not-exist-error?
i/o-error-filename)
(test-cond &i/o-port &i/o
(make-i/o-port-error "Hong Kong")
i/o-port-error?
i/o-error-port)
(test-cond &i/o-decoding &i/o-port
(make-i/o-decoding-error "Hong Kong")
i/o-decoding-error?
i/o-error-port)
(test-cond &i/o-encoding &i/o-port
(make-i/o-encoding-error "Hong Kong" #\$)
i/o-encoding-error?
i/o-error-port
i/o-encoding-error-char)
;; ;;
)) ))

356
collects/tests/r6rs/io/ports.ss
View File

@ -5,11 +5,363 @@
(import (rnrs) (import (rnrs)
(tests r6rs test)) (tests r6rs test))
(define-syntax test-transcoders
(syntax-rules ()
[(_ bytevector->string string->bytevector)
(begin
(test (bytevector->string #vu8(97 112 112 206 187 101)
(make-transcoder (utf-8-codec)))
"app\x03BB;e")
(test (bytevector->string #vu8(97 112 112 206 187 101)
(make-transcoder (latin-1-codec)))
"app\xCE;\xBB;e")
(test (bytevector->string #vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101)
(make-transcoder (utf-16-codec)))
"app\x03BB;e")
(test (bytevector->string #vu8(97 10 98 13 99 13 10 100 #o302 #o205 101
#o342 #o200 #o250 102 13 #o302 #o205 103)
(make-transcoder (utf-8-codec) 'none))
"a\nb\rc\r\nd\x85;e\x2028;f\r\x85;g")
(test (bytevector->string #vu8(97 10 98 13 99 13 10 100 #o302 #o205 101 #o342
#o200 #o250 102 13 #o302 #o205 103)
(make-transcoder (utf-8-codec) 'lf))
"a\nb\nc\nd\ne\nf\ng")
(test/exn (bytevector->string #vu8(97 112 112 206 101)
(make-transcoder (utf-8-codec) 'lf 'raise))
&i/o-decoding)
(test (string->bytevector "app\x03BB;e"
(make-transcoder (utf-8-codec)))
#vu8(97 112 112 206 187 101))
(test (string->bytevector "apple\x85;"
(make-transcoder (latin-1-codec)))
#vu8(97 112 112 108 101 #x85))
(test (let ([v (string->bytevector "app\x03BB;e"
(make-transcoder (utf-16-codec)))])
;; Could be LE or BE:
(if (= (bytevector-u8-ref v 0) #xFE)
v
(if (equal? v #vu8(#xFF #xFE 97 0 112 0 112 0 #xBB #x3 101 0))
#vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101)
v)))
#vu8(#xFE #xFF 0 97 0 112 0 112 #x3 #xBB 0 101))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'lf))
#vu8(97 10 98))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'cr))
#vu8(97 13 98))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'crlf))
#vu8(97 13 10 98))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'nel))
#vu8(97 #o302 #o205 98))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'ls))
#vu8(97 #o342 #o200 #o250 98))
(test (string->bytevector "a\nb"
(make-transcoder (utf-8-codec) 'crnel))
#vu8(97 13 #o302 #o205 98))
(test/exn (string->bytevector "a\x185;b" (make-transcoder (latin-1-codec) 'lf 'raise))
&i/o-encoding))]))
(define (run-io-ports-tests) (define (run-io-ports-tests)
(test (enum-set->list (file-options)) '())
(test (enum-set-member? 'no-create (file-options)) #f)
(test (enum-set-member? 'no-create (file-options no-create)) #t)
(test (enum-set-member? 'no-create (file-options no-fail)) #f)
(test (enum-set-member? 'no-fail (file-options no-fail)) #t)
(test (enum-set-member? 'no-truncate (file-options no-truncate)) #t)
(test (enum-set-member? 'no-truncate (file-options no-create no-fail no-truncate)) #t)
(test (enum-set-member? 'no-fail (file-options no-create no-fail no-truncate)) #t)
(test (enum-set-member? 'no-create (file-options no-create no-fail no-truncate)) #t)
(test (buffer-mode none) 'none)
(test (buffer-mode line) 'line)
(test (buffer-mode block) 'block)
(test (buffer-mode? 'none) #t)
(test (buffer-mode? 'line) #t)
(test (buffer-mode? 'block) #t)
(test (buffer-mode? 'point) #f)
(test/unspec (latin-1-codec))
(test/unspec (utf-8-codec))
(test/unspec (utf-16-codec))
(test (eol-style lf) 'lf)
(test (eol-style cr) 'cr)
(test (eol-style crlf) 'crlf)
(test (eol-style nel) 'nel)
(test (eol-style crnel) 'crnel)
(test (eol-style ls) 'ls)
(test (eol-style none) 'none)
(test (symbol? (native-eol-style)) #t)
(test (error-handling-mode ignore) 'ignore)
(test (error-handling-mode raise) 'raise)
(test (error-handling-mode replace) 'replace)
(test (transcoder-codec (make-transcoder (latin-1-codec))) (latin-1-codec))
(test (transcoder-codec (make-transcoder (utf-8-codec))) (utf-8-codec))
(test (transcoder-codec (make-transcoder (utf-16-codec))) (utf-16-codec))
(test (transcoder-eol-style (make-transcoder (utf-16-codec))) (native-eol-style))
(test (transcoder-error-handling-mode (make-transcoder (utf-16-codec))) 'replace)
(test (transcoder-codec (make-transcoder (utf-8-codec) 'nel)) (utf-8-codec))
(test (transcoder-eol-style (make-transcoder (utf-8-codec) 'nel)) 'nel)
(test (transcoder-error-handling-mode (make-transcoder (utf-8-codec) 'nel)) 'replace)
(test (transcoder-codec (make-transcoder (utf-8-codec) 'nel 'raise)) (utf-8-codec))
(test (transcoder-eol-style (make-transcoder (utf-8-codec) 'nel 'raise)) 'nel)
(test (transcoder-error-handling-mode (make-transcoder (utf-8-codec) 'nel 'raise)) 'raise)
(test/unspec (native-transcoder))
(test-transcoders bytevector->string
string->bytevector)
(test (eqv? (eof-object) (eof-object)) #t) (test (eqv? (eof-object) (eof-object)) #t)
(test (eq? (eof-object) (eof-object)) #t) (test (eq? (eof-object) (eof-object)) #t)
;; ;; ----------------------------------------
)) ;; Check file creation and truncation:
(test/unspec
(if (file-exists? "io-tmp1")
(delete-file "io-tmp1")))
;; Don't create if 'no-create:
(test/exn (open-file-output-port "io-tmp1"
(file-options no-create))
&i/o-file-does-not-exist)
(test/exn (open-file-output-port "io-tmp1"
(file-options no-create no-fail))
&i/o-file-does-not-exist)
(test/exn (open-file-output-port "io-tmp1"
(file-options no-create no-truncate))
&i/o-file-does-not-exist)
(test/exn (open-file-output-port "io-tmp1"
(file-options no-create no-fail no-truncate))
&i/o-file-does-not-exist)
;; Create:
(let ([p (open-file-output-port "io-tmp1")])
(test (file-exists? "io-tmp1") #t)
(test (port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test (output-port? p) #t)
(test (input-port? p) #f)
(test/unspec (close-port p)))
;; Don't re-create:
(test/exn (open-file-output-port "io-tmp1")
&i/o-file-already-exists)
(test/exn (open-file-output-port "io-tmp1" (file-options no-truncate))
&i/o-file-already-exists)
;; Re-open if 'no-create is specified:
(let ([p (open-file-output-port "io-tmp1"
(file-options no-create))])
(test/unspec (close-port p)))
;; Re-open if 'no-fail is specified:
(let ([p (open-file-output-port "io-tmp1"
(file-options no-fail))])
(test/unspec (close-port p)))
;; Create if 'no-fail is specified and it doesn't exist:
(test/unspec (delete-file "io-tmp1"))
(let ([p (open-file-output-port "io-tmp1"
(file-options no-fail no-truncate))])
(test/unspec (close-port p)))
(test/unspec (delete-file "io-tmp1"))
(let ([p (open-file-output-port "io-tmp1"
(file-options no-fail))])
(test/unspec (put-bytevector p #vu8(99 101 98 100)))
(test/unspec (close-port p)))
;; Check content:
(let ([p (open-file-input-port "io-tmp1")])
(test (port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test (input-port? p) #t)
(test (output-port? p) #f)
(test (get-bytevector-n p 5) #vu8(99 101 98 100))
(test (port-eof? p) #t)
(test/unspec (close-port p)))
;; Check that 'no-truncate doesn't truncate:
(let ([p (open-file-output-port "io-tmp1"
(file-options no-fail no-truncate))])
(test/unspec (put-bytevector p #vu8(97)))
(test/unspec (close-port p)))
(let ([p (open-file-input-port "io-tmp1")])
(test (get-bytevector-n p 5) #vu8(97 101 98 100))
(test/unspec (close-port p)))
(let ([p (open-file-output-port "io-tmp1"
(file-options no-create no-truncate))])
(test/unspec (put-bytevector p #vu8(96)))
(test/unspec (close-port p)))
(let ([p (open-file-input-port "io-tmp1")])
(test (get-bytevector-n p 5) #vu8(96 101 98 100))
(test/unspec (close-port p)))
(let ([p (open-file-output-port "io-tmp1"
(file-options no-create no-truncate))])
(test (port-has-port-position? p) #t)
(test (port-has-set-port-position!? p) #t)
(test (port-position p) 0)
(test/unspec (set-port-position! p 6))
(test (port-position p) 6)
(test/unspec (put-bytevector p #vu8(102)))
(test/unspec (close-port p)))
(let ([p (open-file-input-port "io-tmp1")])
(test (get-bytevector-n p 4) #vu8(96 101 98 100))
(test/unspec (get-bytevector-n p 2))
(test (get-bytevector-n p 2) #vu8(102))
(test/unspec (close-port p)))
;; Otherwise, truncate:
(let ([p (open-file-output-port "io-tmp1"
(file-options no-fail))])
(test/unspec (close-port p)))
(let ([p (open-file-input-port "io-tmp1")])
(test (port-eof? p) #t)
(test/unspec (close-port p)))
;; ----------------------------------------
;; Check buffer modes? Just make sure they're accepted:
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'line)])
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'block)])
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create) 'none)])
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options) 'line)])
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options) 'block)])
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options) 'none)])
(close-port p))
;; ----------------------------------------
;; Transcoders
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block (make-transcoder (latin-1-codec)))])
(test (binary-port? p) #f)
(test (textual-port? p) #t)
(test/unspec (put-string p "apple"))
(test/unspec (put-string p "berry" 3))
(test/unspec (put-string p "berry" 1 1))
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options)
'block (make-transcoder (latin-1-codec)))])
(test (binary-port? p) #f)
(test (textual-port? p) #t)
(test (lookahead-char p) #\a)
(test (get-char p) #\a)
(test (get-string-n p 20) "pplerye")
(test (lookahead-char p) (eof-object))
(test (get-char p) (eof-object))
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block (make-transcoder (utf-8-codec)))])
(test/unspec (put-string p "app\x3BB;e"))
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options)
'block (make-transcoder (latin-1-codec)))])
(test (get-string-n p 20) "app\xCE;\xBB;e")
(close-port p))
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block (make-transcoder (utf-16-codec)))])
(test/unspec (put-string p "app\x3BB;e"))
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options)
'block (make-transcoder (utf-16-codec)))])
(test (get-string-n p 20) "app\x3BB;e")
(close-port p))
(let ([p (open-file-input-port "io-tmp1")])
(let ([b1 (get-u8 p)])
(if (= b1 #xFE)
(begin
(test (get-u8 p) #xFF)
(test (get-u8 p) 0)
(test (get-u8 p) 97))
(begin
(test b1 #xFF)
(test (get-u8 p) #xFE)
(test (get-u8 p) 97)
(test (get-u8 p) 0)))))
(let ([bytevector->string-via-file
(lambda (bv tr)
(let ([p (open-file-output-port "io-tmp1" (file-options no-create))])
(put-bytevector p bv)
(close-port p))
(let ([p (open-file-input-port "io-tmp1" (file-options) 'block tr)])
(dynamic-wind
(lambda () 'ok)
(lambda () (get-string-all p))
(lambda () (close-port p)))))]
[string->bytevector-via-file
(lambda (str tr)
(let ([p (open-file-output-port "io-tmp1" (file-options no-create)
'block tr)])
(put-string p str)
(close-port p))
(let ([p (open-file-input-port "io-tmp1")])
(dynamic-wind
(lambda () 'ok)
(lambda () (get-bytevector-all p))
(lambda () (close-port p)))))])
(test-transcoders bytevector->string-via-file
string->bytevector-via-file))
(test/unspec (delete-file "io-tmp1"))
;; ----------------------------------------
;; bytevector ports
(let ([p (open-bytevector-input-port #vu8(0 1 2 3))])
(test (input-port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test (get-u8 p) 0)
(test (lookahead-u8 p) 1)
(test (get-u8 p) 1)
(let ([bv (make-bytevector 10 0)])
(test/unspec (get-bytevector-n! p bv 1 7))
(test bv #vu8(0 2 3 0 0 0 0 0 0 0)))
(test (get-bytevector-some p) (eof-object))
(close-port p))
(let-values ([(p get) (open-bytevector-output-port)])
(test (output-port? p) #t)
(test (binary-port? p) #t)
(test (textual-port? p) #f)
(test/unspec (put-u8 p 10))
(test/unspec (put-bytevector p #vu8(11 12 13)))
(test/unspec (put-bytevector p #vu8(14 15 16 17 18) 4))
(test/unspec (put-bytevector p #vu8(14 15 16 17 18) 2 1))
(test (get) #vu8(10 11 12 13 18 16))
(test (get) #vu8())
(close-port p))
;; ----------------------------------------
;;
)
#;(run-io-ports-tests)
#;(report-test-results)
)

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

@ -343,7 +343,7 @@ static void force_close_output_port(Scheme_Object *port);
static void force_close_input_port(Scheme_Object *port); static void force_close_input_port(Scheme_Object *port);
static Scheme_Object *text_symbol, *binary_symbol; static Scheme_Object *text_symbol, *binary_symbol;
static Scheme_Object *append_symbol, *error_symbol, *update_symbol; static Scheme_Object *append_symbol, *error_symbol, *update_symbol, *can_update_symbol;
static Scheme_Object *replace_symbol, *truncate_symbol, *truncate_replace_symbol; static Scheme_Object *replace_symbol, *truncate_symbol, *truncate_replace_symbol;
static Scheme_Object *must_truncate_symbol; static Scheme_Object *must_truncate_symbol;
@ -377,6 +377,7 @@ scheme_init_port (Scheme_Env *env)
REGISTER_SO(truncate_symbol); REGISTER_SO(truncate_symbol);
REGISTER_SO(truncate_replace_symbol); REGISTER_SO(truncate_replace_symbol);
REGISTER_SO(update_symbol); REGISTER_SO(update_symbol);
REGISTER_SO(can_update_symbol);
REGISTER_SO(must_truncate_symbol); REGISTER_SO(must_truncate_symbol);
text_symbol = scheme_intern_symbol("text"); text_symbol = scheme_intern_symbol("text");
@ -387,6 +388,7 @@ scheme_init_port (Scheme_Env *env)
truncate_symbol = scheme_intern_symbol("truncate"); truncate_symbol = scheme_intern_symbol("truncate");
truncate_replace_symbol = scheme_intern_symbol("truncate/replace"); truncate_replace_symbol = scheme_intern_symbol("truncate/replace");
update_symbol = scheme_intern_symbol("update"); update_symbol = scheme_intern_symbol("update");
can_update_symbol = scheme_intern_symbol("can-update");
must_truncate_symbol = scheme_intern_symbol("must-truncate"); must_truncate_symbol = scheme_intern_symbol("must-truncate");
REGISTER_SO(scheme_none_symbol); REGISTER_SO(scheme_none_symbol);
@ -3718,6 +3720,16 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
e_set++; e_set++;
} else if (SAME_OBJ(argv[i], update_symbol)) { } else if (SAME_OBJ(argv[i], update_symbol)) {
existsok = 2; existsok = 2;
must_exist = 1;
if (typepos == 1) {
mode[2] = mode[1];
typepos = 2;
}
mode[0] = 'r';
mode[1] = '+';
e_set++;
} else if (SAME_OBJ(argv[i], can_update_symbol)) {
existsok = 3;
if (typepos == 1) { if (typepos == 1) {
mode[2] = mode[1]; mode[2] = mode[1];
typepos = 2; typepos = 2;
@ -3760,7 +3772,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
filename = scheme_expand_string_filename(argv[0], filename = scheme_expand_string_filename(argv[0],
name, NULL, name, NULL,
(SCHEME_GUARD_FILE_WRITE (SCHEME_GUARD_FILE_WRITE
| ((existsok && (existsok != -1)) | ((existsok && ((existsok == 1) || (existsok == -2)))
? SCHEME_GUARD_FILE_DELETE ? SCHEME_GUARD_FILE_DELETE
: 0) : 0)
/* append mode: */ /* append mode: */
@ -3784,9 +3796,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
else if (existsok < 0) else if (existsok < 0)
flags |= O_TRUNC; flags |= O_TRUNC;
if (existsok > 1) if ((existsok <= 1) && (existsok > -1))
flags -= O_CREAT;
else if (existsok > -1)
flags |= O_EXCL; flags |= O_EXCL;
do { do {
@ -3853,6 +3863,8 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
hmode = CREATE_ALWAYS; hmode = CREATE_ALWAYS;
} else if (existsok == 2) { } else if (existsok == 2) {
hmode = OPEN_EXISTING; hmode = OPEN_EXISTING;
} else if (existsok == 3) {
hmode = CREATE_NEW;
} }
fd = CreateFileW(WIDE_PATH(filename), fd = CreateFileW(WIDE_PATH(filename),