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

r6rs io/simple tests; syntax-case bug fix (PR 9328)

Browse Source 
svn: r9535
This commit is contained in:
Matthew Flatt 2008-04-29 13:30:09 +00:00
parent 94ccfc68c6
commit c71192136e
6 changed files with 134 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,6 +6,7 @@
(for-syntax scheme/base))
(provide with-r6rs-reader-parameters
rx:id
rx:number)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -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)])

5
collects/rnrs/syntax-case-6.ss
View File

@ -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 ()

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

@ -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)

94
collects/tests/r6rs/io/simple.ss Normal file
View File

@ -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)
;;
))

2
collects/tests/r6rs/run.ss
View File

@ -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)