From f579d40b821aa7f9bdb0ec789745fd9918ad1e86 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 28 Apr 2008 16:32:50 +0000 Subject: [PATCH] 'must-update file mode; R6RS tests and bug fixes svn: r9511 --- collects/mzlib/port.ss | 37 +- collects/r6rs/private/conds.ss | 273 +++++++++++++- collects/r6rs/private/exns.ss | 10 + collects/r6rs/private/io-conds.ss | 45 +-- collects/r6rs/private/records-core.ss | 31 +- collects/rnrs/base-6.ss | 2 +- collects/rnrs/conditions-6.ss | 184 +-------- collects/rnrs/enums-6.ss | 4 +- collects/rnrs/io/ports-6.ss | 169 +++++---- collects/scheme/private/kw-file.ss | 4 +- .../scribblings/reference/file-ports.scrbl | 5 +- collects/scribblings/reference/port-lib.scrbl | 14 +- collects/tests/r6rs/conditions.ss | 61 +++ collects/tests/r6rs/io/ports.ss | 356 +++++++++++++++++- src/mzscheme/src/port.c | 22 +- 15 files changed, 875 insertions(+), 342 deletions(-) create mode 100644 collects/r6rs/private/exns.ss diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index dd6ed8d264..59384f4b14 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -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,9 +1390,8 @@ 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" - port)) + (decode-error "unable to make decoding progress" + port)) (set! ready-start 0) (set! ready-end got-c) (set! buf-start (+ used-c buf-start)) @@ -1407,11 +1410,9 @@ (set! ready-start 0) (set! ready-end (- (bytes-length error-bytes) cnt)) cnt)) - (error - 'converting-input-port - "decoding error in input stream: ~e" - port))) - + (decode-error "decoding error in input stream" + port))) + (unless c (error 'reencode-input-port "could not create converter from ~e to UTF-8" @@ -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,17 +1716,15 @@ ;; 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" - port)) + (decode-error "unable to make decoding progress" + port)) ;; Check that a decoder is available: (unless c diff --git a/collects/r6rs/private/conds.ss b/collects/r6rs/private/conds.ss index ba6416694b..fea642648e 100644 --- a/collects/r6rs/private/conds.ss +++ b/collects/r6rs/private/conds.ss @@ -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)) diff --git a/collects/r6rs/private/exns.ss b/collects/r6rs/private/exns.ss new file mode 100644 index 0000000000..dd5e8fa313 --- /dev/null +++ b/collects/r6rs/private/exns.ss @@ -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)) diff --git a/collects/r6rs/private/io-conds.ss b/collects/r6rs/private/io-conds.ss index a534049a30..e288e05f0d 100644 --- a/collects/r6rs/private/io-conds.ss +++ b/collects/r6rs/private/io-conds.ss @@ -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))) diff --git a/collects/r6rs/private/records-core.ss b/collects/r6rs/private/records-core.ss index 02c1c17764..334b9a20ab 100644 --- a/collects/r6rs/private/records-core.ss +++ b/collects/r6rs/private/records-core.ss @@ -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) - (lambda all-field-values - (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))))))))) + (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))) + (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)) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 5550e18379..f5ec2483fc 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -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) diff --git a/collects/rnrs/conditions-6.ss b/collects/rnrs/conditions-6.ss index 8322e13893..f956cd0fec 100644 --- a/collects/rnrs/conditions-6.ss +++ b/collects/rnrs/conditions-6.ss @@ -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?) diff --git a/collects/rnrs/enums-6.ss b/collects/rnrs/enums-6.ss index 441c2babfc..f1ba2fbb18 100644 --- a/collects/rnrs/enums-6.ss +++ b/collects/rnrs/enums-6.ss @@ -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) diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss index 3b99a68bb9..7d70d634de 100644 --- a/collects/rnrs/io/ports-6.ss +++ b/collects/rnrs/io/ports-6.ss @@ -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) - (flush-output port) + (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,15 +320,24 @@ p)]) (if (no-op-transcoder? t) p - (reencode-input-port p - (codec-enc (transcoder-codec t)) - (case (transcoder-error-handling-mode t) - [(raise) #f] - [(ignore) #""] - [(replace) (string->bytes/utf-8 "\uFFFD")]) - #t - (object-name p) - (not (eq? (transcoder-eol-style t) 'none)))))) + (letrec ([self + (reencode-input-port p + (codec-enc (transcoder-codec t)) + (case (transcoder-error-handling-mode t) + [(raise) #f] + [(ignore) #""] + [(replace) (string->bytes/utf-8 "\uFFFD")]) + #t + (object-name p) + (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,23 +348,33 @@ [else p])]) (if (no-op-transcoder? t) p - (reencode-output-port p - (codec-enc (transcoder-codec t)) - (case (transcoder-error-handling-mode t) - [(raise) #f] - [(ignore) #""] - [(replace) (string->bytes/utf-8 "\uFFFD")]) - #t - (object-name p) - (case (transcoder-eol-style t) - [(lf none) #f] - [(cr) #"\r"] - [(crlf) #"\r\n"] - [(nel) (string->bytes/utf-8 "\u85")] - [(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))]))))) + (letrec ([self + (reencode-output-port p + (codec-enc (transcoder-codec t)) + (case (transcoder-error-handling-mode t) + [(raise) #f] + [(ignore) #""] + [(replace) (string->bytes/utf-8 "\uFFFD")]) + #t + (object-name p) + (case (transcoder-eol-style t) + [(lf none) #f] + [(cr) #"\r"] + [(crlf) #"\r\n"] + [(nel) (string->bytes/utf-8 "\u85")] + [(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))]) + (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 - [(or (enum-set=? options (file-options no-create no-fail no-truncate)) - (enum-set=? options (file-options no-create no-truncate))) - 'must-update] - [(enum-set=? options (file-options no-fail no-truncate)) - 'update] - [(enum-set-member? 'no-create options) ; no-create, no-create + no-fail - 'must-truncate] - [(enum-set-member? 'no-fail options) ; no-fail - 'truncate] - [else ; no-truncate, - 'error]))]) - (file-stream-buffer-mode p buffer-mode) - (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)))))) + (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))) + '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, + '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))))))) (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)]) + (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))))]) (values - (if maybe-transcoder - (transcoded-port p maybe-transcoder) - (wrap-binary-output-port p - (lambda () (file-position p)) - (lambda (pos) (file-position p pos)))) - (lambda () (get-output-bytes p #t))))) + 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))))) diff --git a/collects/scheme/private/kw-file.ss b/collects/scheme/private/kw-file.ss index 2596d8ffa7..22318e788a 100644 --- a/collects/scheme/private/kw-file.ss +++ b/collects/scheme/private/kw-file.ss @@ -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]) diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index c65a80a12d..1085aadbef 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -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 diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index 67a2ed5ed7..2a20078db2 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -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 diff --git a/collects/tests/r6rs/conditions.ss b/collects/tests/r6rs/conditions.ss index be1ef06a24..6452ab2e2b 100644 --- a/collects/tests/r6rs/conditions.ss +++ b/collects/tests/r6rs/conditions.ss @@ -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) + ;; )) diff --git a/collects/tests/r6rs/io/ports.ss b/collects/tests/r6rs/io/ports.ss index 0fdc5341b8..b3a39e48c1 100644 --- a/collects/tests/r6rs/io/ports.ss +++ b/collects/tests/r6rs/io/ports.ss @@ -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) + ) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 1b7ec435ad..c7baa0896d 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -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),