diff --git a/collects/r6rs/private/readtable.ss b/collects/r6rs/private/readtable.ss index 8d24f0a707..f86cfb91d3 100644 --- a/collects/r6rs/private/readtable.ss +++ b/collects/r6rs/private/readtable.ss @@ -6,6 +6,7 @@ (for-syntax scheme/base)) (provide with-r6rs-reader-parameters + rx:id rx:number) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss index bc15255eac..32e38c13fc 100644 --- a/collects/rnrs/io/ports-6.ss +++ b/collects/rnrs/io/ports-6.ss @@ -930,6 +930,19 @@ [pretty-print-size-hook (lambda (v write? p) (cond + [(symbol? v) + (let ([s (symbol->string v)]) + (and (not (regexp-match rx:id s)) + (for/fold ([len 0]) + ([c (in-string s)] + [pos (in-naturals)]) + (+ len + (if (or (char-alphabetic? c) + (and (char-numeric? c) + (positive? pos))) + 1 + (+ 3 (string-length + (number->string (char->integer c) 16))))))))] [(string? v) (and (for/or ([c (in-string v)]) (not (or (char-graphic? c) @@ -966,6 +979,17 @@ [pretty-print-print-hook (lambda (v write? p) (cond + [(symbol? v) + (for ([c (in-string (symbol->string v))] + [pos (in-naturals)]) + (if (or (char-alphabetic? c) + (and (char-numeric? c) + (positive? pos))) + (display c p) + (begin + (display "\\x" p) + (display (number->string (char->integer c) 16) p) + (display ";" p))))] [(string? v) (write-char #\" p) (for ([c (in-string v)]) diff --git a/collects/rnrs/syntax-case-6.ss b/collects/rnrs/syntax-case-6.ss index f19f319a5e..8b40e09ac5 100644 --- a/collects/rnrs/syntax-case-6.ss +++ b/collects/rnrs/syntax-case-6.ss @@ -205,7 +205,8 @@ (mcons (unwrap (car p) (car mapping)) (unwrap (cdr p) (cdr mapping))))] [(vector? mapping) - (list->vector (unwrap (vector->list (syntax-e stx)) (vector->list mapping)))] + (list->vector (mlist->list (unwrap (vector->list (syntax-e stx)) (vector->list mapping))))] + [(null? mapping) null] [(box? mapping) ;; ellipses (let* ([mapping (unbox mapping)] @@ -254,7 +255,7 @@ repeats (mappend repeats (unwrap rest-stx rest-mapping)))))] - [else (error 'unwrap "srtange unwrap mapping: ~e" mapping)])) + [else (error 'unwrap "strange unwrap mapping: ~e" mapping)])) (define-syntax (r6rs:syntax stx) (syntax-case stx () diff --git a/collects/tests/r6rs/io/ports.ss b/collects/tests/r6rs/io/ports.ss index 4fb508e6a1..8c50edc002 100644 --- a/collects/tests/r6rs/io/ports.ss +++ b/collects/tests/r6rs/io/ports.ss @@ -722,9 +722,19 @@ (test-rw 1+2.0i) (test-rw #t) (test-rw #f) + (test-rw 'apple) + (test-rw (string->number "app\x3BB;e")) + (test-rw (string->symbol " ")) + (test-rw (string->symbol "+")) + (test-rw (string->symbol "0")) + (test-rw (string->symbol "app\x1678;e")) + (test-rw 'a1) + (test-rw '->) + (test-rw '...) (test-rw "apple") (test-rw "app\x3BB;e") (test-rw "app\x1678;e") + (test-rw "\r\n") (test-rw #\a) (test-rw #\x3BB) (test-rw #\nul) diff --git a/collects/tests/r6rs/io/simple.ss b/collects/tests/r6rs/io/simple.ss new file mode 100644 index 0000000000..ec8f006073 --- /dev/null +++ b/collects/tests/r6rs/io/simple.ss @@ -0,0 +1,94 @@ +#!r6rs + +(library (tests r6rs io simple) + (export run-io-simple-tests) + (import (rnrs) + (tests r6rs test)) + + (define (run-io-simple-tests) + + (test/unspec + (when (file-exists? "io-tmp2") + (delete-file "io-tmp2"))) + + (test/values (call-with-output-file "io-tmp2" + (lambda (p) + (test (output-port? p) #t) + (test (binary-port? p) #f) + (test (textual-port? p) #t) + (test/unspec (write-char #\q p)) + (test/unspec (newline p)) + (test/unspec (display "more" p)) + (test/unspec (write "last" p)) + (values 3 4))) + 3 4) + + (test/values (call-with-input-file "io-tmp2" + (lambda (p) + (test (input-port? p) #t) + (test (binary-port? p) #f) + (test (textual-port? p) #t) + (test (peek-char p) #\q) + (test (read-char p) #\q) + (test (read-char p) #\newline) + (test (read-char p) #\m) + (test (read-char p) #\o) + (test (peek-char p) #\r) + (test (read-char p) #\r) + (test (read-char p) #\e) + (test (read p) "last") + (test (read p) (eof-object)) + (values 7 8 9))) + 7 8 9) + + (test/unspec (delete-file "io-tmp2")) + + (let ([p (open-output-file "io-tmp2")]) + (test (output-port? p) #t) + (test (binary-port? p) #f) + (test (textual-port? p) #t) + (test/unspec (write-char #\! p)) + (test/unspec (close-output-port p))) + + (let ([p (open-input-file "io-tmp2")]) + (test (input-port? p) #t) + (test (binary-port? p) #f) + (test (textual-port? p) #t) + (test (read-char p) #\!) + (test/unspec (close-input-port p))) + + (test/unspec (delete-file "io-tmp2")) + + (test/values (with-output-to-file "io-tmp2" + (lambda () + (test/unspec (write-char #\z)) + (test/unspec (newline)) + (test/unspec (display "a")) + (test/unspec (write "a")) + (values 30 40))) + 30 40) + + (test/values (with-input-from-file "io-tmp2" + (lambda () + (test (peek-char) #\z) + (test (read-char) #\z) + (test (read) 'a) + (test (read) "a") + (test (read) (eof-object)) + (values 70 80 90))) + 70 80 90) + + (test (input-port? (current-input-port)) #t) + (test (binary-port? (current-input-port)) #f) + (test (textual-port? (current-input-port)) #t) + + (test (output-port? (current-output-port)) #t) + (test (binary-port? (current-output-port)) #f) + (test (textual-port? (current-output-port)) #t) + + (test (output-port? (current-error-port)) #t) + (test (binary-port? (current-error-port)) #f) + (test (textual-port? (current-error-port)) #t) + + ;; + )) diff --git a/collects/tests/r6rs/run.ss b/collects/tests/r6rs/run.ss index 4397449654..909df6954b 100644 --- a/collects/tests/r6rs/run.ss +++ b/collects/tests/r6rs/run.ss @@ -14,6 +14,7 @@ (tests r6rs exceptions) (tests r6rs conditions) (tests r6rs io ports) + (tests r6rs io simple) (tests r6rs programs) (tests r6rs arithmetic fixnums) (tests r6rs arithmetic flonums) @@ -39,6 +40,7 @@ (run-exceptions-tests) (run-conditions-tests) (run-io-ports-tests) +(run-io-simple-tests) (run-programs-tests) (run-arithmetic-fixnums-tests) (run-arithmetic-flonums-tests)