'must-update file mode; R6RS tests and bug fixes
svn: r9511
This commit is contained in:
Matthew Flatt
parent
4c893aa7dc
commit
f579d40b82
|
|
@ -1193,7 +1193,7 @@
|
|||
(cond
|
||||
[(and (mcdr c) (= buf-start buf-end))
|
||||
;; 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))
|
||||
(values 0 0 'aborts)
|
||||
(begin
|
||||
|
|
@ -1293,7 +1293,11 @@
|
|||
|
||||
(define reencode-input-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")])
|
||||
(if newline-convert?
|
||||
(mcons c #f)
|
||||
|
|
@ -1386,8 +1390,7 @@
|
|||
bytes-convert)
|
||||
c buf buf-start buf-end ready-bytes)])
|
||||
(unless (memq status '(continues complete))
|
||||
(error 'reencode-input-port-read
|
||||
"unable to make decoding progress: ~e"
|
||||
(decode-error "unable to make decoding progress"
|
||||
port))
|
||||
(set! ready-start 0)
|
||||
(set! ready-end got-c)
|
||||
|
|
@ -1407,9 +1410,7 @@
|
|||
(set! ready-start 0)
|
||||
(set! ready-end (- (bytes-length error-bytes) cnt))
|
||||
cnt))
|
||||
(error
|
||||
'converting-input-port
|
||||
"decoding error in input stream: ~e"
|
||||
(decode-error "decoding error in input stream"
|
||||
port)))
|
||||
|
||||
(unless c
|
||||
|
|
@ -1437,7 +1438,11 @@
|
|||
|
||||
(define reencode-output-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)]
|
||||
[ready-bytes (make-bytes 1024)]
|
||||
[ready-start 0]
|
||||
|
|
@ -1711,16 +1716,14 @@
|
|||
;; Raise an exception:
|
||||
(begin
|
||||
(set! out-start (add1 out-start))
|
||||
(error
|
||||
'reencode-output-port
|
||||
"error decoding output to stream: ~e"
|
||||
(decode-error
|
||||
"error decoding output to stream"
|
||||
port))))))))
|
||||
|
||||
;; This error is used when decoding wants more bytes to make progress even
|
||||
;; though we've supplied hundreds of bytes
|
||||
(define (raise-insane-decoding-length)
|
||||
(error 'reencode-output-port-write
|
||||
"unable to make decoding progress: ~e"
|
||||
(decode-error "unable to make decoding progress"
|
||||
port))
|
||||
|
||||
;; Check that a decoder is available:
|
||||
|
|
|
|||
|
|
@ -1,8 +1,271 @@
|
|||
#lang scheme
|
||||
#lang scheme/base
|
||||
|
||||
(provide (struct-out exn:fail:r6rs)
|
||||
(struct-out exn:fail:contract:r6rs))
|
||||
(require rnrs/records/syntactic-6
|
||||
rnrs/records/procedural-6
|
||||
scheme/mpair
|
||||
"exns.ss"
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(define-struct (exn:fail:r6rs exn:fail) (who irritants))
|
||||
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants))
|
||||
(provide &condition
|
||||
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
10
collects/r6rs/private/exns.ss
Normal 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))
|
||||
|
|
@ -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-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)
|
||||
(import (rnrs base (6))
|
||||
(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)))
|
||||
(import (r6rs private conds)))
|
||||
|
|
|
|||
|
|
@ -252,16 +252,27 @@
|
|||
(define (default-protocol rtd)
|
||||
(let ((parent (record-type-parent rtd)))
|
||||
(if (not parent)
|
||||
(lambda (p)
|
||||
(lambda field-values
|
||||
(apply p field-values)))
|
||||
(let ((parent-field-count (field-count parent)))
|
||||
(lambda (p) p)
|
||||
(let ((parent-field-count (field-count parent))
|
||||
(count (field-count rtd)))
|
||||
(lambda (p)
|
||||
(lambda all-field-values
|
||||
(if (= (length all-field-values) count)
|
||||
(call-with-values
|
||||
(lambda () (split-at all-field-values parent-field-count))
|
||||
(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)
|
||||
(typed-vector-ref :record-constructor-descriptor desc 0))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(require (for-syntax r6rs/private/base-for-syntax
|
||||
scheme/base)
|
||||
r6rs/private/qq-gen
|
||||
r6rs/private/conds
|
||||
r6rs/private/exns
|
||||
(prefix-in r5rs: r5rs)
|
||||
(only-in r6rs/private/readtable rx:number)
|
||||
scheme/bool)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require rnrs/records/syntactic-6
|
||||
rnrs/records/procedural-6
|
||||
r6rs/private/conds
|
||||
scheme/mpair
|
||||
(for-syntax scheme/base))
|
||||
(require r6rs/private/conds)
|
||||
|
||||
(provide &condition
|
||||
condition?
|
||||
|
|
@ -27,181 +23,3 @@
|
|||
&lexical make-lexical-violation lexical-violation?
|
||||
&syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
|
||||
&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?)
|
||||
|
|
|
|||
|
|
@ -239,14 +239,14 @@
|
|||
#'(begin
|
||||
(define enum-universe (make-enumeration-universe (mlist 'sym ...)))
|
||||
(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]
|
||||
...
|
||||
[(_ other)
|
||||
(identifier? #'other)
|
||||
(raise-syntax-error #f "not in enumeration" stx #'other)]))
|
||||
(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 s)
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
rnrs/conditions-6
|
||||
r6rs/private/io-conds
|
||||
r6rs/private/readtable
|
||||
r6rs/private/exns
|
||||
scheme/port
|
||||
scheme/pretty)
|
||||
|
||||
|
|
@ -182,7 +183,8 @@
|
|||
1
|
||||
(case-lambda
|
||||
[() (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 ()
|
||||
(set! disconnected? #t)
|
||||
port)))
|
||||
|
|
@ -199,14 +201,16 @@
|
|||
(lambda (bytes start end can-buffer/block? enable-breaks?)
|
||||
(check-disconnect)
|
||||
(if (= start end)
|
||||
(begin
|
||||
(flush-output port)
|
||||
0)
|
||||
(cond
|
||||
[enable-breaks?
|
||||
(parameterize-break #t (write-bytes (subbytes start end) port))]
|
||||
(parameterize-break #t (write-bytes (subbytes bytes start end) port))]
|
||||
[can-buffer/block?
|
||||
(write-bytes (subbytes start end) port)]
|
||||
[else
|
||||
(write-bytes-avail* (subbytes start end) port)])))
|
||||
(write-bytes-avail* (subbytes bytes start end) port)])))
|
||||
(lambda ()
|
||||
(unless disconnected?
|
||||
(close-output-port port)))
|
||||
|
|
@ -316,6 +320,7 @@
|
|||
p)])
|
||||
(if (no-op-transcoder? t)
|
||||
p
|
||||
(letrec ([self
|
||||
(reencode-input-port p
|
||||
(codec-enc (transcoder-codec t))
|
||||
(case (transcoder-error-handling-mode t)
|
||||
|
|
@ -324,7 +329,15 @@
|
|||
[(replace) (string->bytes/utf-8 "\uFFFD")])
|
||||
#t
|
||||
(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)
|
||||
(let ([p (cond
|
||||
|
|
@ -335,6 +348,7 @@
|
|||
[else p])])
|
||||
(if (no-op-transcoder? t)
|
||||
p
|
||||
(letrec ([self
|
||||
(reencode-output-port p
|
||||
(codec-enc (transcoder-codec t))
|
||||
(case (transcoder-error-handling-mode t)
|
||||
|
|
@ -351,7 +365,16 @@
|
|||
[(crnel) (string->bytes/utf-8 "\r\u85")]
|
||||
[(ls) (string->bytes/utf-8 "\u2028")]
|
||||
[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)
|
||||
(unless (and (port? p)
|
||||
|
|
@ -374,9 +397,9 @@
|
|||
(raise-type-error 'port-has-port-position? "port" p))
|
||||
(cond
|
||||
[(binary-input-port? p)
|
||||
(and (binary-input-port-get-pos p))]
|
||||
(and (binary-input-port-get-pos p) #t)]
|
||||
[(binary-output-port? p)
|
||||
(and (binary-output-port-get-pos p))]
|
||||
(and (binary-output-port-get-pos p) #t)]
|
||||
[(textual-input-port? p)
|
||||
(port-has-port-position? (textual-input-port-port p))]
|
||||
[(textual-output-port? p)
|
||||
|
|
@ -467,7 +490,9 @@
|
|||
(unless (transcoder? maybe-transcoder)
|
||||
(raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder)))
|
||||
(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
|
||||
(transcoded-port p maybe-transcoder)
|
||||
(wrap-binary-input-port p
|
||||
|
|
@ -589,7 +614,7 @@
|
|||
(raise-type-error 'get-bytevector-all "binary port" p))
|
||||
(let ([p2 (open-output-bytes)])
|
||||
(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))
|
||||
(let ([p2 (open-output-bytes)])
|
||||
(copy-port p p2)
|
||||
(get-output-string p)))
|
||||
(get-output-string p2)))
|
||||
|
||||
(define (get-line p)
|
||||
(unless (textual-port? p)
|
||||
|
|
@ -660,25 +685,36 @@
|
|||
(when maybe-transcoder
|
||||
(unless (transcoder? maybe-transcoder)
|
||||
(raise-type-error who "transcoder or #f" maybe-transcoder)))
|
||||
(let ([p (open-output-file filename
|
||||
#:exists (cond
|
||||
(let ([exists-mode (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=? options (file-options no-fail no-truncate))
|
||||
'can-update]
|
||||
[(enum-set-member? 'no-create options) ; no-create, no-create + no-fail
|
||||
'must-truncate]
|
||||
[(enum-set-member? 'no-fail options) ; no-fail
|
||||
'truncate]
|
||||
[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)
|
||||
(if maybe-transcoder
|
||||
(transcoded-port p maybe-transcoder)
|
||||
(wrap-binary-port p
|
||||
(lambda () (file-position p))
|
||||
(lambda (pos) (file-position p pos))))))
|
||||
(lambda (pos) (file-position p pos)))))))
|
||||
|
||||
(define (open-file-output-port filename
|
||||
[options (file-options)]
|
||||
|
|
@ -697,14 +733,17 @@
|
|||
(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
|
||||
(let* ([p (open-output-bytes)]
|
||||
[p2 (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)))))
|
||||
(lambda (pos) (file-position p pos))))])
|
||||
(values
|
||||
p2
|
||||
(lambda ()
|
||||
(flush-output p2)
|
||||
(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)])
|
||||
|
|
@ -943,14 +982,14 @@
|
|||
(unless (transcoder? t)
|
||||
(raise-type-error 'bytevector->string "transcoder" t))
|
||||
(let ([p #f])
|
||||
(dynamic-require
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! p (open-bytevector-input-port bv t)))
|
||||
(lambda ()
|
||||
(apply
|
||||
string-append
|
||||
(let loop ()
|
||||
(let ([s (get-string-n p)])
|
||||
(let ([s (get-string-n p 4096)])
|
||||
(if (eof-object? s)
|
||||
null
|
||||
(cons s (loop)))))))
|
||||
|
|
@ -961,11 +1000,11 @@
|
|||
(raise-type-error 'string->bytevector "transcoder" t))
|
||||
(let ([p #f]
|
||||
[result #f])
|
||||
(dynamic-require
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set!-values (p result) (open-bytevector-output-port t)))
|
||||
(lambda ()
|
||||
(put-string s p)
|
||||
(put-string p s)
|
||||
(result))
|
||||
(lambda () (close-output-port p)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -12,10 +12,10 @@
|
|||
call-with-output-file*)
|
||||
|
||||
(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
|
||||
"'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
|
||||
(let ([open-input-file (lambda (path #:mode [mode 'binary])
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ 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
|
||||
[#:exists exists-flag (one-of/c 'error 'append 'update 'can-update
|
||||
'replace 'truncate
|
||||
'must-truncate 'truncate/replace) 'error])
|
||||
output-port?]{
|
||||
|
|
@ -113,6 +113,9 @@ files that already exist:
|
|||
truncating it; if the file does not exist, the
|
||||
@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,
|
||||
whether it already exists or not; under Windows,
|
||||
@scheme['append] is equivalent to @scheme['update], except that
|
||||
|
|
|
|||
|
|
@ -188,7 +188,9 @@ it defaults to @scheme[0].}
|
|||
[error-bytes (or/c false/c bytes?)]
|
||||
[close? any/c #t]
|
||||
[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?]{
|
||||
|
||||
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
|
||||
given byte sequence is used in place of bytes from @scheme[in] that
|
||||
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
|
||||
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?)]
|
||||
[close? any/c #t]
|
||||
[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?]{
|
||||
|
||||
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
|
||||
given byte sequence is used in place of bytes send to the output port
|
||||
that trigger conversion errors. Otherwise, if a conversion is
|
||||
encountered, the @exnraise[exn:fail].
|
||||
that trigger conversion errors. Otherwise, @scheme[enc-error] is
|
||||
called, which must raise an exception.
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -187,6 +187,67 @@
|
|||
(make-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)
|
||||
|
||||
;;
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -5,11 +5,363 @@
|
|||
(import (rnrs)
|
||||
(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)
|
||||
|
||||
(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 (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)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -343,7 +343,7 @@ static void force_close_output_port(Scheme_Object *port);
|
|||
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 *append_symbol, *error_symbol, *update_symbol, *can_update_symbol;
|
||||
static Scheme_Object *replace_symbol, *truncate_symbol, *truncate_replace_symbol;
|
||||
static Scheme_Object *must_truncate_symbol;
|
||||
|
||||
|
|
@ -377,6 +377,7 @@ scheme_init_port (Scheme_Env *env)
|
|||
REGISTER_SO(truncate_symbol);
|
||||
REGISTER_SO(truncate_replace_symbol);
|
||||
REGISTER_SO(update_symbol);
|
||||
REGISTER_SO(can_update_symbol);
|
||||
REGISTER_SO(must_truncate_symbol);
|
||||
|
||||
text_symbol = scheme_intern_symbol("text");
|
||||
|
|
@ -387,6 +388,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");
|
||||
can_update_symbol = scheme_intern_symbol("can-update");
|
||||
must_truncate_symbol = scheme_intern_symbol("must-truncate");
|
||||
|
||||
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++;
|
||||
} else if (SAME_OBJ(argv[i], update_symbol)) {
|
||||
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) {
|
||||
mode[2] = mode[1];
|
||||
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],
|
||||
name, NULL,
|
||||
(SCHEME_GUARD_FILE_WRITE
|
||||
| ((existsok && (existsok != -1))
|
||||
| ((existsok && ((existsok == 1) || (existsok == -2)))
|
||||
? SCHEME_GUARD_FILE_DELETE
|
||||
: 0)
|
||||
/* append mode: */
|
||||
|
|
@ -3784,9 +3796,7 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
|
|||
else if (existsok < 0)
|
||||
flags |= O_TRUNC;
|
||||
|
||||
if (existsok > 1)
|
||||
flags -= O_CREAT;
|
||||
else if (existsok > -1)
|
||||
if ((existsok <= 1) && (existsok > -1))
|
||||
flags |= O_EXCL;
|
||||
|
||||
do {
|
||||
|
|
@ -3853,6 +3863,8 @@ scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv
|
|||
hmode = CREATE_ALWAYS;
|
||||
} else if (existsok == 2) {
|
||||
hmode = OPEN_EXISTING;
|
||||
} else if (existsok == 3) {
|
||||
hmode = CREATE_NEW;
|
||||
}
|
||||
|
||||
fd = CreateFileW(WIDE_PATH(filename),
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user